(tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
(make-definition-source
:pathname
- (if (eql (sb-c::debug-source-from debug-source) :file)
- (parse-namestring (sb-c::debug-source-name debug-source)))
+ ;; KLUDGE: at the moment, we don't record the correct toplevel
+ ;; form number for forms processed by EVAL (including EVAL-WHEN
+ ;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a
+ ;; DEFINITION-SOURCE with a pathname. (When that's fixed, take
+ ;; out the (not (debug-source-form ...)) test.
+ (if (and (sb-c::debug-source-namestring debug-source)
+ (not (sb-c::debug-source-form debug-source)))
+ (parse-namestring (sb-c::debug-source-namestring debug-source)))
:character-offset
(if tlf
(elt (sb-c::debug-source-start-positions debug-source) tlf))
:doc "private: primitives used to write debuggers"
:use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS" "SB!VM")
:import-from (("SB!C"
- "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME"
+ "DEBUG-SOURCE-FORM" "DEBUG-SOURCE-NAMESTRING"
"DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED"
"DEBUG-SOURCE-START-POSITIONS" "MAKE-DEBUG-SOURCE"
"DEBUG-SOURCE" "DEBUG-SOURCE-P"))
- :reexport ("DEBUG-SOURCE-FROM"
- "DEBUG-SOURCE-NAME"
+ :reexport ("DEBUG-SOURCE-FORM"
+ "DEBUG-SOURCE-NAMESTRING"
"DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED"
"DEBUG-SOURCE-START-POSITIONS" "DEBUG-SOURCE"
"DEBUG-SOURCE-P")
;;; There is one per compiled file and one per function compiled at
;;; toplevel or loaded from source.
(def!struct (debug-source #-sb-xc-host (:pure t))
- ;; This slot indicates where the definition came from:
- ;; :FILE - from a file (i.e. COMPILE-FILE)
- ;; :LISP - from Lisp (i.e. COMPILE)
- (from (missing-arg) :type (member :file :lisp))
- ;; If :FILE, the file name, if :LISP or :STREAM, then a vector of
- ;; the top level forms. When from COMPILE, form 0 is #'(LAMBDA ...).
- (name nil)
+ ;; (This is one of those structures where IWBNI we had multiple
+ ;; inheritance. The first four slots describe compilation of a
+ ;; file, the fifth and sixth compilation of a form processed by
+ ;; EVAL, and the seventh and eigth all compilation units; and these
+ ;; are orthogonal concerns that can combine independently.)
+
+ ;; When the DEBUG-SOURCE describes a file, the file's namestring.
+ ;; Otherwise, NIL.
+ (namestring nil :type (or null string))
;; the universal time that the source was written, or NIL if
;; unavailable
(created nil :type (or unsigned-byte null))
- ;; the universal time that the source was compiled
- (compiled (missing-arg) :type unsigned-byte)
;; the source path root number of the first form read from this
;; source (i.e. the total number of forms converted previously in
- ;; this compilation)
+ ;; this compilation). (Note: this will always be 0 so long as the
+ ;; SOURCE-INFO structure has exactly one FILE-INFO.)
(source-root 0 :type index)
;; The FILE-POSITIONs of the truly top level forms read from this
;; file (if applicable). The vector element type will be chosen to
- ;; hold the largest element. May be null to save space, or if
- ;; :DEBUG-SOURCE-FORM is :LISP.
+ ;; hold the largest element.
(start-positions nil :type (or (simple-array * (*)) null))
- ;; If from :LISP, this is the function whose source is form 0.
+
+ ;; For functions processed by EVAL (including EVAL-WHEN and LOAD on
+ ;; a source file), the source form.
+ (form nil :type list)
+ ;; This is the function whose source is the form.
(function nil)
+
+ ;; the universal time that the source was compiled
+ (compiled (missing-arg) :type unsigned-byte)
;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...))
(plist *source-plist*))
\f
(values *cached-form-number-translations* *cached-toplevel-form*)
(let* ((offset (sb!di:code-location-toplevel-form-offset location))
(res
- (ecase (sb!di:debug-source-from d-source)
- (:file (get-file-toplevel-form location))
- (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
+ (cond ((sb!di:debug-source-namestring d-source)
+ (get-file-toplevel-form location))
+ ((sb!di:debug-source-form d-source)
+ (sb!di:debug-source-form d-source))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form.")))))
(setq *cached-toplevel-form-offset* offset)
(values (setq *cached-form-number-translations*
(sb!di:form-number-translations res offset))
(aref (or (sb!di:debug-source-start-positions d-source)
(error "no start positions map"))
local-tlf-offset))
- (name (sb!di:debug-source-name d-source)))
+ (name (sb!di:debug-source-namestring d-source)))
(unless (eq d-source *cached-debug-source*)
(unless (and *cached-source-stream*
(equal (pathname *cached-source-stream*)
;; any nondefault options.
(format-universal-time nil (sb-c::debug-source-compiled source)
:style :abbreviated))
- (let ((name (sb-c::debug-source-name source)))
- (ecase (sb-c::debug-source-from source)
- (:file
- (format s "~&~A~@:_ Created: " (namestring name))
- (format-universal-time s (sb-c::debug-source-created source)))
- (:lisp (format s "~& ~S" (aref name 0))))))))))
+ (let ((name (sb-c::debug-source-namestring source)))
+ (cond (name
+ (format s "~&~A~@:_ Created: " name)
+ (format-universal-time s (sb-c::debug-source-created source)))
+ ((sb-di:debug-source-form source)
+ (format s "~& ~S" (sb-di:debug-source-form source)))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form.")))))))))
;;; Describe a compiled function. The closure case calls us to print
;;; the guts.
\f
;;;; LOAD-AS-SOURCE
-;;; Load a text file. (Note that load-as-fasl is in another file.)
+;;; Load a text stream. (Note that load-as-fasl is in another file.)
(defun load-as-source (stream verbose print)
(maybe-announce-load stream verbose)
- (do ((sexpr (read stream nil *eof-object*)
- (read stream nil *eof-object*)))
- ((eq sexpr *eof-object*)
- t)
- (if print
- (let ((results (multiple-value-list (eval sexpr))))
- (load-fresh-line)
- (format t "~{~S~^, ~}~%" results))
- (eval sexpr))))
+ (macrolet ((do-sexprs ((sexpr 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))))
+ (setf (sb!c::source-info-stream ,source-info) ,stream)
+ (sb!c::do-forms-from-info ((,sexpr) ,source-info)
+ ,@body))
+ (do ((,sexpr (read ,stream nil *eof-object*)
+ (read ,stream nil *eof-object*)))
+ ((eq ,sexpr *eof-object*))
+ ,@body))))))
+ (do-sexprs (sexpr stream)
+ (if print
+ (let ((results (multiple-value-list (eval sexpr))))
+ (load-fresh-line)
+ (format t "~{~S~^, ~}~%" results))
+ (eval sexpr)))
+ t))
\f
;;;; LOAD itself
;;;; function names and documentation
;;;; the ANSI interface to function names (and to other stuff too)
+;;; Note: this function gets called by the compiler (as of 1.0.17.x,
+;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says
+;;; we're allowed to return NIL here freely, it seems plausible that
+;;; small changes to the circumstances under which this function
+;;; returns non-NIL might have subtle consequences on the compiler.
+;;; So it might be desirable to have the compiler not rely on this
+;;; function, eventually.
(defun function-lambda-expression (fun)
"Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
(info (sb!kernel:%code-debug-info code)))
(if info
(let ((source (sb!c::debug-info-source info)))
- (cond ((and (eq (sb!c::debug-source-from source) :lisp)
+ (cond ((and (sb!c::debug-source-form source)
(eq (sb!c::debug-source-function source) fun))
- (values (svref (sb!c::debug-source-name source) 0)
+ (values (sb!c::debug-source-form source)
nil
name))
((legal-fun-name-p name)
\f
;;; Return DEBUG-SOURCE structure containing information derived from
;;; INFO.
-(defun debug-source-for-info (info)
+(defun debug-source-for-info (info &key function)
(declare (type source-info info))
- (let* ((file-info (source-info-file-info info))
- (res (make-debug-source
- :from :file
- :created (file-info-write-date file-info)
- :compiled (source-info-start-time info)
- :source-root (file-info-source-root file-info)
- :start-positions (coerce-to-smallest-eltype
- (file-info-positions file-info))))
- (name (file-info-name file-info)))
- (etypecase name
- ((member :lisp)
- (setf (debug-source-from res) name
- (debug-source-name res) (file-info-forms file-info)))
- (pathname
- (setf (debug-source-name res)
- (make-file-info-namestring name file-info))))
- res))
+ (let ((file-info (get-toplevelish-file-info info)))
+ (make-debug-source
+ :compiled (source-info-start-time info)
+
+ :namestring (make-file-info-namestring
+ (if (pathnamep (file-info-name file-info))
+ (file-info-name file-info))
+ file-info)
+ :created (file-info-write-date file-info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))
+
+ :form (let ((direct-file-info (source-info-file-info info)))
+ (if (eq :lisp (file-info-name direct-file-info))
+ (elt (file-info-forms direct-file-info) 0)))
+ :function function)))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
;;; possible. Ordinarily we coerce it to the smallest specialized
(declare (type core-object object)
(type (or null function) function))
(aver (zerop (hash-table-count (core-object-patch-table object))))
- (let ((source (debug-source-for-info info)))
- (setf (debug-source-function source) function)
+ (let ((source (debug-source-for-info info :function function)))
(dolist (info (core-object-debug-info object))
(setf (debug-info-source info) source)))
(setf (core-object-debug-info object) nil)
;;; A FILE-INFO structure holds all the source information for a
;;; given file.
-(def!struct (file-info (:copier nil))
+(def!struct (file-info
+ (:copier nil)
+ #-no-ansi-print-object
+ (:print-object (lambda (s stream)
+ (print-unreadable-object (s stream :type t)
+ (princ (file-info-name s) stream)))))
;; If a file, the truename of the corresponding source file. If from
;; a Lisp form, :LISP. If from a stream, :STREAM.
- (name (missing-arg) :type (or pathname (member :lisp :stream)))
+ (name (missing-arg) :type (or pathname (eql :lisp)))
;; the external format that we'll call OPEN with, if NAME is a file.
(external-format nil)
;; the defaulted, but not necessarily absolute file name (i.e. prior
(file-info nil :type (or file-info null))
;; the stream that we are using to read the FILE-INFO, or NIL if
;; no stream has been opened yet
- (stream nil :type (or stream null)))
+ (stream nil :type (or stream null))
+ ;; if the current compilation is recursive (e.g., due to EVAL-WHEN
+ ;; processing at compile-time), the invoking compilation's
+ ;; source-info.
+ (parent nil :type (or source-info null)))
;;; Given a pathname, return a SOURCE-INFO structure.
(defun make-file-source-info (file external-format)
- (let ((file-info (make-file-info :name (truename file)
- :untruename (merge-pathnames file)
- :external-format external-format
- :write-date (file-write-date file))))
-
- (make-source-info :file-info file-info)))
+ (make-source-info
+ :file-info (make-file-info :name (truename file)
+ :untruename (merge-pathnames file)
+ :external-format external-format
+ :write-date (file-write-date file))))
;;; Return a SOURCE-INFO to describe the incremental compilation of FORM.
-(defun make-lisp-source-info (form)
- (make-source-info :start-time (get-universal-time)
- :file-info (make-file-info :name :lisp
- :forms (vector form)
- :positions '#(0))))
-
-;;; Return a SOURCE-INFO which will read from STREAM.
-(defun make-stream-source-info (stream)
- (let ((file-info (make-file-info :name :stream)))
- (make-source-info :file-info file-info
- :stream stream)))
+(defun make-lisp-source-info (form &key parent)
+ (make-source-info
+ :file-info (make-file-info :name :lisp
+ :forms (vector form)
+ :positions '#(0))
+ :parent parent))
+
+;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO
+;;; with no parent (e.g., from a REPL evaluation) or until we reach a
+;;; SOURCE-INFO whose FILE-INFO denotes a file.
+(defun get-toplevelish-file-info (&optional (source-info *source-info*))
+ (if source-info
+ (do* ((sinfo source-info (source-info-parent sinfo))
+ (finfo (source-info-file-info sinfo)
+ (source-info-file-info sinfo)))
+ ((or (not (source-info-p (source-info-parent sinfo)))
+ (pathnamep (file-info-name finfo)))
+ finfo))))
;;; Return a form read from STREAM; or for EOF use the trick,
;;; popularized by Kent Pitman, of returning STREAM itself. If an
(setf (source-info-stream info) nil)
(values))
+;;; Loop over FORMS retrieved from INFO. Used by COMPILE-FILE and
+;;; LOAD when loading from a FILE-STREAM associated with a source
+;;; file.
+(defmacro do-forms-from-info (((form &rest keys) info)
+ &body body)
+ (aver (symbolp form))
+ (once-only ((info info))
+ `(let ((*source-info* ,info))
+ (loop (destructuring-bind (,form &key ,@keys &allow-other-keys)
+ (let* ((file-info (source-info-file-info ,info))
+ (stream (get-source-stream ,info))
+ (pos (file-position stream))
+ (form (read-for-compile-file stream pos)))
+ (if (eq form stream) ; i.e., if EOF
+ (return)
+ (let* ((forms (file-info-forms file-info))
+ (current-idx (+ (fill-pointer forms)
+ (file-info-source-root
+ file-info))))
+ (vector-push-extend form forms)
+ (vector-push-extend pos (file-info-positions
+ file-info))
+ (list form :current-index current-idx))))
+ ,@body)))))
+
;;; Read and compile the source file.
(defun sub-sub-compile-file (info)
- (let* ((file-info (source-info-file-info info))
- (stream (get-source-stream info)))
- (loop
- (let* ((pos (file-position stream))
- (form (read-for-compile-file stream pos)))
- (if (eq form stream) ; i.e., if EOF
- (return)
- (let* ((forms (file-info-forms file-info))
- (current-idx (+ (fill-pointer forms)
- (file-info-source-root file-info))))
- (vector-push-extend form forms)
- (vector-push-extend pos (file-info-positions file-info))
- (find-source-paths form current-idx)
- (process-toplevel-form form
- `(original-source-start 0 ,current-idx)
- nil)))))))
+ (do-forms-from-info ((form current-index) info)
+ (find-source-paths form current-index)
+ (process-toplevel-form
+ form `(original-source-start 0 ,current-index) nil)))
;;; Return the INDEX'th source form read from INFO and the position
;;; where it was read.
(*disabled-package-locks* *disabled-package-locks*)
(*lexenv* (make-null-lexenv))
(*block-compile* *block-compile-arg*)
- (*source-info* info)
(*toplevel-lambdas* ())
(*fun-names-in-this-file* ())
(*allow-instrumenting* nil)
;; on me (e.g. by using me as *CURRENT-COMPONENT*, or by pushing
;; LAMBDAs onto my NEW-FUNCTIONALS, as in sbcl-0.pre7.115).
(info :no-ir2-yet :type (or ir2-component (member :no-ir2-yet :dead)))
- ;; the SOURCE-INFO structure describing where this component was
- ;; compiled from
- (source-info *source-info* :type source-info)
;; count of the number of inline expansions we have done while
;; compiling this component, to detect infinite or exponential
;; blowups
(last-location-retrieved nil :type (or null sb!di:code-location))
(last-form-retrieved -1 :type fixnum))
+;;; OAOO note: this shares a lot of implementation with
+;;; SB-DEBUG::GET-FILE-TOPLEVEL-FORM. Perhaps these should be merged
+;;; somehow.
(defun get-toplevel-form (debug-source tlf-index)
- (let ((name (sb!di:debug-source-name debug-source)))
- (ecase (sb!di:debug-source-from debug-source)
- (:file
- (cond ((not (probe-file name))
- (warn "The source file ~S no longer seems to exist." name)
+ (cond
+ ((sb!di:debug-source-namestring debug-source)
+ (let ((namestring (sb!di:debug-source-namestring debug-source)))
+ (cond ((not (probe-file namestring))
+ (warn "The source file ~S no longer seems to exist." namestring)
nil)
(t
(let ((start-positions
debug-source)))
(char-offset
(aref start-positions local-tlf-index)))
- (with-open-file (f name)
+ (with-open-file (f namestring)
(cond ((= (sb!di:debug-source-created debug-source)
- (file-write-date name))
+ (file-write-date namestring))
(file-position f char-offset))
(t
(warn "Source file ~S has been modified; ~@
using form offset instead of ~
file index."
- name)
+ namestring)
(let ((*read-suppress* t))
(dotimes (i local-tlf-index) (read f)))))
(let ((*readtable* (copy-readtable)))
(declare (ignore rest sub-char))
(let ((token (read stream t nil t)))
(format nil "#.~S" token))))
- (read f))
- ))))))))
- (:lisp
- (aref name tlf-index)))))
+ (read f)))))))))))
+ ((sb!di:debug-source-form debug-source)
+ (sb!di:debug-source-form debug-source))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form."))))
(defun cache-valid (loc cache)
(and cache
;; need *BACKEND-INFO-ENVIRONMENT*.
(*info-environment* *info-environment*)
(form (get-lambda-to-compile definition))
- (*source-info* (make-lisp-source-info form))
+ (*source-info* (make-lisp-source-info form :parent *source-info*))
(*toplevel-lambdas* ())
(*block-compile* nil)
(*allow-instrumenting* nil)
;;; 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.18.9"
+"1.0.18.10"
projects / sbcl.git / commitdiff