diff options
Diffstat (limited to 'vim/bundle/slimv/slime/swank/source-path-parser.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/swank/source-path-parser.lisp | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/source-path-parser.lisp b/vim/bundle/slimv/slime/swank/source-path-parser.lisp new file mode 100644 index 0000000..bb9c35c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/source-path-parser.lisp @@ -0,0 +1,239 @@ +;;;; 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) + (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))))) |