From f4f6325e34564593199574698de96ae446345b6e Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 6 Apr 2004 20:44:03 +0000
Subject: [PATCH] Add support for source location recording, from Helmut Eller
 on cmucl-imp:

    The patch below adds a somewhat general mechanism to the get the
    "current location".  So every macro that wants to record the
    source location, can insert a call to SOURCE-LOCATION in the
    generated code and safe the result in a appropriate place.
    SOURCE-LOCATION is a compiler-macro and returns a quoted struct
    with the source info.

    The patch adds the definition for SOURCE-LOCATION some
    modifications for the defclass, defgeneric and defmethod macros.
    Classes, generic functions and methods have already a "source"
    slot and the result of SOURCE-LOCATION is just stored into that
    slot.  (The source slot contains currently only the *loadpath*,
    which is is not very useful, if the fasl file is in a different
    directory than the source file.)
---
 bootfiles/18e/boot24.lisp | 43 +++++++++++++++++++++++++++++
 compiler/ir1util.lisp     | 58 ++++++++++++++++++++++++++++++++++++++-
 compiler/main.lisp        |  8 +++++-
 pcl/boot.lisp             | 26 ++++++++----------
 pcl/defclass.lisp         | 53 +++++++++++++++++++----------------
 pcl/defcombin.lisp        | 17 ++++++------
 pcl/std-class.lisp        |  3 +-
 7 files changed, 157 insertions(+), 51 deletions(-)
 create mode 100644 bootfiles/18e/boot24.lisp

diff --git a/bootfiles/18e/boot24.lisp b/bootfiles/18e/boot24.lisp
new file mode 100644
index 000000000..5cf89d145
--- /dev/null
+++ b/bootfiles/18e/boot24.lisp
@@ -0,0 +1,43 @@
+;;;
+;;; Bootstrap file for adding support for source location recording
+;;; from Helmut Eller.
+;;;
+
+(in-package "C")
+
+(setf lisp::*enable-package-locked-errors* nil)
+
+(defstruct (form-numbers)
+  ;; The tlf-number and form-number encoded in a fixnum.
+  (form-numbers (required-argument) :type fixnum))
+
+(defstruct (file-source-location
+	     (:include form-numbers)
+	     (:make-load-form-fun :just-dump-it-normally)
+	     (:pure t))
+  (pathname (required-argument) :type simple-string))
+
+(defstruct (stream-source-location
+	     (:include form-numbers)
+	     (:make-load-form-fun :just-dump-it-normally)
+	     (:pure t))
+  user-info)
+
+(defun encode-form-numbers (tlf-number form-number)
+  "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum."
+  (declare (type (unsigned-byte 14) tlf-number form-number))
+  (logior tlf-number (ash form-number 14)))
+
+(defun namestring-for-debug-source (file-info)
+  "Extract the namestring from FILE-INFO for the DEBUG-SOURCE.  
+Return FILE-INFO's untruename (e.g., target:foo) if it is absolute;
+otherwise the truename."
+  (let* ((untruename (file-info-untruename file-info))
+	 (dir (pathname-directory untruename)))
+    (namestring (if (and dir (eq (first dir) :absolute))
+		    untruename
+		    (file-info-name file-info)))))
+
+(defun source-location ()
+  "Return a source-location for the call site."
+  nil)
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index 82c800bd4..0f8753749 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.101 2004/03/24 13:27:43 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.102 2004/04/06 20:44:01 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -410,6 +410,62 @@
 	(values (node-source-form use) t)
 	(values nil nil))))
 
+
+;;; Utilities for source location recording.  SOURCE-LOCATION returns
+;;; a data structure describing the source location of the call site.
+;;; The structure includes form numbers and the filename, if we
+;;; compile a file, or the user supplied info, if we compile from a
+;;; stream.
+;;;
+;;; Some effort was made to keep the structures small.  We restrict
+;;; form numbers to two 14 bit integers and encode them in a single
+;;; fixnum.  Both FILE-SOURCE-LOCATION and STREAM-SOURCE-LOCATION
+;;; require 4 words (usually 16 bytes).
+
+(defstruct (form-numbers)
+  ;; The tlf-number and form-number encoded in a fixnum.
+  (form-numbers (required-argument) :type fixnum))
+
+(defstruct (file-source-location
+	     (:include form-numbers)
+	     (:make-load-form-fun :just-dump-it-normally)
+	     (:pure t))
+  (pathname (required-argument) :type simple-string))
+
+(defstruct (stream-source-location
+	     (:include form-numbers)
+	     (:make-load-form-fun :just-dump-it-normally)
+	     (:pure t))
+  user-info)
+
+(defun encode-form-numbers (tlf-number form-number)
+  "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum."
+  (declare (type (unsigned-byte 14) tlf-number form-number))
+  (logior tlf-number (ash form-number 14)))
+
+(defun decode-form-numbers (fixnum)
+  "Return the tlf-number and form-number from an encoded FIXNUM."
+  (values (ldb (byte 14 0) fixnum) 
+	  (ldb (byte 14 14) fixnum)))
+
+(defun source-location ()
+  "Return a source-location for the call site."
+  nil)
+
+(define-compiler-macro source-location ()
+  (let ((file-info (car (source-info-current-file *source-info*)))
+	(form-numbers (encode-form-numbers
+		       (source-path-tlf-number *current-path*)
+		       (source-path-form-number *current-path*))))
+      (etypecase (file-info-name file-info)
+	((member :stream)
+	 `(quote ,(make-stream-source-location :form-numbers form-numbers
+					       :user-info *user-source-info*)))
+	(pathname
+	 `(quote ,(make-file-source-location 
+		   :form-numbers form-numbers
+		   :pathname (namestring-for-debug-source file-info)))))))
+
 
 ;;; MAKE-LEXENV  --  Interface
 ;;;
