Changeset 13159 for release


Ignore:
Timestamp:
Nov 2, 2009, 5:28:16 PM (10 years ago)
Author:
rme
Message:

Merge r13124 from trunk (record source text in read loop)

Location:
release/1.4/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/1.4/source/compiler/X86/x86-disassemble.lisp

    r13075 r13159  
    28132813  (let ((source-note (function-source-note function)))
    28142814    (when source-note
    2815       (format t ";; Source: ~S:~D-~D"
    2816               (source-note-filename source-note)
    2817               (source-note-start-pos source-note)
    2818               (source-note-end-pos source-note))
    2819       ;; Fetch source from file if don't already have it.
    2820       (ensure-source-note-text source-note))))
     2815      (ensure-source-note-text source-note)
     2816      (if (source-note-filename source-note)
     2817        (format t ";; ~S:~D-~D"
     2818                (source-note-filename source-note)
     2819                (source-note-start-pos source-note)
     2820                (source-note-end-pos source-note))
     2821          (let* ((source-text (source-note-text source-note)))
     2822            (when source-text
     2823              (format t ";;; ~A" (string-sans-most-whitespace source-text 100))))))))
    28212824
    28222825(defun x86-disassemble-xfunction (function xfunction
  • release/1.4/source/level-1/l1-reader.lisp

    r13075 r13159  
    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
  • release/1.4/source/level-1/l1-readloop-lds.lisp

    r13075 r13159  
    317317         (eof-value (cons nil nil))
    318318         (eof-count 0)
    319          (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)))
     319         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*))
     320         (*nx-source-note-map* (make-hash-table :test #'eq :shared nil)))
    320321    (declare (dynamic-extent eof-value))
    321322    (loop
     
    327328              (setq *in-read-loop* nil
    328329                    *break-level* break-level)
     330              (clrhash *nx-source-note-map*)
    329331              (multiple-value-bind (form env print-result)
    330332                  (toplevel-read :input-stream input-stream
    331333                                 :output-stream output-stream
    332334                                 :prompt-function prompt-function
    333                                  :eof-value eof-value)
     335                                 :eof-value eof-value
     336                                 :map *nx-source-note-map*)
    334337                (if (eq form eof-value)
    335338                  (progn
     
    392395                           (output-stream *standard-output*)
    393396                           (prompt-function #'print-listener-prompt)
    394                            (eof-value *eof-value*))
     397                           (eof-value *eof-value*)
     398                           (map nil))
    395399  (force-output output-stream)
    396400  (funcall prompt-function output-stream)
    397   (read-toplevel-form input-stream :eof-value eof-value))
     401  (read-toplevel-form input-stream :eof-value eof-value :map map))
    398402
    399403(defvar *always-eval-user-defvars* nil)
  • release/1.4/source/level-1/l1-streams.lisp

    r13097 r13159  
    59075907                     (read-command-or-keyword stream eof-value))
    59085908                    ((eq first-char eof-value) eof-value)
    5909                     (t (read-recording-source stream :eofval eof-value
    5910                                               :file-name file-name
    5911                                               :start-offset start-offset
    5912                                               :map map
    5913                                               :save-source-text t))))))
     5909                    (t (multiple-value-bind (form note)
     5910                           (read-recording-source stream :eofval eof-value
     5911                                                  :file-name file-name
     5912                                                  :start-offset start-offset
     5913                                                  :map map
     5914                                                  :save-source-text t)
     5915                         (setq *loading-toplevel-location* note)
     5916                         form))))))
    59145917      (if (eq form eof-value)
    59155918        (return (values form nil t))
Note: See TracChangeset for help on using the changeset viewer.