Ignore:
Timestamp:
Oct 29, 2009, 5:43:04 PM (10 years ago)
Author:
gz
Message:

Recording source text in read-loop (useful for disassembly). It's now possible have a source note with null filename, fix a couple places to account for that.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-reader.lisp

    r13067 r13124  
    30083008  (let* ((file (source-note-filename sn))
    30093009         (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)))))
    30133014    (when text
    30143015      (setq text (string-sans-most-whitespace text 121))
    30153016      (when (> (length text) 120)
    30163017        (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))))
    30203023
    30213024(defun source-note-filename (source)
     
    31093112    (null (values (read-internal stream nil eofval nil) nil))
    31103113    (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))
    31123116              (*recording-source-streams* (cons recording *recording-source-streams*)))
    31133117         (declare (dynamic-extent recording *recording-source-streams*))
     
    31343138                                                  start-offset)))))
    31353139           (values form source-note))))
    3136     (T
     3140    (T ;; not clear if this is ever useful
    31373141       (let* ((start-pos (stream-position stream))
    31383142              (form (read-internal stream nil eofval nil))
     
    31463150         (values form source-note)))))
    31473151
    3148 (defun fetch-octets-from-stream (stream start-offset end-offset)
     3152(defmethod fetch-octets-from-stream ((stream input-stream) start-offset end-offset)
    31493153  ;; We basically want to read the bytes between two positions, but there is no
    31503154  ;; direct interface for that.  So we let the stream decode and then we re-encode.
     
    31973201      (etypecase source
    31983202        (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"))))
    32103217        (source-note
    32113218         (ensure-source-note-text source))
     
    32213228
    32223229
     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
    32233335
    32243336; end
Note: See TracChangeset for help on using the changeset viewer.