diff --git a/compiler/main.lisp b/compiler/main.lisp
index d3fa014a4..61084ec84 100644
--- a/compiler/main.lisp
+++ b/compiler/main.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.139 2004/01/16 14:15:16 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.140 2004/04/06 20:44:01 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -131,6 +131,11 @@
 ;;;
 (defvar *source-info* nil)
 
+(defvar *user-source-info* nil
+  "The user supplied source-info for the current compilation.  
+This is the :source-info argument to COMPILE-FROM-STREAM and will be
+stored in the INFO slot of the DEBUG-SOURCE in code components and 
+in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")
 
 ;;; Maybe-Mumble  --  Internal
 ;;;
@@ -1505,6 +1510,7 @@
 	   (*lexical-environment* (make-null-environment))
 	   (*converting-for-interpreter* nil)
 	   (*source-info* info)
+	   (*user-source-info* d-s-info)
 	   (*compile-file-pathname* nil)
 	   (*compile-file-truename* nil)
 	   (*top-level-lambdas* ())
diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 72530d079..4cf83757b 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.71 2004/01/09 05:18:08 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.72 2004/04/06 20:44:02 rtoy Exp $")
 
 (in-package :pcl)
 
@@ -302,7 +302,9 @@ work during bootstrapping.
        ,(make-top-level-form
 	 `(defgeneric ,function-specifier)
 	 '(:load-toplevel :execute)
-	 `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))
+	 `(load-defgeneric ',function-specifier ',lambda-list 
+	   :definition-source (c::source-location)
+	   ,@initargs))
        ,@methods
        `,(function ,function-specifier))))
 
@@ -320,8 +322,6 @@ work during bootstrapping.
   (apply #'ensure-generic-function
 	 function-specifier
 	 :lambda-list lambda-list
-	 :definition-source `((defgeneric ,function-specifier)
-			      ,*load-pathname*)
 	 initargs))
 
 
@@ -512,7 +512,7 @@ work during bootstrapping.
     ',qualifiers
     ,specializers-form
     ',unspecialized-lambda-list
-    ,initargs-form
+    (list* :definition-source (c::source-location) ,initargs-form)
     ;;Paper over a bug in KCL by passing the cache-symbol
     ;;here in addition to in the list.
     ',pv-table-symbol
@@ -1335,12 +1335,7 @@ work during bootstrapping.
       (maybe-compile :function)))
   ;;
   (let ((method (apply #'add-named-method
-		       gf-name qualifiers specializers lambda-list
-		       :definition-source `((defmethod ,gf-name
-						,@qualifiers
-						,specializers)
-					    ,*load-pathname*)
-		       initargs)))
+		       gf-name qualifiers specializers lambda-list initargs)))
     ;;
     (record-inline-access-info method inline-access method-info)
     ;;
