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

Allow COMPILE-FILE-POSITION in more situations

Browse source 
A way to understand the new logic is that supposing (hypothetically) that
COMPILE-FILE-POSITION were a function, not a macro, then previously it was
acceptable only where the call to it would occur at runtime and not sooner.
This patch makes it ok to use at read-time and/or compile-time.
Of course since it is a macro, the call always occurs in the compiler,
so the preceding is just a model for explaining the behavioral change.
This commit is contained in:
Douglas Katzman 2015-04-19 22:29:35 -04:00
parent 21264e9461
commit 88b273a5e0
2 changed files with 62 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -208,21 +208,11 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
;; as a design choice, but just an accident of the particular implementation.
;;
(let ()
(defmacro compile-file-position ()
(defmacro compile-file-position (&whole this-form)
#!+sb-doc
"Return line# and column# of this macro invocation as multiple values."
(or (and *source-info*
(file-info-subforms (source-info-file-info *source-info*))
(boundp '*current-path*)
*current-path*
(let* ((original-source-path
(cddr (member 'original-source-start *current-path*)))
(path (reverse original-source-path))
(file-info (source-info-file-info *source-info*))
(form (elt (file-info-forms file-info) (car path)))
(charpos))
(dolist (p (cdr path))
(setq form (nth p form)))
(let (file-info charpos)
(flet ((find-form-eq (form &optional fallback-path)
(with-array-data ((vect (file-info-subforms file-info))
(start) (end) :check-fill-pointer t)
(declare (ignore start))
@ -231,24 +221,50 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
(declare (index-or-minus-1 i))
(when (eq form (svref vect i))
(if charpos ; ambiguous
(return (setq charpos (compile-file-position-helper
file-info (cdr path))))
(setq charpos (svref vect (- i 2)))))))
(when charpos
(let* ((newlines (file-info-newlines file-info))
(index
(position charpos newlines :test #'>= :from-end t)))
;; Line numbers traditionally begin at 1, columns at 0.
(if index
;; INDEX is 1 less than the number of newlines seen
;; up to and including this startpos.
;; e.g. index=0 => 1 newline seen => line=2
`(values ,(+ index 2)
;; 1 char after the newline = column 0
,(- charpos (aref newlines index) 1))
;; zero newlines were seen
`(values 1 ,charpos))))))
'(values 0 -1))))
(return
(setq charpos
(and fallback-path
(compile-file-position-helper
file-info fallback-path))))
(setq charpos (svref vect (- i 2)))))))))
(cond
((and *source-info* (boundp '*current-path*) (not *current-path*))
;; probably a read-time eval
(setq file-info (source-info-file-info *source-info*))
(find-form-eq this-form))
;; Hmm, would a &WHOLE argument would work better or worse in general?
((and *source-info* (boundp '*current-path*) *current-path*)
(setq file-info (source-info-file-info *source-info*))
(let* ((original-source-path
(cddr (member 'original-source-start *current-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))
(setq form (nth p form)))
(find-form-eq form (cdr path))))
(unless charpos
(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))
(find-form-eq this-form)))))))
(if charpos
(let* ((newlines (file-info-newlines file-info))
(index
(position charpos newlines :test #'>= :from-end t)))
;; Line numbers traditionally begin at 1, columns at 0.
(if index
;; INDEX is 1 less than the number of newlines seen
;; up to and including this startpos.
;; e.g. index=0 => 1 newline seen => line=2
`(values ,(+ index 2)
;; 1 char after the newline = column 0
,(- charpos (aref newlines index) 1))
;; zero newlines were seen
`(values 1 ,charpos)))
'(values 0 -1))))))
;; Find FORM's character position in FILE-INFO by looking for PATH-TO-FIND.
;; This is done by imparting tree structure to the annotations
@ -271,9 +287,6 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
;; However, if you _could_ supply correct paths, this would compute correct
;; answers. (Modulo any bugs due to near-total lack of testing)
;; Also note one more thing that doesn't work, and expectedly so:
;; (DEFUN F () (FORMAT T #.(FORMAT NIL "Fail ~D~%" (COMPILE-FILE-POSITION))))
(defun compile-file-position-helper (file-info path-to-find)
(let (found-form start-char)
(labels

16
tests/compiler-2.impure-cload.lisp
View file

@ -116,11 +116,25 @@
(more-randomness))
(progn (more-randomness))))))) ; <-- this is line 117
(defun compile-file-pos-sharp-dot (x)
(list #.(format nil "Foo line ~D" (compile-file-position)) ; line #120
x))
(defun compile-file-pos-eval-in-macro ()
(macrolet ((macro (x)
(format nil "hi ~A at ~D" x
(compile-file-position)))) ; line #126
(macro "there")))
(with-test (:name :compile-file-position)
(assert (string= (more-foo t) "Great! (97 . 32)"))
(assert (string= (more-foo nil) "Yikes (98 . 31)"))
(assert (string= (bork t) "failed to frob a knob at line #103"))
(assert (string= (bork nil) "failed to frob a knob at line #117")))
(assert (string= (bork nil) "failed to frob a knob at line #117"))
(assert (string= (car (compile-file-pos-sharp-dot nil))
"Foo line 120"))
(assert (string= (compile-file-pos-eval-in-macro)
"hi there at 126")))
(eval-when (:compile-toplevel)
(let ((stream (sb-c::source-info-stream sb-c::*source-info*)))