Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8438) +++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8439) @@ -2706,5 +2706,4 @@ usual))) - (defun string-sans-most-whitespace (string &optional (max-length (length string))) (with-output-to-string (sans-whitespace) @@ -2729,5 +2728,7 @@ (let* ((source-note (getf (%lfun-info function) 'function-source-note)) (source-info (find-source-at-pc function pc)) - (text (if source-info + (text (if (and source-info + (plusp (car (getf source-info :source-text-range))) + (plusp (cdr (getf source-info :source-text-range)))) (string-sans-most-whitespace (subseq (%fast-uncompact (getf source-note :%text)) Index: /branches/working-0711/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8438) +++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8439) @@ -611,5 +611,5 @@ (when (and *compiler-record-source* *definition-source-note*) (list 'function-source-note - (source-note-to-list *definition-source-note* :form nil :children nil))) + (source-note-for-%lfun-info *definition-source-note* :form nil :children nil))) (when *x862-recorded-symbols* (list 'function-symbol-map (x862-digest-symbols))) @@ -685,39 +685,37 @@ (defun generate-pc-source-mapping (pc-start pc-end text-start text-end) - (if (every #'small-positive-integer-p - (list pc-start pc-end text-start text-end)) - (let ((mapping 0)) - (setf (ldb (byte 15 0) mapping) pc-start - (ldb (byte 15 15) mapping) pc-end - (ldb (byte 15 30) mapping) text-start - (ldb (byte 15 45) mapping) text-end) - mapping) - (vector pc-start pc-end text-start text-end))) - -(defstruct (pc-source-mapping (:type vector)) - pc-start - pc-end - text-start - text-end) + (cond + ((every #'small-positive-integer-p (list pc-start pc-end text-start text-end)) + (let ((mapping 0)) + (setf (ldb (byte 15 0) mapping) pc-start + (ldb (byte 15 15) mapping) pc-end + (ldb (byte 15 30) mapping) text-start + (ldb (byte 15 45) mapping) text-end) + mapping)) + ((every #'plusp (list pc-start pc-end text-start text-end)) + (vector pc-start pc-end text-start text-end)) + (t nil))) (defun x862-generate-pc-source-map (definition-source-note emitted-source-notes) (when *compiler-record-source* (let ((def-start (source-note-start definition-source-note)) - (vec (make-array (length emitted-source-notes)))) - (flet ((pc-start (note) (aref note )))) - (map-into vec - (lambda (start) - (make-pc-source-mapping :pc-start (x862-vinsn-note-label-address - start - t) - :pc-end (x862-vinsn-note-label-address + (vec (make-array (length emitted-source-notes) :fill-pointer 0))) + (loop + for start in emitted-source-notes + for mapping = (generate-pc-source-mapping (x862-vinsn-note-label-address + start + t) + (x862-vinsn-note-label-address (vinsn-note-peer start) - nil) - :text-start (- (source-note-start (aref (vinsn-note-info start) 0)) - def-start) - :text-end (- (source-note-end (aref (vinsn-note-info start) 0)) - def-start))) - emitted-source-notes) - vec))) + nil) + (- (source-note-start (aref (vinsn-note-info start) 0)) + def-start) + (- (source-note-end (aref (vinsn-note-info start) 0)) + def-start)) + when mapping + do (vector-push-extend mapping vec)) + (let ((simple-vec (make-array (length vec)))) + (map-into simple-vec #'identity vec) + simple-vec)))) (defun x862-vinsn-note-label-address (note &optional start-p sym) Index: /branches/working-0711/ccl/compiler/nx0.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx0.lisp (revision 8438) +++ /branches/working-0711/ccl/compiler/nx0.lisp (revision 8439) @@ -1569,5 +1569,5 @@ (defvar *compile-file-original-buffer-offset* nil) -(defun substream (stream start &optional end) +(defun substream (stream start end) "like subseq, but on streams that support file-position. Leaves stream positioned where it was before calling substream." @@ -1579,9 +1579,9 @@ ((not (open-stream-p stream)) (if (typep stream 'file-stream) - (if (probe-file (stream-pathname stream)) - (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens. - (substream f start end)) - "") - "")) + (if (probe-file (stream-pathname stream)) + (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens. + (substream f start end)) + "") + "")) (t (let ((now (file-position stream))) @@ -1630,5 +1630,5 @@ :start (+ start (or *compile-file-original-buffer-offset* 0)) :end (+ end (or *compile-file-original-buffer-offset* 0)) - :%text (%fast-compact (or text (substream stream start end))) + :%text text :form form :children children))) @@ -1643,9 +1643,9 @@ ;;; the struct. -(defun source-note-to-list (note &key (start t) (end t) (text t) (form t) (children t) (file-name t)) +(defun source-note-for-%lfun-info (note &key (start t) (end t) (text t) (form t) (children t) (file-name t)) (append (when start (list :start (source-note-start note))) - (when end (list :end (source-note-end note))) - (when text (list :%text (source-note-%text note))) - (when form (list :form (source-note-form note))) + (when end (list :end (source-note-end note))) + (when text (list :%text (%fast-compact (source-note-%text note)))) + (when form (list :form (source-note-form note))) (when children (list :children (source-note-children note))) (when file-name (list :file-name (source-note-file-name note))))) @@ -1675,4 +1675,19 @@ map)) +(defun compute-children-text (source-note stream) + (unless (source-note-%text source-note) + (setf (source-note-%text source-note) + (substream stream (source-note-start source-note) (source-note-end source-note)))) + (dolist (nested (source-note-children source-note)) + (when nested + (unless (source-note-%text nested) + (setf (source-note-%text nested) + (make-array (- (source-note-end nested) (source-note-start nested)) + :displaced-to (source-note-%text source-note) + :displaced-index-offset (- (source-note-start nested) + (source-note-start source-note))))) + (compute-children-text nested nil))) + source-note) + (defun nx1-source-note (nx1-code) "Return the source-note for the form which generated NX1-CODE." @@ -1694,6 +1709,6 @@ (loop for pc-map across pc-source-map - for pc-start = (aref pc-map 0) - for pc-end = (aref pc-map 1) + for pc-start = (pc-source-map-pc-start pc-map) + for pc-end = (pc-source-map-pc-end pc-map) do (when (and (<= pc-start pc pc-end) (or (null best-guess) @@ -1702,8 +1717,8 @@ best-length (- pc-end pc-start)))) (when best-guess - (list :pc-range (cons (aref best-guess 0) - (aref best-guess 1)) - :source-text-range (cons (aref best-guess 2) - (aref best-guess 3)) + (list :pc-range (cons (pc-source-map-pc-start best-guess) + (pc-source-map-pc-end best-guess)) + :source-text-range (cons (pc-source-map-text-start best-guess) + (pc-source-map-text-end best-guess)) :file-name (getf function-source-note :file-name) :text (getf function-source-note :text))))))) Index: /branches/working-0711/ccl/level-1/l1-reader.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8438) +++ /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8439) @@ -2503,30 +2503,24 @@ (values form t - (when (and (consp form) (record-source-location-on-stream-p stream)) + (when (and (not (eql t nested-source-notes)) + (consp form) + (record-source-location-on-stream-p stream)) + ;; mb 2008-02-07: sometime the nested-source-notes end with t, don't know + ;; why. don't really care here. + + (let ((last (last nested-source-notes))) + (when (atom (cdr last)) + ;; dotted list. + (setf (cdr last) (list (cdr last))))) (make-source-note :stream stream :start (1- start) :end end :form (car vals) - :children (labels ((rec (note) - ;; use this recursive function to - ;; remove nils since - ;; nested-source-notes can be a - ;; dotted list or an atom - (cond - ((consp note) - (if (null (car note)) - (rec (cdr note)) - (cons (car note) (rec (cdr note))))) - ((source-note-p note) - note) - #| ((null note) '()) - (t (error "Don't know how to deal with a source note like ~S." - nested-source-notes)) |# ))) - (rec nested-source-notes))))))))))) + :children nested-source-notes))))))))) #| (defun %parse-expression-test (string) - (let* ((stream (make-string-input-stream string))) - (%parse-expression stream (read-char stream t) nil))) +(let* ((stream (make-string-input-stream string))) +(%parse-expression stream (read-char stream t) nil))) (%parse-expression-test ";hello") Index: /branches/working-0711/ccl/lib/nfcomp.lisp =================================================================== --- /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8438) +++ /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8439) @@ -425,6 +425,6 @@ (return)) (setf form -form - *definition-source-note* source-note - *form-source-note-map* (make-source-note-form-map source-note + *definition-source-note* (compute-children-text source-note *fcomp-stream*) + *form-source-note-map* (make-source-note-form-map *definition-source-note* *form-source-note-map*)))))) (fcomp-form form env processing-mode) @@ -497,7 +497,4 @@ (record-form-source-equivalent/list form body) (fcomp-macrolet body env processing-mode)) - ;; special case for passing around source-location info - (%source-note (fcomp-form (list 'quote (source-note-to-list *definition-source-note*)) - env processing-mode)) ((%include include) (fcomp-include form env processing-mode)) (t