Changeset 13146

Timestamp:

Oct 30, 2009, 3:32:15 PM (15 years ago)

Author:

gz

Message:

readloop source text recording (r13124, r13131)

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-disassemble.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (1 diff)
• level-1/l1-reader.lisp (modified) (6 diffs)
• level-1/l1-readloop-lds.lisp (modified) (3 diffs)
• level-1/l1-streams.lisp (modified) (1 diff)

branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

@@ -2813 +2813 @@
   (let ((source-note (function-source-note function)))
     (when source-note
-      (format t ";; Source: ~S:~D-~D"
-              (source-note-filename source-note)
-              (source-note-start-pos source-note)
-              (source-note-end-pos source-note))
-      ;; Fetch source from file if don't already have it.
-      (ensure-source-note-text source-note))))
+      (ensure-source-note-text source-note)
+      (if (source-note-filename source-note)
+        (format t ";; ~S:~D-~D"
+                (source-note-filename source-note)
+                (source-note-start-pos source-note)
+                (source-note-end-pos source-note))
+          (let* ((source-text (source-note-text source-note)))
+            (when source-text
+              (format t ";;; ~A" (string-sans-most-whitespace source-text 100))))))))
 
 (defun x86-disassemble-xfunction (function xfunction

branches/working-0711/ccl/compiler/nx0.lisp

@@ -46 +46 @@
 (defvar *nx-cur-func-name* nil)
 (defvar *nx-current-note* nil)
-(defparameter *nx-source-note-map* nil) ;; there might be external refs, from macros.
+(defvar *nx-source-note-map* nil) ;; there might be external refs, from macros.
 (defvar *nx-form-type* t)
 ;(defvar *nx-proclaimed-inline* nil)

branches/working-0711/ccl/level-1/l1-reader.lisp

@@ -3008 +3008 @@
   (let* ((file (source-note-filename sn))
          (text (ignore-errors (source-note-text sn))))
-    ;; Should fix this when record the name.
-    (when (eq (pathname-version file) :newest)
-      (setq file (namestring (make-pathname :version nil :defaults file))))
+    (when file
+      ;; Should fix this when record the name.
+      (when (eq (pathname-version file) :newest)
+        (setq file (namestring (make-pathname :version nil :defaults file)))))
     (when text
       (setq text (string-sans-most-whitespace text 121))
       (when (> (length text) 120)
         (setq text (concatenate 'string (subseq text 0 120) "..."))))
-    (format stream "~s:~s-~s ~s" file
-            (source-note-start-pos sn) (source-note-end-pos sn)
-            text)))
+    (if file
+      (format stream "*~s:~s-~s ~s" file
+              (source-note-start-pos sn) (source-note-end-pos sn)
+              text)
+      (format stream "Interactive ~s" text))))
 
 (defun source-note-filename (source)
@@ -3109 +3112 @@
     (null (values (read-internal stream nil eofval nil) nil))
     (hash-table
-       (let* ((recording (list stream map file-name start-offset))
+       (let* ((stream (recording-input-stream stream))
+              (recording (list stream map file-name start-offset))
               (*recording-source-streams* (cons recording *recording-source-streams*)))
          (declare (dynamic-extent recording *recording-source-streams*))
@@ -3134 +3138 @@
                                                   start-offset)))))
            (values form source-note))))
-    (T
+    (T ;; not clear if this is ever useful
        (let* ((start-pos (stream-position stream))
               (form (read-internal stream nil eofval nil))
@@ -3146 +3150 @@
          (values form source-note)))))
 
