1.0.48.4: source locations for init files

 Refactor PROCESS-INIT-FILE to share code with LOAD-AS-SOURCE.

 Also add in contrib/sb-introspect/load-test.lisp which was
 left out from the last commit.

diff --git a/NEWS b/NEWS
index 15c4775..132c6e7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,9 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.48:
-  * enhancement: functions from files loaded as source now have source
-    locations.
-  * enhancement: functions from compile-time-too evaluation now have source
-    locations.
+  * enhancement: source locations are now available for files loaded as source,
+    compile-time-too evaluation, and initialization files.
   * enhancement: WITH-COMPILATION-UNIT :SOURCE-NAMESTRING allows providing
     virtual source-file information, eg. overriding input-file of COMPILE-FILE
     when a temporary file is used for compilation.

diff --git a/contrib/sb-introspect/load-test.lisp b/contrib/sb-introspect/load-test.lisp
new file mode 100644 (file)
index 0000000..3fc51f9
--- /dev/null
+++ b/contrib/sb-introspect/load-test.lisp
@@ -0,0 +1,14 @@
+;;;
+;;; The order of the forms must not change, as the order is checked in
+;;; `test-driver.lisp'. Thus do not alter this file unless you edit
+;;; test-driver.lisp to match.
+;;;
+
+(declaim (optimize (debug 3)))
+(in-package :cl-user)
+
+(eval-when (:compile-toplevel)
+  (error "load-test.lisp needs to be loaded as source"))
+
+(defun loaded-as-source-fun ()
+  t)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 651ba3d..cf4afc2 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1143,6 +1143,7 @@ possibly temporariliy, because it might be used internally."
                "DEBUG-NAMIFY"
                "FORCE" "DELAY" "PROMISE-READY-P"
                "FIND-RESTART-OR-CONTROL-ERROR"
+               "LOAD-AS-SOURCE"
 
                ;; These could be moved back into SB!EXT if someone has
                ;; compelling reasons, but hopefully we can get by

diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp
index 6f2912e..48b3fc3 100644 (file)
--- a/src/code/target-load.lisp
+++ b/src/code/target-load.lisp
@@ -28,39 +28,37 @@
 ;;;; LOAD-AS-SOURCE
 
 ;;; Load a text stream.  (Note that load-as-fasl is in another file.)
-(defun load-as-source (stream verbose print)
+(defun load-as-source (stream &key verbose print (context "loading"))
   (maybe-announce-load stream verbose)
-  (macrolet
-      ((do-sexprs (((sexpr index) stream) &body body)
-         (aver (symbolp sexpr))
-         (with-unique-names (source-info)
-           (once-only ((stream stream))
-             `(if (handler-case (pathname stream)
-                    (error () nil))
-                  (let* ((,source-info (sb!c::make-file-source-info
-                                        (pathname ,stream)
-                                        (stream-external-format ,stream)))
-                         (sb!c::*source-info* ,source-info)
-                         (sb!c::*source-paths* (make-hash-table :test 'eq)))
-                    (setf (sb!c::source-info-stream ,source-info) ,stream)
-                    (sb!c::do-forms-from-info ((,sexpr current-index)
-                                               ,source-info)
-                      (sb!c::find-source-paths ,sexpr current-index)
-                      (let ((,index current-index))
-                        ,@body)))
-                  (let ((sb!c::*source-info* nil)
-                        (,index nil))
-                    (do ((,sexpr (read ,stream nil *eof-object*)
-                                 (read ,stream nil *eof-object*)))
-                        ((eq ,sexpr *eof-object*))
-                      ,@body)))))))
-    (do-sexprs ((sexpr tlf-index) stream)
-      (if print
-          (let ((results (multiple-value-list (eval-tlf sexpr tlf-index))))
-            (load-fresh-line)
-            (format t "~{~S~^, ~}~%" results))
-          (eval-tlf sexpr tlf-index)))
-    t))
+  (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
+         (native (when pathname (native-namestring pathname))))
+    (with-simple-restart (abort "Abort ~A file ~S." context native)
+      (flet ((eval-form (form index)
+               (with-simple-restart (continue "Ignore error and continue ~A file ~S."
+                                              context native)
+                 (loop
+                   (with-simple-restart (retry "Retry EVAL of current toplevel form.")
+                     (if print
+                         (let ((results (multiple-value-list (eval-tlf form index))))
+                           (load-fresh-line)
+                           (format t "~{~S~^, ~}~%" results))
+                         (eval-tlf form index)))
+                   (return)))))
+        (if pathname
+            (let* ((info (sb!c::make-file-source-info
+                          pathname (stream-external-format stream)))
+                   (sb!c::*source-info* info)
+                   (sb!c::*source-paths* (make-hash-table :test 'eq)))
+              (setf (sb!c::source-info-stream info) stream)
+              (sb!c::do-forms-from-info ((form current-index) info)
+                (sb!c::find-source-paths form current-index)
+                (eval-form form current-index)))
+            (let ((sb!c::*source-info* nil))
+              (do ((form (read stream nil *eof-object*)
+                         (read stream nil *eof-object*)))
+                  ((eq form *eof-object*))
+                (eval-form form nil)))))))
+  t)
 \f
 ;;;; LOAD itself
 
@@ -119,7 +117,7 @@
              (return-from load
                (if faslp
                    (load-as-fasl stream verbose print)
-                   (load-as-source stream verbose print))))))
+                   (load-as-source stream :verbose verbose :print print))))))
     ;; Case 1: stream.
     (when (streamp pathspec)
       (return-from load (load-stream pathspec (fasl-header-p pathspec))))

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index f519002..7c84ba6 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -245,30 +245,19 @@ any non-negative real number."
          (values "sysinit" *sysinit-pathname-function*))
         (:user
          (values "userinit" *userinit-pathname-function*)))
