Changeset 11071 for trunk/source/level-1


Ignore:
Timestamp:
Oct 13, 2008, 4:14:40 PM (11 years ago)
Author:
gz
Message:

From working-0711 branch: add new fn, not used by anything yet:

READ-RECORDING-SOURCE (stream &key eofval file-name start-offset map)
Read a top-level form, perhaps recording source locations.
If MAP is NIL, just reads a form as if by READ.
If MAP is non-NIL, returns a second value of a source-note object describing the form.
In addition, if MAP is a hash table, it gets filled with source-note's for all
non-atomic nested subforms.

File:
1 edited

Legend:

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

    r10426 r11071  
    24672467;;; this (multiple-value-list, etc.) should probably consider
    24682468;;; rewriting those parts of the CLOS and I/O code that make
    2469 ;;; using things like READ-CHAR impractical ...
     2469;;; using things like READ-CHAR impractical...
     2470
     2471;;; mb: the reason multiple-value-list is used here is that we need to distunguish between the
     2472;;; recursive parse call returning (values nil) and (values).
    24702473(defun %parse-expression (stream firstchar dot-ok)
    24712474  (let* ((readtable *readtable*)
    2472          (attrtab (rdtab.ttab readtable)))
    2473     (let* ((attr (%character-attribute firstchar attrtab)))
    2474       (declare (fixnum attr))
    2475       (if (= attr $cht_ill)
    2476           (signal-reader-error stream "Illegal character ~S." firstchar))
    2477       (let* ((vals (multiple-value-list
    2478                     (if (not (logbitp $cht_macbit attr))
    2479                       (%parse-token stream firstchar dot-ok)
    2480                       (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
    2481                         (cond ((null def))
    2482                               ((atom def)
    2483                                (funcall def stream firstchar))
    2484                               #+no ; include if %initial-readtable% broken (see above)
    2485                               ((and (consp (car def))
    2486                                     (eq (caar def) 'function))
    2487                                (funcall (cadar def) stream firstchar))
    2488                               ((functionp (car def))
    2489                                (funcall (car def) stream firstchar))
    2490                               (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))))
    2491         (declare (dynamic-extent vals)
    2492                  (list vals))
    2493         (if (null vals)
    2494             (values nil nil)
    2495             (values (car vals) t))))))
    2496 
     2475         (attrtab (rdtab.ttab readtable))
     2476         (attr (%character-attribute firstchar attrtab))
     2477         (start-pos (file-position stream)))
     2478    (declare (fixnum attr))
     2479    (when (eql attr $cht_ill)
     2480      (signal-reader-error stream "Illegal character ~S." firstchar))
     2481    (let* ((vals (multiple-value-list
     2482                     (if (not (logbitp $cht_macbit attr))
     2483                       (%parse-token stream firstchar dot-ok)
     2484                       (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
     2485                         (cond ((null def))
     2486                               ((atom def)
     2487                                (funcall def stream firstchar))
     2488                               #+no     ; include if %initial-readtable% broken (see above)
     2489                               ((and (consp (car def))
     2490                                     (eq (caar def) 'function))
     2491                                (funcall (cadar def) stream firstchar))
     2492                               ((functionp (car def))
     2493                                (funcall (car def) stream firstchar))
     2494                               (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))
     2495           (end-pos (and start-pos (file-position stream))))
     2496      (declare (dynamic-extent vals)
     2497               (list vals))
     2498      (if (null vals)
     2499        (values nil nil)
     2500        (destructuring-bind (form &optional nested-source-notes)
     2501                            vals
     2502          ;; Can't really trust random reader macros to return source notes...
     2503          (unless (and (consp nested-source-notes)
     2504                       (source-note-p (car nested-source-notes)))
     2505            (setq nested-source-notes nil))
     2506          (values form
     2507                  t
     2508                  (and start-pos
     2509                       (make-source-note :form form
     2510                                         :stream stream
     2511                                         :start-pos (1- start-pos)
     2512                                         :end-pos end-pos
     2513                                         :subform-notes nested-source-notes))))))))
    24972514
    24982515#|
     
    25112528      (let* ((firstch (%next-non-whitespace-char-and-attr-no-eof stream)))
    25122529        (if (eq firstch termch)
    2513             (return (values nil nil))
    2514             (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok)
     2530            (return (values nil nil nil))
     2531            (multiple-value-bind (val val-p source-info)
     2532                (%parse-expression stream firstch dot-ok)
    25152533              (if val-p
    2516                   (return (values val t))))))))
    2517 
     2534                  (return (values val t source-info))))))))
    25182535
    25192536(defun read-list (stream &optional nodots (termch #\)))
    25202537  (let* ((dot-ok (cons nil nil))
    25212538         (head (cons nil nil))
    2522          (tail head))
     2539         (tail head)
     2540         (source-note-list nil))
    25232541    (declare (dynamic-extent dot-ok head)
    25242542             (list head tail))
    25252543    (if nodots (setq dot-ok nil))
    2526     (multiple-value-bind (firstform firstform-p)
     2544    (multiple-value-bind (firstform firstform-p firstform-source-note)
    25272545        (%read-list-expression stream dot-ok termch)
     2546      (when firstform-source-note
     2547        (push firstform-source-note source-note-list))
    25282548      (when firstform-p
    25292549        (if (and dot-ok (eq firstform dot-ok))       ; just read a dot
     
    25312551        (rplacd tail (setq tail (cons firstform nil)))
    25322552        (loop
    2533           (multiple-value-bind (nextform nextform-p)
     2553          (multiple-value-bind (nextform nextform-p nextform-source-note)
    25342554              (%read-list-expression stream dot-ok termch)
     2555            (when nextform-source-note
     2556              (push nextform-source-note source-note-list))
    25352557            (if (not nextform-p) (return))
    25362558            (if (and dot-ok (eq nextform dot-ok))    ; just read a dot
    2537                 (if (multiple-value-bind (lastform lastform-p)
     2559                (if (multiple-value-bind (lastform lastform-p lastform-source-note)
    25382560                        (%read-list-expression stream nil termch)
     2561                      (when lastform-source-note
     2562                        (push lastform-source-note source-note-list))
    25392563                      (and lastform-p
    2540                            (progn (rplacd tail lastform) 
     2564                           (progn (rplacd tail lastform)
    25412565                                  (not (nth-value 1 (%read-list-expression stream nil termch))))))
    25422566                    (return)
    25432567                    (signal-reader-error stream "Dot context error."))
    2544                 (rplacd tail (setq tail (cons nextform nil))))))))
    2545     (cdr head)))
     2568              (rplacd tail (setq tail (cons nextform nil))))))))
     2569    (values (cdr head) source-note-list)))
    25462570
    25472571#|
     
    25672591            (lambda (stream ignore)
    25682592              (declare (ignore ignore))
    2569               `(quote ,(read stream t nil t)))))
     2593              (multiple-value-bind (form source-note)
     2594                  (read-internal stream t nil t)
     2595                (values `(quote ,form) (and source-note (list source-note)))))))
    25702596
    25712597(defparameter *alternate-line-terminator*
     
    26302656    (declare (ignore subchar))
    26312657    (if (or (null numarg) *read-suppress*)
    2632       (let* ((lst (read-list stream t))
    2633              (len (length lst))
    2634              (vec (make-array len)))
    2635         (declare (list lst) (fixnum len) (simple-vector vec))
    2636         (dotimes (i len vec)
    2637           (setf (svref vec i) (pop lst))))
     2658      (multiple-value-bind (lst notes) (read-list stream t)
     2659        (let* ((len (length lst))
     2660               (vec (make-array len)))
     2661          (declare (list lst) (fixnum len) (simple-vector vec))
     2662          (dotimes (i len)
     2663            (setf (svref vec i) (pop lst)))
     2664          (values vec notes)))
    26382665      (locally
    2639         (declare (fixnum numarg))
     2666          (declare (fixnum numarg))
    26402667        (do* ((vec (make-array numarg))
     2668              (notes ())
    26412669              (lastform)
    26422670              (i 0 (1+ i)))
    2643              ((multiple-value-bind (form form-p) (%read-list-expression stream nil)
    2644                 (if form-p
    2645                   (setq lastform form)
    2646                   (unless (= i numarg)
    2647                       (if (= i 0)
    2648                         (%err-disp $XARROOB -1 vec)
    2649                         (do* ((j i (1+ j)))
    2650                              ((= j numarg))
    2651                           (declare (fixnum j))
    2652                           (setf (svref vec j) lastform)))))
    2653                 (not form-p))
    2654               vec)
     2671            ((multiple-value-bind (form form-p source-info)
     2672                 (%read-list-expression stream nil)
     2673               (if form-p
     2674                 (progn
     2675                   (setq lastform form)
     2676                   (when source-info (push source-info notes)))
     2677                 (unless (= i numarg)
     2678                   (if (= i 0)
     2679                     (%err-disp $XARROOB -1 vec)
     2680                     (do* ((j i (1+ j)))
     2681                         ((= j numarg))
     2682                       (declare (fixnum j))
     2683                       (setf (svref vec j) lastform)))))
     2684               (not form-p))
     2685               (values vec notes))
    26552686          (declare (fixnum i))
    26562687          (setf (svref vec i) lastform)))))))
     
    26892720 #\#
    26902721 #\C
    2691  #'(lambda (stream char arg &aux form)
     2722 #'(lambda (stream char arg)
    26922723     (require-no-numarg char arg )
    2693      (setq form (read stream t nil t))
    2694      (unless *read-suppress* (apply #'complex form))))
     2724     (multiple-value-bind (form note) (read-internal stream t nil t)
     2725       (values (unless *read-suppress* (apply #'complex form)) (and note (list note))))))
    26952726
    26962727(set-dispatch-macro-character
     
    27762807            (lambda (stream subchar numarg)
    27772808              (require-no-numarg subchar numarg)
    2778               `(function ,(read stream t nil t)))))
     2809              (multiple-value-bind (form note) (read-internal stream t nil t)
     2810                (values `(function ,form) (and note (list note)))))))
    27792811
    27802812(set-dispatch-macro-character
     
    28442876;;;recursive reading.  So recursive reads always get done via tyi's, and streams
    28452877;;;only get to intercept toplevel reads.
    2846 
    28472878(defun read (&optional stream (eof-error-p t) eof-value recursive-p)
    28482879  (declare (resident))
     2880  ;; just return the first value of read-internal
     2881  (values (read-internal stream eof-error-p eof-value recursive-p)))
     2882
     2883(defun read-internal (stream eof-error-p eof-value recursive-p)
    28492884  (setq stream (input-stream-arg stream))
    28502885  (if recursive-p
    2851     (%read-form stream 0 nil)
     2886    (%read-form stream (if eof-error-p 0) nil)
    28522887    (let ((%read-objects% nil) (%keep-whitespace% nil))
    28532888      (%read-form stream (if eof-error-p 0) eof-value))))
     
    28572892   that followed the object."
    28582893  (setq stream (input-stream-arg stream))
    2859   (if recursive-p
    2860     (%read-form stream 0 nil)
    2861     (let ((%read-objects% nil) (%keep-whitespace% t))
    2862       (%read-form stream (if eof-error-p 0) eof-value))))
     2894  (values
     2895    (if recursive-p
     2896      (%read-form stream 0 nil)
     2897      (let ((%read-objects% nil) (%keep-whitespace% t))
     2898        (%read-form stream (if eof-error-p 0) eof-value)))))
    28632899
    28642900
    28652901(defun read-delimited-list (char &optional stream recursive-p)
    28662902  "Read Lisp values from INPUT-STREAM until the next character after a
    2867    value's representation is ENDCHAR, and return the objects as a list."
     2903   value's representation is CHAR, and return the objects as a list."
    28682904  (setq char (require-type char 'character))
    28692905  (setq stream (input-stream-arg stream))
    2870   (let ((%keep-whitespace% nil))
    2871     (if recursive-p
    2872       (%read-form stream char nil)
    2873       (let ((%read-objects% nil))
    2874         (%read-form stream char nil)))))
     2906  (values
     2907   (let ((%keep-whitespace% nil))
     2908     (if recursive-p
     2909       (%read-form stream char nil)
     2910       (let ((%read-objects% nil))
     2911         (%read-form stream char nil))))))
    28752912
    28762913(defun read-conditional (stream subchar int)
    28772914  (declare (ignore int))
    2878   (cond ((eq subchar (read-feature stream)) (read stream t nil t))
     2915  (cond ((eq subchar (read-feature stream))
     2916         (multiple-value-bind (form note) (read-internal stream t nil t)
     2917           (values form (and note (list note)))))
    28792918        (t (let* ((*read-suppress* t))
    28802919             (read stream t nil t)
     
    29012940(set-dispatch-macro-character #\# #\- #'read-conditional)
    29022941
    2903 
    2904 
    2905 
    2906 ;;;arg=0 : read form, error if eof
    2907 ;;;arg=nil : read form, eof-val if eof.
    2908 ;;;arg=char : read delimited list
    29092942(defun %read-form (stream arg eof-val)
     2943  "Read a lisp form from STREAM
     2944
     2945arg=0 : read form, error if eof
     2946arg=nil : read form, eof-val if eof.
     2947arg=char : read delimited list"
    29102948  (declare (resident))
    29112949  (check-type *readtable* readtable)
     
    29142952      (read-list stream nil arg)
    29152953      (loop
    2916           (let* ((ch (%next-non-whitespace-char-and-attr stream)))
     2954        (let* ((ch (%next-non-whitespace-char-and-attr stream)))
    29172955          (if (null ch)
    29182956            (if arg
    29192957              (error 'end-of-file :stream stream)
    29202958              (return eof-val))
    2921             (multiple-value-bind (form form-p) (%parse-expression stream ch nil)
    2922               (if form-p
    2923                  (if *read-suppress*
    2924                      (return nil)
    2925                      (return form)))))))))
    2926 
    2927 
    2928 
    2929 
    2930 
     2959            (multiple-value-bind (form form-p source-note)
     2960                (%parse-expression stream ch nil)
     2961              (when form-p
     2962                (return
     2963                 (values (if *read-suppress* nil form)
     2964                         source-note)))))))))
    29312965
    29322966;;;Until load backquote...
     
    29382972
    29392973(set-dispatch-macro-character #\# #\P
    2940  (qlfun |#P-reader| (stream char flags &aux path (invalid-string "Invalid flags (~S) for pathname ~S"))
     2974 (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S"))
    29412975   (declare (ignore char))
    29422976   (when (null flags) (setq flags 0))
    29432977   (unless (memq flags '(0 1 2 3 4))
    29442978     (unless *read-suppress* (report-bad-arg flags '(integer 0 4))))
    2945    (setq path (read stream t nil t))
    2946    (unless *read-suppress*
    2947      (unless (stringp path) (report-bad-arg path 'string))
    2948      (setq path (pathname path))
    2949      (when (%ilogbitp 0 flags)
    2950        (when (%pathname-type path) (error invalid-string flags path))
    2951        (setf (%pathname-type path) :unspecific))
    2952      (when (%ilogbitp 1 flags)
    2953        (when (%pathname-name path) (error invalid-string flags path))
    2954        (setf (%pathname-name path) ""))
    2955      path)))
    2956 
    2957 
    2958 
    2959 
    2960 
    2961 
     2979   (multiple-value-bind (path note) (read-internal stream t nil t)
     2980     (unless *read-suppress*
     2981       (unless (stringp path) (report-bad-arg path 'string))
     2982       (setq path (pathname path))
     2983       (when (%ilogbitp 0 flags)
     2984         (when (%pathname-type path) (error invalid-string flags path))
     2985         (setf (%pathname-type path) :unspecific))
     2986       (when (%ilogbitp 1 flags)
     2987         (when (%pathname-name path) (error invalid-string flags path))
     2988         (setf (%pathname-name path) ""))
     2989       (values path (and note (list note)))))))
     2990
     2991
     2992;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     2993
     2994(defstruct (source-note (:constructor %make-source-note))
     2995  ;; For an inner source form, the source-note of the outer source form.
     2996  source
     2997  file-name
     2998  file-range)
     2999
     3000(defun encode-file-range (start-pos end-pos)
     3001  (let ((len (- end-pos start-pos)))
     3002    (if (< len (ash 1 12))
     3003      (+ (ash start-pos 12) len)
     3004      (cons start-pos end-pos))))
     3005
     3006(defun source-note-start-pos (source-note)
     3007  (let ((range (source-note-file-range source-note)))
     3008    (when range
     3009      (if (consp range) (car range) (ash range -12)))))
     3010
     3011(defun source-note-end-pos (source-note)
     3012  (let ((range (source-note-file-range source-note)))
     3013    (when range
     3014      (if (consp range) (cdr range) (+ (ash range -12) (logand range #xFFF))))))
     3015
     3016(defvar *recording-source-streams* ())
     3017
     3018(defun make-source-note (&key form stream start-pos end-pos subform-notes)
     3019  (let ((recording (assq stream *recording-source-streams*)))
     3020    (when (and recording (not *read-suppress*))
     3021      (destructuring-bind (map file-name stream-offset) (cdr recording)
     3022        (let* ((prev (gethash form map))
     3023               (note (%make-source-note :file-name file-name
     3024                                        :file-range (encode-file-range
     3025                                                     (+ stream-offset start-pos)
     3026                                                     (+ stream-offset end-pos)))))
     3027          (setf (gethash form map)
     3028                (cond ((null prev) note)
     3029                      ((consp prev) (cons note prev))
     3030                      (t (list note prev))))
     3031          (loop for sub in subform-notes as subnote = (require-type sub 'source-note)
     3032            do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote))
     3033            do (setf (source-note-source subnote) note))
     3034          note)))))
     3035
     3036(defmethod make-load-form ((note source-note) &optional env)
     3037  (make-load-form-saving-slots note :environment env))
     3038
     3039(defun read-recording-source (stream &key eofval file-name start-offset map)
     3040  "Read a top-level form, perhaps recording source locations.
     3041If MAP is NIL, just reads a form as if by READ.
     3042If MAP is non-NIL, returns a second value of a source-note object describing the form.
     3043In addition, if MAP is a hash table, it gets filled with source-note's for all
     3044non-atomic nested subforms."
     3045  (typecase map
     3046    (null (values (read-internal stream nil eofval nil) nil))
     3047    (hash-table
     3048     (let* ((recording (list stream map file-name (or start-offset 0)))
     3049            (*recording-source-streams* (cons recording *recording-source-streams*)))
     3050       (declare (dynamic-extent recording *recording-source-streams*))
     3051       (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
     3052         (when (and source-note (not (eq form eofval)))
     3053           (assert (null (source-note-source source-note)))
     3054           (loop for form being the hash-key using (hash-value note) of map
     3055                 do (cond ((eq note source-note) nil)
     3056                          ;; Remove entries with multiple source notes, which can happen
     3057                          ;; for atoms.  If we can't tell which instance we mean, then we
     3058                          ;; don't have useful source info.
     3059                          ((listp note) (remhash form map))
     3060                          ((loop for p = note then (source-note-source p) while (source-note-p p)
     3061                                 thereis (eq p source-note))
     3062                           ;; Flatten the backpointers so each subnote points directly
     3063                           ;; to the toplevel note.
     3064                           (setf (source-note-source note) source-note)))))
     3065         (values form source-note))))
     3066    (T
     3067     (let* ((start (file-position stream))
     3068            (form (read-internal stream nil eofval nil)))
     3069       (values form (and (neq form eofval)
     3070                         (%make-source-note :file-name file-name
     3071                                            :file-range (encode-file-range
     3072                                                         (+ (or start-offset 0)
     3073                                                            start)
     3074                                                         (+ (or start-offset 0)
     3075                                                            (file-position stream))))))))))
Note: See TracChangeset for help on using the changeset viewer.