Ignore:
Timestamp:
Feb 21, 2008, 10:05:23 PM (14 years ago)
Author:
mb
Message:

Merge in mb-coverage-merge branch. No other changes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r8444 r8554  
    24072407              (or dot-ok
    24082408                  (signal-reader-error stream "Dot context error in ~s." (%string-from-token tb)))
    2409               (signal-reader-error stream "Illegal symbol syntax in ~s. (%string-from-token tb)"))
     2409              (signal-reader-error stream "Illegal symbol syntax in ~s." (%string-from-token tb)))
    24102410            ;; Something other than a buffer full of dots.  Thank god.
    24112411            (let* ((num (if (null escapes)
     
    24762476  (let* ((readtable *readtable*)
    24772477         (attrtab (rdtab.ttab readtable))
    2478          (attr (%character-attribute firstchar attrtab)))
     2478         (attr (%character-attribute firstchar attrtab))
     2479         (start-pos (file-position stream)))
    24792480    (declare (fixnum attr))
    2480     (if (= attr $cht_ill)
     2481    (if (eql attr $cht_ill)
    24812482        (signal-reader-error stream "Illegal character ~S." firstchar))
    2482     (with-read-source-tracking (stream start end)
    2483       (let* ((vals (multiple-value-list
    2484                        (if (not (logbitp $cht_macbit attr))
    2485                            (%parse-token stream firstchar dot-ok)
    2486                            (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
    2487                              (cond ((null def))
    2488                                    ((atom def)
    2489                                     (funcall def stream firstchar))
    2490                                    #+no ; include if %initial-readtable% broken (see above)
    2491                                    ((and (consp (car def))
    2492                                          (eq (caar def) 'function))
    2493                                     (funcall (cadar def) stream firstchar))
    2494                                    ((functionp (car def))
    2495                                     (funcall (car def) stream firstchar))
    2496                                    (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))))
    2497         (declare (dynamic-extent vals)
    2498                  (list vals))
    2499         (if (null vals)
    2500             (values nil nil nil)           
    2501             (destructuring-bind (form &optional nested-source-notes)
    2502                 vals
    2503               (values form
    2504                       t
    2505                       (when (and (not (eql t nested-source-notes))
    2506                                  (consp form)
    2507                                  (record-source-location-on-stream-p stream))
    2508                         ;; mb 2008-02-07: sometime the nested-source-notes end with t, don't know
    2509                         ;; why. don't really care here.
    2510                         (make-source-note :stream stream
    2511                                           :start (1- start)
    2512                                           :end end
    2513                                           :form (car vals)
    2514                                           :children (if nested-source-notes
    2515                                                       (let ((last (last nested-source-notes)))
    2516                                                         (when (atom (cdr last))
    2517                                                           ;; dotted list.
    2518                                                           (setf (cdr last) (list (cdr last))))
    2519                                                         nested-source-notes)
    2520                                                       '()))))))))))
     2483    (let* ((vals (multiple-value-list
     2484                  (if (not (logbitp $cht_macbit attr))
     2485                    (%parse-token stream firstchar dot-ok)
     2486                    (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
     2487                      (cond ((null def))
     2488                            ((atom def)
     2489                             (funcall def stream firstchar))
     2490                            #+no ; include if %initial-readtable% broken (see above)
     2491                            ((and (consp (car def))
     2492                                  (eq (caar def) 'function))
     2493                             (funcall (cadar def) stream firstchar))
     2494                            ((functionp (car def))
     2495                             (funcall (car def) stream firstchar))
     2496                            (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))
     2497           (end-pos (and start-pos (file-position stream))))
     2498      (declare (dynamic-extent vals)
     2499               (list vals))
     2500      (if (null vals)
     2501        (values nil nil)
     2502        (destructuring-bind (form &optional nested-source-notes)
     2503                            vals
     2504          ;; Can't really trust random reader macros to return source notes...
     2505          (unless (and (consp nested-source-notes)
     2506                       (source-note-p (car nested-source-notes)))
     2507            (setq nested-source-notes nil))
     2508          (values form
     2509                  t
     2510                  (and start-pos
     2511                       (make-source-note :form form
     2512                                         :stream stream
     2513                                         :start-pos (1- start-pos)
     2514                                         :end-pos end-pos
     2515                                         :subform-notes nested-source-notes))))))))
    25212516
    25222517#|
     
    25452540         (head (cons nil nil))
    25462541         (tail head)
    2547          (source-note-list-head (cons nil nil))
    2548          (source-note-list-tail source-note-list-head))
     2542         (source-note-list nil))
    25492543    (declare (dynamic-extent dot-ok head)
    25502544             (list head tail))
     
    25522546    (multiple-value-bind (firstform firstform-p firstform-source-note)
    25532547        (%read-list-expression stream dot-ok termch)
     2548      (when firstform-source-note
     2549        (push firstform-source-note source-note-list))
    25542550      (when firstform-p
    25552551        (if (and dot-ok (eq firstform dot-ok))       ; just read a dot
    25562552            (signal-reader-error stream "Dot context error."))
    2557         (rplacd source-note-list-tail (setq source-note-list-tail (cons firstform-source-note nil)))
    25582553        (rplacd tail (setq tail (cons firstform nil)))
    25592554        (loop
    25602555          (multiple-value-bind (nextform nextform-p nextform-source-note)
    25612556              (%read-list-expression stream dot-ok termch)
     2557            (when nextform-source-note
     2558              (push nextform-source-note source-note-list))
    25622559            (if (not nextform-p) (return))
    25632560            (if (and dot-ok (eq nextform dot-ok))    ; just read a dot
    25642561                (if (multiple-value-bind (lastform lastform-p lastform-source-note)
    25652562                        (%read-list-expression stream nil termch)
     2563                      (when lastform-source-note
     2564                        (push lastform-source-note source-note-list))
    25662565                      (and lastform-p
    25672566                           (progn (rplacd tail lastform)
    2568                                   (rplacd source-note-list-tail lastform-source-note)
    25692567                                  (not (nth-value 1 (%read-list-expression stream nil termch))))))
    25702568                    (return)
    25712569                    (signal-reader-error stream "Dot context error."))
    25722570                (progn
    2573                   (rplacd source-note-list-tail (setq source-note-list-tail (cons nextform-source-note nil)))
    25742571                  (rplacd tail (setq tail (cons nextform nil)))))))))
    2575    
    2576     (if (record-source-location-on-stream-p stream)
    2577         (values (cdr head) (cdr source-note-list-head))
    2578         (values (cdr head)))))
     2572    (values (cdr head) source-note-list)))
    25792573
    25802574#|
     
    28862880  (setq stream (input-stream-arg stream))
    28872881  (if recursive-p
    2888     (%read-form stream 0 nil)
     2882    (%read-form stream (if eof-error-p 0) nil)
    28892883    (let ((%read-objects% nil) (%keep-whitespace% nil))
    28902884      (%read-form stream (if eof-error-p 0) eof-value))))
     
    29522946        (let* ((ch (%next-non-whitespace-char-and-attr stream)))
    29532947          (if (null ch)
    2954               (if arg
    2955                   (error 'end-of-file :stream stream)
    2956                   (return eof-val))
    2957               (multiple-value-bind (form form-p source-note)
    2958                   (%parse-expression stream ch nil)
    2959                 (when form-p
    2960                   (return
    2961                     (values (if *read-suppress* nil form)
    2962                             source-note)))))))))
     2948            (if arg
     2949              (error 'end-of-file :stream stream)
     2950              (return eof-val))
     2951            (multiple-value-bind (form form-p source-note)
     2952                (%parse-expression stream ch nil)
     2953              (when form-p
     2954                (return
     2955                 (values (if *read-suppress* nil form)
     2956                         source-note)))))))))
    29632957
    29642958;;;Until load backquote...
     
    29892983
    29902984
    2991 
    2992 
    2993 
     2985;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     2986
     2987(defstruct (code-note (:constructor %make-code-note))
     2988  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
     2989  code-coverage
     2990  ;; The actual form - useful during debugging, perhaps remove later.
     2991  form
     2992  ;; For the outermost source form, a string (the text of the form).
     2993  ;; For an inner source form, the source-note of the outer source form.
     2994  ;; For a random code form (no file info, generated by macros or other source
     2995  ;; transform), code-note of parent form
     2996  source
     2997  ;; PC information generated by compiler.  For source notes not stored in
     2998  ;; an lfun, it could contain intermediate results during compilation.
     2999  start-pc
     3000  end-pc
     3001  ;; Notes for code-generating subforms of this form
     3002  subform-notes)
     3003
     3004(defstruct (source-note (:include code-note)
     3005                        (:constructor %make-source-note))
     3006  ;; The source location: file name, and start/end offsets within the file
     3007  file-name
     3008  start-pos
     3009  end-pos)
     3010
     3011;;; we don't actually store source-note structs in the fasl since that runs into problems dumping
     3012;;; the struct.
     3013(defun source-note-for-%lfun-info (note &key (start t) (end t) (text t) (form t) (subform-notes t) (file-name t))
     3014  (append (when start (list :start (source-note-start-pos note)))
     3015          (when end   (list :end  (source-note-end-pos note)))
     3016          (when text
     3017            (let ((source (source-note-source note)))
     3018              (list :%text
     3019                    (%fast-compact
     3020                     (etypecase source
     3021                       (string source)
     3022                       (source-note (source-note-source source))
     3023                       (code-note (code-note-source source)))))))
     3024          (when form  (list :form (source-note-form  note)))
     3025          (when subform-notes (list :subform-notes (source-note-subform-notes note)))
     3026          (when file-name (list :file-name (source-note-file-name note)))))
     3027
     3028(defun source-note-from-%lfun-info (lfun-info)
     3029  (let ((note-plist (getf lfun-info 'function-source-note)))
     3030    (%make-source-note :file-name (getf note-plist :file-name)
     3031                       :start-pos (getf note-plist :start)
     3032                       :end-pos (getf note-plist :end)
     3033                       :source (%fast-uncompact (getf note-plist :%text))
     3034                       )))
     3035
     3036
     3037(defmethod make-load-form ((note code-note) &optional env)
     3038  (make-load-form-saving-slots note :environment env))
     3039
     3040(defmethod print-object ((note code-note) stream)
     3041  (print-unreadable-object (note stream :type t :identity t)
     3042    (let ((text (and (source-note-p note) (ignore-errors (source-note-text note)))))
     3043      (when (and (null text) (code-note-form note))
     3044        (setq text (ignore-errors
     3045                    (let ((*print-circle* t))
     3046                      (format nil "~s" (code-note-form note))))))
     3047      (when (> (length text) 20)
     3048        (let ((end (position #\Newline text :start 20)))
     3049          (when (or end (> (length text) 120))
     3050            (setq text (concatenate 'string
     3051                                    (subseq text 0 (min (or end (length text)) 120))
     3052                                    "...")))))
     3053      (format stream "[~s]~:[~; for ~:*~a~] (~s subforms)"
     3054              (code-note-code-coverage note)
     3055              text
     3056              (length (code-note-subform-notes note))))))
     3057
     3058(defun source-note-length (note)
     3059  (- (source-note-end-pos note) (source-note-start-pos note)))
     3060
     3061(defun source-note-text (note)
     3062  (multiple-value-bind (string offset) (source-note-string-and-offset note)
     3063    (when string
     3064      (subseq string offset (+ offset (source-note-length note))))))
     3065
     3066(defun source-note-string-and-offset (note)
     3067  "Returns a string and offset where the text of note's form starts"
     3068  (when (source-note-p note)
     3069    (let ((source (source-note-source note)))
     3070      (cond ((stringp source)
     3071             (assert (<= (source-note-length note) (length source)))
     3072             (values source 0))
     3073            ((source-note-p source)
     3074             (let ((start (source-note-start-pos note))
     3075                   (parent-start (source-note-start-pos source)))
     3076               (assert (<= parent-start start
     3077                           (source-note-end-pos note) (source-note-end-pos source)))
     3078               (multiple-value-bind (parent-string parent-offset)
     3079                                    (source-note-string-and-offset source)
     3080                 (values parent-string (+ parent-offset (- start parent-start))))))))))
     3081
     3082(defvar *recording-source-streams* ())
     3083
     3084(defun read-recording-source (stream &key eofval file-name start-offset map)
     3085  "Read a top-level form, perhaps recording source location.
     3086If MAP is NIL, just reads a form as if by READ.
     3087If MAP is non-NIL, returns a second value of a source-note describing the form.
     3088In addition, if MAP is a hash table, it gets filled with source-note's for all
     3089non-atomic nested forms."
     3090  (typecase map
     3091    (null (values (read-internal stream nil eofval nil) nil))
     3092    (hash-table
     3093     (let* ((recording (list stream map file-name (or start-offset 0)))
     3094            (*recording-source-streams* (cons recording *recording-source-streams*)))
     3095       (declare (dynamic-extent recording *recording-source-streams*))
     3096       (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
     3097         (when (and source-note (not (eq form eofval)))
     3098           (assert (null (source-note-source source-note)))
     3099           (let ((text (make-string (source-note-length source-note)))
     3100                 (pos (file-position stream)))
     3101             (file-position stream (- (source-note-start-pos source-note) start-offset))
     3102             (read-sequence text stream)
     3103             (file-position stream pos)
     3104             (setf (source-note-source source-note) text)))
     3105         (values form source-note))))
     3106    ((eql t)
     3107     (let* ((start (file-position stream))
     3108            (form (read-internal stream nil eofval nil)))
     3109       (values form (and (neq form eofval)
     3110                         (%make-source-note :form form
     3111                                            :file-name file-name
     3112                                            :start-pos (+ (or start-offset 0) start)
     3113                                            :end-pos (+ (or start-offset 0) (file-position stream)))))))))
     3114
     3115(defun make-source-note (&key form stream start-pos end-pos subform-notes)
     3116  (let ((recording (assoc stream *recording-source-streams*)))
     3117    (when (and recording (not *read-suppress*))
     3118      (destructuring-bind (map file-name stream-offset) (cdr recording)
     3119        (let* ((prev (gethash form map))
     3120               (note (%make-source-note :form form
     3121                                        :file-name file-name
     3122                                        :start-pos (+ stream-offset start-pos)
     3123                                        :end-pos (+ stream-offset end-pos))))
     3124          (setf (gethash form map)
     3125                (cond ((null prev) note)
     3126                      ((consp prev) (cons note prev))
     3127                      (t (list note prev))))
     3128          (loop for sub in subform-notes as subnote = (require-type sub 'source-note)
     3129            do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote))
     3130            do (setf (source-note-source subnote) note))
     3131          note)))))
     3132
     3133(defun make-code-note (&key form source)
     3134  (declare (ignorable form))
     3135  ;; A note for a form generated by macroexpansion
     3136  (let* ((source (and source (require-type source 'code-note)))
     3137         (note (%make-code-note
     3138                ;; Unfortunately, recording the macroexpanded form is problematic, since they
     3139                ;; can have references to non-dumpable forms, see e.g. loop.
     3140                ;; Could print it and record the string instead.
     3141                ;; :form form
     3142                :source source)))
     3143    #+debug
     3144    (when form
     3145      (setf (code-note-form note)
     3146            (with-output-to-string (s) (let ((*print-string-length* 80)) (prin1 form s)))))
     3147    note))
     3148
     3149; end
Note: See TracChangeset for help on using the changeset viewer.