common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add function returning start+end line+col of recursive reads

Browse source 
It's in sb-int for now as opposed to sb-ext because we could do better-
it returns "missing" for the ending column most of the time.
This commit is contained in:
Douglas Katzman 2024-06-24 20:33:57 -04:00
parent 7c86a3348f
commit 83ff0e2e75
3 changed files with 75 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/cold/exports.lisp
View file

@ -623,6 +623,7 @@ possibly temporarily, because it might be used internally.")
"C-STRING-ENCODING-ERROR"
"C-STRING-DECODING-ERROR"
"ATTEMPT-RESYNC" "FORCE-END-OF-FILE"
"FORM-SOURCE-BOUNDS"
;; not potential SB-EXT exports
"GET-EXTERNAL-FORMAT" "GET-EXTERNAL-FORMAT-OR-LOSE"

63
src/compiler/target-main.lisp
View file

@ -304,16 +304,18 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
;; measurement unit. The standard allows counting in something other than
;; characters (namely bytes) for character streams, which is basically
;; irrelevant here, as we don't need random access to the file.
(compute-compile-file-position this-form nil))
(values (compute-compile-file-position this-form)))
(defmacro compile-file-line (&whole this-form)
"Return line# and column# of this macro invocation as multiple values."
(compute-compile-file-position this-form t))
(let ((start (form-source-bounds this-form)))
`(values ,(or (car start) 0) ,(or (cdr start) -1))))
)
(defun compute-compile-file-position (this-form as-line/col-p)
(let (file-info stream charpos)
(defun compute-compile-file-position (this-form)
(let (file-info stream start-pos end-pos)
(flet ((find-form-eq (form &optional fallback-path)
(when (and file-info (file-info-subforms file-info))
(with-array-data ((vect (file-info-subforms file-info))
(start) (end) :check-fill-pointer t)
(declare (ignore start))
@ -321,46 +323,51 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
((< i 0))
(declare (index-or-minus-1 i))
(when (eq form (svref vect i))
(if charpos ; ambiguous
(if start-pos ; ambiguous
(return
(setq charpos
(setf (values start-pos end-pos)
(and fallback-path
(compile-file-position-helper
file-info fallback-path))))
(setq charpos (svref vect (- i 2)))))))))
(let ((source-info *source-info*))
(setq start-pos (svref vect (- i 2))
end-pos (svref vect (1- i))))))))))
(let ((source-info *source-info*)
(source-path
(cond ((boundp '*current-path*) *current-path*)
((boundp '*source-paths*) (get-source-path this-form)))))
(when (and source-info (boundp '*current-path*))
(setq file-info (source-info-file-info source-info)
stream (source-info-stream source-info))
(cond
((not *current-path*)
((not source-path)
;; probably a read-time eval
(find-form-eq this-form))
;; Hmm, would a &WHOLE argument would work better or worse in general?
(t
(let* ((original-source-path (source-path-original-source *current-path*))
(let* ((original-source-path (source-path-original-source source-path))
(path (reverse original-source-path)))
(when (file-info-subforms file-info)
(let ((form (elt (file-info-forms file-info) (car path))))
(dolist (p (cdr path))
(unless (listp form)
;; probably comma
(return))
(setq form (nth p form)))
(find-form-eq form (cdr path))))
(unless charpos
(unless (and start-pos end-pos)
(let ((parent (source-info-parent *source-info*)))
;; probably in a local macro executing COMPILE-FILE-POSITION,
;; not producing a sexpr containing an invocation of C-F-P.
(when parent
(setq file-info (source-info-file-info parent)
stream (source-info-stream parent))
(find-form-eq this-form))))))))))
(if as-line/col-p
(if (and charpos (form-tracking-stream-p stream))
(let ((line/col (line/col-from-charpos stream charpos)))
`(values ,(car line/col) ,(cdr line/col)))
'(values 0 -1))
charpos)))
(find-form-eq this-form (cdr path)))))))))))
(values start-pos end-pos stream)))
;; Find FORM's character position in FILE-INFO by looking for PATH-TO-FIND.
;; Given the form whose source path is PATH-TO-FIND, return the values
;; corresponding to FILE-POSITION of that form's first and last characters.
;; (Note that thse are sometimes approximate depending on whitespace)
;; The form should be the currently-being-compiled toplevel form
;; or subform thereof, and findable by EQness in the FILE-INFO's forms read.
;; This is done by imparting tree structure to the annotations
;; more-or-less paralleling construction of the original sexpr.
;; Unfortunately, though this was a nice idea, it is not terribly useful.
@ -382,7 +389,7 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
;; answers. (Modulo any bugs due to near-total lack of testing)
(defun compile-file-position-helper (file-info path-to-find)
(let (start-char)
(let (start-char end-char)
(labels
((recurse (subpath upper-bound queue)
(let ((index -1))
@ -398,7 +405,8 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
;; This does not eagerly declare victory, because we want
;; to find the rightmost match. In "#1=(FOO)" there are two
;; different annotations pointing to (FOO).
(setq start-char (caar item)))
(setq start-char (caar item)
end-char (cdar item)))
(unless queue (return))
(let* ((next (car queue))
(next-end (cdar next)))
@ -425,4 +433,13 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
(aref v (+ i 2))))
#'< :key 'caar))))
(recurse path-to-find (cdaar list) (cdr list))))
start-char))
(values start-char end-char)))
;;; Given FORM which must be the currently-being-compiled toplevel form or subform thereof,
;;; return (VALUES START END) of that form where each coordinate is a cons (LINE . COLUMN).
(defun form-source-bounds (form)
(multiple-value-bind (start-pos end-pos stream) (compute-compile-file-position form)
(if (and start-pos end-pos (form-tracking-stream-p stream))
(values (line/col-from-charpos stream start-pos)
(line/col-from-charpos stream end-pos))
(values nil nil))))

34
tests/filecompile.impure-cload.lisp
View file

@ -73,3 +73,37 @@
(with-test (:name :compile-file-stream-line-column)
(assert (equal (foo-char-macro) '((31) (26)))))
(defglobal *form-grid-coordinates* (make-array 3 :fill-pointer 0))
(defmacro annotate-me (&whole thing &body body)
(multiple-value-bind (start end) (sb-int:form-source-bounds thing)
(vector-push-extend (vector start end) *form-grid-coordinates*)
`(progn ,@body)))
(defun kickme (x y)
(declare (integer x y))
"foo"
(progn
(annotate-me (+ (annotate-me (progn (* x
;;; ^ This left paranthesis is at line 88 column 4
;;; ^ and this one is line 88 column 20
5)))
(annotate-me (logcount y)))
)))
;;; ^ this right parenthesis is at line 93 column 16
;;; Hint: move around in Emacs to visually confirm that this output
;;; looks right, then plug the numbers into the test below.
#+nil(format t "~&According to compiler: ~S~%" *form-grid-coordinates*)
(with-test (:name :form-grid-coords-golden-test)
(flet ((assert-line/col-is (index start end)
(let ((actual (aref *form-grid-coordinates* index)))
(assert (equal start (aref actual 0)))
(assert (equal end (aref actual 1))))))
(assert-line/col-is 0 '(88 . 4) '(93 . 16))
;; Somehow we can't figure out where annotation 1 ends precisely
;; but we do see that newlines occurred.
(assert-line/col-is 1 '(88 . 20) '(92 . -1))
(assert-line/col-is 2 '(92 . 18) '(92 . 44))))