-    (flet ((process-stream (stream pathname)
-             (with-simple-restart (abort "Skip rest of ~A file ~S."
-                                         context (native-namestring pathname))
-               (loop
-                 (with-simple-restart
-                     (continue "Ignore error and continue processing ~A file ~S."
-                               context (native-namestring pathname))
-                   (let ((form (read stream nil stream)))
-                     (if (eq stream form)
-                         (return-from process-init-file nil)
-                         (eval form))))))))
-      (if specified-pathname
-          (with-open-file (stream (parse-native-namestring specified-pathname)
-                                  :if-does-not-exist nil)
-            (if stream
-                (process-stream stream (pathname stream))
-                (cerror "Ignore missing init file"
-                        "The specified ~A file ~A was not found."
-                        context specified-pathname)))
-          (let ((default (funcall default-function)))
-            (when default
-              (with-open-file (stream (pathname default) :if-does-not-exist nil)
-                (when stream
-                  (process-stream stream (pathname stream))))))))))
+    (if specified-pathname
+        (with-open-file (stream (parse-native-namestring specified-pathname)
+                                :if-does-not-exist nil)
+          (if stream
+              (load-as-source stream :context context)
+              (cerror "Ignore missing init file"
+                      "The specified ~A file ~A was not found."
+                      context specified-pathname)))
+        (let ((default (funcall default-function)))
+          (when default
+            (with-open-file (stream (pathname default) :if-does-not-exist nil)
+              (when stream
+                (load-as-source stream :context context))))))))
 
 (defun process-eval/load-options (options)
   (/show0 "handling --eval and --load options")

diff --git a/tests/init.test.sh b/tests/init.test.sh
index fed1fb8..642d5ca 100644 (file)
--- a/tests/init.test.sh
+++ b/tests/init.test.sh
@@ -20,6 +20,7 @@ use_test_subdirectory
 tmpcore="init-test.core"
 
 run_sbcl <<EOF
+  (require :sb-introspect)
   (defun custom-userinit-pathname ()
      "$SBCL_PWD/custom-userinit.lisp")
   (defun custom-sysinit-pathname ()
@@ -33,6 +34,11 @@ if [ $? != 0 ]; then
     exit 1
 fi
 run_sbcl_with_core "$tmpcore" --disable-debugger <<EOF
+  (assert (string= (custom-sysinit-pathname)
+                   (namestring
+                    (sb-introspect:definition-source-pathname
+                     (car (sb-introspect:find-definition-sources-by-name
+                           'sysinit-21 :function))))))
   (userinit-quit (sysinit-21))
 EOF
 check_status_maybe_lose "userinit and sysinit loading" $? 21 "(loading worked)"

diff --git a/version.lisp-expr b/version.lisp-expr
index 22da1e0..67cb2c3 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.48.3"
+"1.0.48.4"