243 lines
9.2 KiB
Common Lisp
243 lines
9.2 KiB
Common Lisp
;;;; Source-paths
|
|
|
|
;;; CMUCL/SBCL use a data structure called "source-path" to locate
|
|
;;; subforms. The compiler assigns a source-path to each form in a
|
|
;;; compilation unit. Compiler notes usually contain the source-path
|
|
;;; of the error location.
|
|
;;;
|
|
;;; Compiled code objects don't contain source paths, only the
|
|
;;; "toplevel-form-number" and the (sub-) "form-number". To get from
|
|
;;; the form-number to the source-path we need the entire toplevel-form
|
|
;;; (i.e. we have to read the source code). CMUCL has already some
|
|
;;; utilities to do this translation, but we use some extended
|
|
;;; versions, because we need more exact position info. Apparently
|
|
;;; Hemlock is happy with the position of the toplevel-form; we also
|
|
;;; need the position of subforms.
|
|
;;;
|
|
;;; We use a special readtable to get the positions of the subforms.
|
|
;;; The readtable stores the start and end position for each subform in
|
|
;;; hashtable for later retrieval.
|
|
;;;
|
|
;;; This code has been placed in the Public Domain. All warranties
|
|
;;; are disclaimed.
|
|
|
|
;;; Taken from swank-cmucl.lisp, by Helmut Eller
|
|
|
|
(defpackage swank/source-path-parser
|
|
(:use cl)
|
|
(:export
|
|
read-source-form
|
|
source-path-string-position
|
|
source-path-file-position
|
|
source-path-source-position
|
|
|
|
sexp-in-bounds-p
|
|
sexp-ref)
|
|
(:shadow ignore-errors))
|
|
|
|
(in-package swank/source-path-parser)
|
|
|
|
;; Some test to ensure the required conformance
|
|
(let ((rt (copy-readtable nil)))
|
|
(assert (or (not (get-macro-character #\space rt))
|
|
(nth-value 1 (get-macro-character #\space rt))))
|
|
(assert (not (get-macro-character #\\ rt))))
|
|
|
|
(eval-when (:compile-toplevel)
|
|
(defmacro ignore-errors (&rest forms)
|
|
;;`(progn . ,forms) ; for debugging
|
|
`(cl:ignore-errors . ,forms)))
|
|
|
|
(defun make-sharpdot-reader (orig-sharpdot-reader)
|
|
(lambda (s c n)
|
|
;; We want things like M-. to work regardless of any #.-fu in
|
|
;; the source file that is to be visited. (For instance, when a
|
|
;; file contains #. forms referencing constants that do not
|
|
;; currently exist in the image.)
|
|
(ignore-errors (funcall orig-sharpdot-reader s c n))))
|
|
|
|
(defun make-source-recorder (fn source-map)
|
|
"Return a macro character function that does the same as FN, but
|
|
additionally stores the result together with the stream positions
|
|
before and after of calling FN in the hashtable SOURCE-MAP."
|
|
(lambda (stream char)
|
|
(let ((start (1- (file-position stream)))
|
|
(values (multiple-value-list (funcall fn stream char)))
|
|
(end (file-position stream)))
|
|
#+(or)
|
|
(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
|
|
start values end (char-code char) char)
|
|
(when values
|
|
(destructuring-bind (&optional existing-start &rest existing-end)
|
|
(car (gethash (car values) source-map))
|
|
;; Some macros may return what a sub-call to another macro
|
|
;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
|
|
;; once from #\# and once from #\(. If the saved form
|
|
;; is a subform, don't save it again.
|
|
(unless (and existing-start existing-end
|
|
(<= start existing-start end)
|
|
(<= start existing-end end))
|
|
(push (cons start end) (gethash (car values) source-map)))))
|
|
(values-list values))))
|
|
|
|
(defun make-source-recording-readtable (readtable source-map)
|
|
(declare (type readtable readtable) (type hash-table source-map))
|
|
"Return a source position recording copy of READTABLE.
|
|
The source locations are stored in SOURCE-MAP."
|
|
(flet ((install-special-sharpdot-reader (rt)
|
|
(let ((fun (ignore-errors
|
|
(get-dispatch-macro-character #\# #\. rt))))
|
|
(when fun
|
|
(let ((wrapper (make-sharpdot-reader fun)))
|
|
(set-dispatch-macro-character #\# #\. wrapper rt)))))
|
|
(install-wrappers (rt)
|
|
(dotimes (code 128)
|
|
(let ((char (code-char code)))
|
|
(multiple-value-bind (fun nt) (get-macro-character char rt)
|
|
(when fun
|
|
(let ((wrapper (make-source-recorder fun source-map)))
|
|
(set-macro-character char wrapper nt rt))))))))
|
|
(let ((rt (copy-readtable readtable)))
|
|
(install-special-sharpdot-reader rt)
|
|
(install-wrappers rt)
|
|
rt)))
|
|
|
|
;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
|
|
;; Should be possible as we only need the right "list structure" and
|
|
;; not the right atoms.
|
|
(defun read-and-record-source-map (stream)
|
|
"Read the next object from STREAM.
|
|
Return the object together with a hashtable that maps
|
|
subexpressions of the object to stream positions."
|
|
(let* ((source-map (make-hash-table :test #'eq))
|
|
(*readtable* (make-source-recording-readtable *readtable* source-map))
|
|
(*read-suppress* nil)
|
|
(start (file-position stream))
|
|
(form (ignore-errors (read stream)))
|
|
(end (file-position stream)))
|
|
;; ensure that at least FORM is in the source-map
|
|
(unless (gethash form source-map)
|
|
(push (cons start end) (gethash form source-map)))
|
|
(values form source-map)))
|
|
|
|
(defun starts-with-p (string prefix)
|
|
(declare (type string string prefix))
|
|
(not (mismatch string prefix
|
|
:end1 (min (length string) (length prefix))
|
|
:test #'char-equal)))
|
|
|
|
(defun extract-package (line)
|
|
(declare (type string line))
|
|
(let ((name (cadr (read-from-string line))))
|
|
(find-package name)))
|
|
|
|
#+(or)
|
|
(progn
|
|
(assert (extract-package "(in-package cl)"))
|
|
(assert (extract-package "(cl:in-package cl)"))
|
|
(assert (extract-package "(in-package \"CL\")"))
|
|
(assert (extract-package "(in-package #:cl)")))
|
|
|
|
;; FIXME: do something cleaner than this.
|
|
(defun readtable-for-package (package)
|
|
;; KLUDGE: due to the load order we can't reference the swank
|
|
;; package.
|
|
(funcall (read-from-string "swank::guess-buffer-readtable")
|
|
(string-upcase (package-name package))))
|
|
|
|
;; Search STREAM for a "(in-package ...)" form. Use that to derive
|
|
;; the values for *PACKAGE* and *READTABLE*.
|
|
;;
|
|
;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends
|
|
;; use the same heuristic and to avoid the need to access
|
|
;; swank::guess-buffer-readtable from here.
|
|
(defun guess-reader-state (stream)
|
|
(let* ((point (file-position stream))
|
|
(pkg *package*))
|
|
(file-position stream 0)
|
|
(loop for line = (read-line stream nil nil) do
|
|
(when (not line) (return))
|
|
(when (or (starts-with-p line "(in-package ")
|
|
(starts-with-p line "(cl:in-package "))
|
|
(let ((p (extract-package line)))
|
|
(when p (setf pkg p)))
|
|
(return)))
|
|
(file-position stream point)
|
|
(values (readtable-for-package pkg) pkg)))
|
|
|
|
(defun skip-whitespace (stream)
|
|
(peek-char t stream nil nil))
|
|
|
|
;; Skip over N toplevel forms.
|
|
(defun skip-toplevel-forms (n stream)
|
|
(let ((*read-suppress* t))
|
|
(dotimes (i n)
|
|
(read stream))
|
|
(skip-whitespace stream)))
|
|
|
|
(defun read-source-form (n stream)
|
|
"Read the Nth toplevel form number with source location recording.
|
|
Return the form and the source-map."
|
|
(multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
|
|
(let (#+sbcl
|
|
(*features* (append *features*
|
|
(symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl)))))
|
|
(skip-toplevel-forms n stream)
|
|
(read-and-record-source-map stream))))
|
|
|
|
(defun source-path-stream-position (path stream)
|
|
"Search the source-path PATH in STREAM and return its position."
|
|
(check-source-path path)
|
|
(destructuring-bind (tlf-number . path) path
|
|
(multiple-value-bind (form source-map) (read-source-form tlf-number stream)
|
|
(source-path-source-position (cons 0 path) form source-map))))
|
|
|
|
(defun check-source-path (path)
|
|
(unless (and (consp path)
|
|
(every #'integerp path))
|
|
(error "The source-path ~S is not valid." path)))
|
|
|
|
(defun source-path-string-position (path string)
|
|
(with-input-from-string (s string)
|
|
(source-path-stream-position path s)))
|
|
|
|
(defun source-path-file-position (path filename)
|
|
;; We go this long way round, and don't directly operate on the file
|
|
;; stream because FILE-POSITION (used above) is not totally savy even
|
|
;; on file character streams; on SBCL, FILE-POSITION returns the binary
|
|
;; offset, and not the character offset---screwing up on Unicode.
|
|
(let ((toplevel-number (first path))
|
|
(buffer))
|
|
(with-open-file (file filename)
|
|
(skip-toplevel-forms (1+ toplevel-number) file)
|
|
(let ((endpos (file-position file)))
|
|
(setq buffer (make-array (list endpos) :element-type 'character
|
|
:initial-element #\Space))
|
|
(assert (file-position file 0))
|
|
(read-sequence buffer file :end endpos)))
|
|
(source-path-string-position path buffer)))
|
|
|
|
(defgeneric sexp-in-bounds-p (sexp i)
|
|
(:method ((list list) i)
|
|
(< i (loop for e on list
|
|
count t)))
|
|
(:method ((sexp t) i) nil))
|
|
|
|
(defgeneric sexp-ref (sexp i)
|
|
(:method ((s list) i) (elt s i)))
|
|
|
|
(defun source-path-source-position (path form source-map)
|
|
"Return the start position of PATH from FORM and SOURCE-MAP. All
|
|
subforms along the path are considered and the start and end position
|
|
of the deepest (i.e. smallest) possible form is returned."
|
|
;; compute all subforms along path
|
|
(let ((forms (loop for i in path
|
|
for f = form then (if (sexp-in-bounds-p f i)
|
|
(sexp-ref f i))
|
|
collect f)))
|
|
;; select the first subform present in source-map
|
|
(loop for form in (nreverse forms)
|
|
for ((start . end) . rest) = (gethash form source-map)
|
|
when (and start end (not rest))
|
|
return (return (values start end)))))
|