@@ -1753,7 +1748,8 @@ work during bootstrapping.
 #-loadable-pcl
 (defun ensure-generic-function-using-class
     (existing spec &rest keys
-     &key (lambda-list nil lambda-list-p) argument-precedence-order 
+     &key (lambda-list nil lambda-list-p) argument-precedence-order
+     definition-source
      &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
@@ -1769,10 +1765,10 @@ work during bootstrapping.
 	(t
 	 (pushnew spec *early-generic-functions* :test #'equal)
 	 (make-early-gf spec lambda-list lambda-list-p nil
-			argument-precedence-order))))
+			argument-precedence-order definition-source))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p function
-		      argument-precedence-order)
+		      argument-precedence-order source)
   (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
     (set-funcallable-instance-function 
      fin 
@@ -1787,7 +1783,7 @@ work during bootstrapping.
 			 has not been set.~@:>" fin)))))
     (setf (gdefinition spec) fin)
     (bootstrap-set-slot 'standard-generic-function fin 'name spec)
-    (bootstrap-set-slot 'standard-generic-function fin 'source *load-pathname*)
+    (bootstrap-set-slot 'standard-generic-function fin 'source source)
     (set-function-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index 66fc1046f..2232dd14b 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.29 2003/05/13 10:16:59 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.30 2004/04/06 20:44:03 rtoy Rel $")
 ;;;
 
 (in-package :pcl)
@@ -165,10 +165,12 @@
 				    ',metaclass
 				    ',supers
 				    (list ,@canonical-slots)
-				    (list ,@(apply #'append 
-						   (when defstruct-p
-						     '(:from-defclass-p t))
-						   other-initargs))))))))
+				    (list 
+				     :definition-source (c::source-location)
+				     ,@(apply #'append 
+					      (when defstruct-p
+						'(:from-defclass-p t))
+					      other-initargs))))))))
           (if defstruct-p
               (progn
                 (eval defclass-form) ; define the class now, so that
@@ -356,12 +358,15 @@
 	     (others (ecd-other-initargs definition)))
 	(loop (when (null others) (return nil))
 	      (let ((initarg (pop others)))
-		(unless (eq initarg :direct-default-initargs)
-		 (error "~@<The defclass option ~S is not supported by ~
-                         the bootstrap object system.~@:>"
-			initarg)))
-	      (setq default-initargs
-		    (nconc default-initargs (reverse (pop others)))))))
+		(cond ((eq initarg :direct-default-initargs)
+		       (setq default-initargs
+			     (nconc default-initargs (reverse (pop others)))))
+		      (t
+		       (cerror "Discard it."
+			       "~@<The defclass option ~S is not supported by ~
+                                 the bootstrap object system.~@:>"
+			       initarg)
+		       (pop others)))))))
     (reverse default-initargs)))
 
 (defun bootstrap-slot-index (class-name slot-name)
@@ -425,16 +430,18 @@
 	canonical-options (copy-tree canonical-options))
   (when (eq metaclass 'standard-class)
     (inform-type-system-about-std-class name))
-  (let ((ecd
-	  (make-early-class-definition name
-				       *load-pathname*
-				       metaclass
-				       supers
-				       canonical-slots
-				       canonical-options))
-	(existing
-	  (find name *early-class-definitions* :key #'ecd-class-name)))
-    (setq *early-class-definitions*
-	  (cons ecd (remove existing *early-class-definitions*)))
-    ecd))
+  (let ((source (getf canonical-options :definition-source)))
+    (remf canonical-options :definition-source)
+    (let ((ecd
+	   (make-early-class-definition name
+					source
+					metaclass
+					supers
+					canonical-slots
+					canonical-options))
+	  (existing
+	   (find name *early-class-definitions* :key #'ecd-class-name)))
+      (setq *early-class-definitions*
+	    (cons ecd (remove existing *early-class-definitions*)))
+      ecd)))
 
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
index 747af7fe3..1a58fc977 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.25 2003/08/25 20:10:41 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.26 2004/04/06 20:44:03 rtoy Exp $")
 
 (in-package :pcl)
 
@@ -117,7 +117,8 @@
     (make-top-level-form `(define-method-combination ,type)
 			 '(:load-toplevel :execute)
       `(load-short-defcombin
-	 ',type ',operator ',identity-with-one-arg ',documentation))))
+	 ',type ',operator ',identity-with-one-arg 
+	',documentation (c::source-location)))))
 
 (defun set-random-documentation (type doc-type doc)
   (let ((pair (assoc doc-type
@@ -127,7 +128,7 @@
 	(push (cons doc-type doc)
 	      (info random-documentation stuff type)))))
 
-(defun load-short-defcombin (type operator ioa doc)
+(defun load-short-defcombin (type operator ioa doc source)
   (let* ((specializers
 	   (list (find-class 'generic-function)
 		 (intern-eql-specializer type)
@@ -148,8 +149,7 @@
 			   (make-short-method-combination
 			       type options operator ioa new-method doc))
 			 args))
-	    :definition-source `((define-method-combination ,type)
-				 ,*load-pathname*)))
+	    :definition-source source))
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
@@ -252,9 +252,9 @@
       (make-top-level-form `(define-method-combination ,type)
 			   '(:load-toplevel :execute)
 	`(load-long-defcombin ',type ',documentation #',function
-			      ',arguments-option)))))
+			      ',arguments-option (c::source-location))))))
 
-(defun load-long-defcombin (type doc function args-lambda-list)
+(defun load-long-defcombin (type doc function args-lambda-list source)
   (let* ((specializers
 	   (list (find-class 'generic-function)
 		 (intern-eql-specializer type)
@@ -278,8 +278,7 @@
 					   :args-lambda-list args-lambda-list
 					   :documentation doc))
 			  args))
-	 :definition-source `((define-method-combination ,type)
-			      ,*load-pathname*))))
+	 :definition-source source)))
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 7bb08c55f..62b139ca3 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.71 2003/10/29 12:14:35 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.72 2004/04/06 20:44:03 rtoy Exp $")
 
 (in-package :pcl)
 
@@ -352,7 +352,6 @@
   (apply #'ensure-class name :metaclass metaclass-name
 	 :direct-superclasses supers
 	 :direct-slots slots
-	 :definition-source `((defclass ,name) ,*load-pathname*)
 	 other))
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
-- 
GitLab