diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index a1f95d736..94bc2def5 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -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 diff --git a/tests/compiler-2.impure-cload.lisp b/tests/compiler-2.impure-cload.lisp index c2a04a325..433ef07bb 100644 --- a/tests/compiler-2.impure-cload.lisp +++ b/tests/compiler-2.impure-cload.lisp @@ -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*)))