Changeset 13124 for trunk/source/level-1/l1-reader.lisp
- Timestamp:
- Oct 29, 2009, 5:43:04 PM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-reader.lisp
r13067 r13124 3008 3008 (let* ((file (source-note-filename sn)) 3009 3009 (text (ignore-errors (source-note-text sn)))) 3010 ;; Should fix this when record the name. 3011 (when (eq (pathname-version file) :newest) 3012 (setq file (namestring (make-pathname :version nil :defaults file)))) 3010 (when file 3011 ;; Should fix this when record the name. 3012 (when (eq (pathname-version file) :newest) 3013 (setq file (namestring (make-pathname :version nil :defaults file))))) 3013 3014 (when text 3014 3015 (setq text (string-sans-most-whitespace text 121)) 3015 3016 (when (> (length text) 120) 3016 3017 (setq text (concatenate 'string (subseq text 0 120) "...")))) 3017 (format stream "~s:~s-~s ~s" file 3018 (source-note-start-pos sn) (source-note-end-pos sn) 3019 text))) 3018 (if file 3019 (format stream "*~s:~s-~s ~s" file 3020 (source-note-start-pos sn) (source-note-end-pos sn) 3021 text) 3022 (format stream "Interactive ~s" text)))) 3020 3023 3021 3024 (defun source-note-filename (source) … … 3109 3112 (null (values (read-internal stream nil eofval nil) nil)) 3110 3113 (hash-table 3111 (let* ((recording (list stream map file-name start-offset)) 3114 (let* ((stream (recording-input-stream stream)) 3115 (recording (list stream map file-name start-offset)) 3112 3116 (*recording-source-streams* (cons recording *recording-source-streams*))) 3113 3117 (declare (dynamic-extent recording *recording-source-streams*)) … … 3134 3138 start-offset))))) 3135 3139 (values form source-note)))) 3136 (T 3140 (T ;; not clear if this is ever useful 3137 3141 (let* ((start-pos (stream-position stream)) 3138 3142 (form (read-internal stream nil eofval nil)) … … 3146 3150 (values form source-note))))) 3147 3151 3148 (def un fetch-octets-from-stream (streamstart-offset end-offset)3152 (defmethod fetch-octets-from-stream ((stream input-stream) start-offset end-offset) 3149 3153 ;; We basically want to read the bytes between two positions, but there is no 3150 3154 ;; direct interface for that. So we let the stream decode and then we re-encode. … … 3197 3201 (etypecase source 3198 3202 (null 3199 (with-open-file (stream filename :if-does-not-exist if-does-not-exist) 3200 (when stream 3201 (let ((start (source-note-start-pos source-note)) 3202 (end (source-note-end-pos source-note)) 3203 (len (file-length stream))) 3204 (if (<= end len) 3205 (setf (source-note.source source-note) 3206 (fetch-octets-from-stream stream start end)) 3207 (when if-does-not-exist 3208 (error 'simple-file-error :pathname filename 3209 :error-type "File ~s changed since source info recorded"))))))) 3203 (if filename 3204 (with-open-file (stream filename :if-does-not-exist if-does-not-exist) 3205 (when stream 3206 (let ((start (source-note-start-pos source-note)) 3207 (end (source-note-end-pos source-note)) 3208 (len (file-length stream))) 3209 (if (<= end len) 3210 (setf (source-note.source source-note) 3211 (fetch-octets-from-stream stream start end)) 3212 (when if-does-not-exist 3213 (error 'simple-file-error :pathname filename 3214 :error-type "File ~s changed since source info recorded")))))) 3215 (when if-does-not-exist 3216 (error "Missing source text in internative source note")))) 3210 3217 (source-note 3211 3218 (ensure-source-note-text source)) … … 3221 3228 3222 3229 3230 ;;; Wrapper stream for recording source of non-random-access streams. 3231 (defclass recording-character-input-stream (fundamental-stream character-input-stream) 3232 ((input-stream :initarg :input-stream) 3233 (string :initform (make-array 1024 :element-type 'character :fill-pointer 0 :adjustable t)))) 3234 3235 (defmethod stream-element-type ((s recording-character-input-stream)) 3236 (with-slots (input-stream) s 3237 (stream-element-type input-stream))) 3238 3239 (defmethod stream-read-char ((s recording-character-input-stream)) 3240 (with-slots (input-stream string) s 3241 (let ((char (stream-read-char input-stream))) 3242 (when (and char (neq char :eof)) 3243 (vector-push-extend char string)) 3244 char))) 3245 3246 (defmethod stream-read-char-no-hang ((s recording-character-input-stream)) 3247 (with-slots (input-stream string) s 3248 (let ((char (stream-read-char-no-hang input-stream))) 3249 (when (and char (neq char :eof)) 3250 (vector-push-extend char string)) 3251 char))) 3252 3253 (defmethod stream-peek-char ((s recording-character-input-stream)) 3254 (with-slots (input-stream) s 3255 (stream-peek-char input-stream))) 3256 3257 (defmethod stream-listen ((s recording-character-input-stream)) 3258 (with-slots (input-stream) s 3259 (stream-listen input-stream))) 3260 3261 (defmethod stream-read-line ((s recording-character-input-stream)) 3262 (generic-read-line s)) 3263 3264 (defmethod stream-read-list ((s recording-character-input-stream) list count) 3265 (generic-character-read-list s list count)) 3266 3267 (defmethod stream-read-vector ((s recording-character-input-stream) vector start end) 3268 (generic-character-read-vector s vector start end)) 3269 3270 (defmethod stream-unread-char ((s recording-character-input-stream) char) 3271 (with-slots (input-stream string) s 3272 (vector-pop string) ;; Error if no characters read since last reset. 3273 (stream-unread-char input-stream char))) 3274 3275 (defmethod stream-eofp ((s recording-character-input-stream)) 3276 (with-slots (input-stream) s 3277 (stream-eofp input-stream))) 3278 3279 (defmethod stream-clear-input ((s recording-character-input-stream)) 3280 (with-slots (input-stream) s 3281 (stream-clear-input input-stream))) 3282 3283 (defmethod stream-position ((s recording-character-input-stream) &optional newpos) 3284 (with-slots (string) s 3285 (unless newpos 3286 (fill-pointer string)))) 3287 3288 (defun recording-input-stream (stream) 3289 (let ((pos (stream-position stream))) 3290 (if (and pos (stream-position stream pos)) 3291 stream 3292 (make-instance 'recording-character-input-stream :input-stream stream)))) 3293 3294 (defmethod fetch-octets-from-stream ((s recording-character-input-stream) start-offset end-offset) 3295 (declare (fixnum start-offset end-offset)) 3296 (with-slots (string) s 3297 (when (< start-offset end-offset) 3298 (let* ((sstring (array-data-and-offset string)) 3299 (noctets (loop for i fixnum from start-offset below end-offset 3300 as code fixnum = (%char-code (%schar sstring i)) 3301 sum (cond ((< code #x80) 1) 3302 ((< code #x800) 2) 3303 ((< code #x10000) 3) 3304 (t 4)) 3305 of-type fixnum)) 3306 (vec (make-array noctets :element-type '(unsigned-byte 8))) 3307 (index 0)) 3308 (declare (type fixnum noctets index) 3309 (type simple-base-string sstring) 3310 (type (simple-array (unsigned-byte 8) (*)) vec)) 3311 (macrolet ((out (octet) `(progn 3312 (setf (aref vec index) ,octet) 3313 (incf index)))) 3314 (loop for i fixnum from start-offset below end-offset 3315 as code fixnum = (%char-code (%schar sstring i)) 3316 do (cond ((< code #x80) 3317 (out code)) 3318 ((< code #x800) 3319 (out (logior #xc0 (ldb (byte 5 6) code))) 3320 (out (logior #x80 (ldb (byte 6 0) code)))) 3321 ((< code #x10000) 3322 (out (logior #xe0 (ldb (byte 4 12) code))) 3323 (out (logior #x80 (ldb (byte 6 6) code))) 3324 (out (logior #x80 (ldb (byte 6 0) code)))) 3325 (t 3326 (out (logior #xf0 (ldb (byte 3 18) code))) 3327 (out (logior #xe0 (ldb (byte 6 12) code))) 3328 (out (logior #x80 (ldb (byte 6 6) code))) 3329 (out (logior #x80 (ldb (byte 6 0) code))))))) 3330 (setf (fill-pointer string) 0) ;; reset 3331 vec)))) 3332 3333 3334 3223 3335 3224 3336 ; end
Note: See TracChangeset
for help on using the changeset viewer.