-(defun fetch-octets-from-stream (stream start-offset end-offset)
+(defmethod fetch-octets-from-stream ((stream input-stream) start-offset end-offset)
   ;; We basically want to read the bytes between two positions, but there is no
   ;; direct interface for that.  So we let the stream decode and then we re-encode.
@@ -3197 +3201 @@
       (etypecase source
         (null
-         (with-open-file (stream filename :if-does-not-exist if-does-not-exist)
-           (when stream
-             (let ((start (source-note-start-pos source-note))
-                   (end (source-note-end-pos source-note))
-                   (len (file-length stream)))
-               (if (<= end len)
-                   (setf (source-note.source source-note)
-                         (fetch-octets-from-stream stream start end))
-                   (when if-does-not-exist
-                     (error 'simple-file-error :pathname filename
-                            :error-type "File ~s changed since source info recorded")))))))
+         (if filename
+           (with-open-file (stream filename :if-does-not-exist if-does-not-exist)
+             (when stream
+               (let ((start (source-note-start-pos source-note))
+                     (end (source-note-end-pos source-note))
+                     (len (file-length stream)))
+                 (if (<= end len)
+                     (setf (source-note.source source-note)
+                           (fetch-octets-from-stream stream start end))
+                     (when if-does-not-exist
+                       (error 'simple-file-error :pathname filename
+                              :error-type "File ~s changed since source info recorded"))))))
+           (when if-does-not-exist
+             (error "Missing source text in internative source note"))))
         (source-note
          (ensure-source-note-text source))
@@ -3221 +3228 @@
 
 
+;;; Wrapper stream for recording source of non-random-access streams.
+(defclass recording-character-input-stream (fundamental-stream character-input-stream)
+  ((input-stream :initarg :input-stream)
+   (string :initform (make-array 1024 :element-type 'character :fill-pointer 0 :adjustable t))))
+
+(defmethod stream-element-type ((s recording-character-input-stream))
+  (with-slots (input-stream) s
+    (stream-element-type input-stream)))
+
+(defmethod stream-read-char ((s recording-character-input-stream))
+  (with-slots (input-stream string) s
+    (let ((char (stream-read-char input-stream)))
+      (when (and char (neq char :eof))
+        (vector-push-extend char string))
+      char)))
+
+(defmethod stream-read-char-no-hang ((s recording-character-input-stream))
+  (with-slots (input-stream string) s
+    (let ((char (stream-read-char-no-hang input-stream)))
+      (when (and char (neq char :eof))
+        (vector-push-extend char string))
+      char)))
+
+(defmethod stream-peek-char ((s recording-character-input-stream))
+  (with-slots (input-stream) s
+    (stream-peek-char input-stream)))
+
+(defmethod stream-listen ((s recording-character-input-stream))
+  (with-slots (input-stream) s
+    (stream-listen input-stream)))
+
+(defmethod stream-read-line ((s recording-character-input-stream))
+  (generic-read-line s))
+
+(defmethod stream-read-list ((s recording-character-input-stream) list count)
+  (generic-character-read-list s list count))
+
+(defmethod stream-read-vector ((s recording-character-input-stream) vector start end)
+  (generic-character-read-vector s vector start end))
+
+(defmethod stream-unread-char ((s recording-character-input-stream) char)
+  (with-slots (input-stream string) s
+    (vector-pop string)    ;; Error if no characters read since last reset.
+    (stream-unread-char input-stream char)))
+
+(defmethod stream-eofp ((s recording-character-input-stream))
+  (with-slots (input-stream) s
+    (stream-eofp input-stream)))
+
+(defmethod stream-clear-input ((s recording-character-input-stream))
+  (with-slots (input-stream) s
+    (stream-clear-input input-stream)))
+
+(defmethod stream-position ((s recording-character-input-stream) &optional newpos)
+  (with-slots (string) s
+    (unless newpos
+      (fill-pointer string))))
+
+(defun recording-input-stream (stream)
+  (let ((pos (stream-position stream)))
+    (if (and pos (stream-position stream pos))
+      stream
+      (make-instance 'recording-character-input-stream :input-stream stream))))
+
+(defmethod fetch-octets-from-stream ((s recording-character-input-stream) start-offset end-offset)
+  (declare (fixnum start-offset end-offset))
+  (with-slots (string) s
+    (when (< start-offset end-offset)
+      (let* ((sstring (array-data-and-offset string))
+             (noctets (loop for i fixnum from start-offset below end-offset
+                         as code fixnum = (%char-code (%schar sstring i))
+                         sum (cond ((< code #x80) 1)
+                                   ((< code #x800) 2)
+                                   ((< code #x10000) 3)
+                                   (t 4))
+                         of-type fixnum))
+             (vec (make-array noctets :element-type '(unsigned-byte 8)))
+             (index 0))
+        (declare (type fixnum noctets index)
+                 (type simple-base-string sstring)
+                 (type (simple-array (unsigned-byte 8) (*)) vec))
+        (macrolet ((out (octet) `(progn
+                                   (setf (aref vec index) ,octet)
+                                   (incf index))))
+          (loop for i fixnum from start-offset below end-offset
+             as code fixnum = (%char-code (%schar sstring i))
+             do (cond ((< code #x80)
+                       (out code))
+                      ((< code #x800)
+                       (out (logior #xc0 (ldb (byte 5 6) code)))
+                       (out (logior #x80 (ldb (byte 6 0) code))))
+                      ((< code #x10000)
+                       (out (logior #xe0 (ldb (byte 4 12) code)))
+                       (out (logior #x80 (ldb (byte 6 6) code)))
+                       (out (logior #x80 (ldb (byte 6 0) code))))
+                      (t
+                       (out (logior #xf0 (ldb (byte 3 18) code)))
+                       (out (logior #xe0 (ldb (byte 6 12) code)))
+                       (out (logior #x80 (ldb (byte 6 6) code)))
+                       (out (logior #x80 (ldb (byte 6 0) code)))))))
+        (setf (fill-pointer string) 0) ;; reset
+        vec))))
+
+
+
 
 ; end

branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

@@ -317 +317 @@
          (eof-value (cons nil nil))
          (eof-count 0)
-         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)))
+         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*))
+         (*nx-source-note-map* (make-hash-table :test #'eq :shared nil)))
     (declare (dynamic-extent eof-value))
     (loop
@@ -327 +328 @@
               (setq *in-read-loop* nil
                     *break-level* break-level)
+              (clrhash *nx-source-note-map*)
               (multiple-value-bind (form env print-result)
                   (toplevel-read :input-stream input-stream
                                  :output-stream output-stream
                                  :prompt-function prompt-function
-                                 :eof-value eof-value)
+                                 :eof-value eof-value
+                                 :map *nx-source-note-map*)
                 (if (eq form eof-value)
                   (progn
@@ -392 +395 @@
                            (output-stream *standard-output*)
                            (prompt-function #'print-listener-prompt)
-                           (eof-value *eof-value*))
+                           (eof-value *eof-value*)
+                           (map nil))
   (force-output output-stream)
   (funcall prompt-function output-stream)
-  (read-toplevel-form input-stream :eof-value eof-value))
+  (read-toplevel-form input-stream :eof-value eof-value :map map))
 
 (defvar *always-eval-user-defvars* nil)

branches/working-0711/ccl/level-1/l1-streams.lisp

@@ -5907 +5907 @@
                      (read-command-or-keyword stream eof-value))
                     ((eq first-char eof-value) eof-value)
-                    (t (read-recording-source stream :eofval eof-value
-                                              :file-name file-name
-                                              :start-offset start-offset
-                                              :map map
-                                              :save-source-text t))))))
+                    (t (multiple-value-bind (form note)
+                           (read-recording-source stream :eofval eof-value
+                                                  :file-name file-name
+                                                  :start-offset start-offset
+                                                  :map map
+                                                  :save-source-text t)
+                         (setq *loading-toplevel-location* note)
+                         form))))))
       (if (eq form eof-value)
         (return (values form nil t))