From 35ff77d30acfbf6b8632bb0dd38cf8a7d3060897 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 6 May 2004 14:36:47 +0000
Subject: [PATCH] Merge in the 19a changes containing Helmut Eller's
 implementation for source location for defvar and friends.

---
 bootfiles/18e/boot25.lisp | 77 +++++++++++++++++++++++++++++++++++++++
 code/describe.lisp        | 10 ++++-
 code/macros.lisp          | 14 +++++--
 compiler/globaldb.lisp    |  7 +++-
 4 files changed, 101 insertions(+), 7 deletions(-)
 create mode 100644 bootfiles/18e/boot25.lisp

diff --git a/bootfiles/18e/boot25.lisp b/bootfiles/18e/boot25.lisp
new file mode 100644
index 000000000..b3d64eb42
--- /dev/null
+++ b/bootfiles/18e/boot25.lisp
@@ -0,0 +1,77 @@
+
+(setf lisp::*enable-package-locked-errors* nil)
+(in-package :c)
+
+;;; Used to record the source-location of definitions.
+;;;
+(define-info-class source-location)
+(define-info-type source-location defvar (or form-numbers null) nil)
+
+
+(in-package :lisp)
+;;; DEFCONSTANT  --  Public
+;;;
+(defmacro defconstant (var val &optional doc)
+  "For defining global constants at top level.  The DEFCONSTANT says that the
+  value is constant and may be compiled into code.  If the variable already has
+  a value, and this is not equal to the init, an error is signalled.  The third
+  argument is an optional documentation string for the variable."
+  `(progn
+     (eval-when (:compile-toplevel)
+       (c::do-defconstant-compile-time ',var ,val ',doc))
+     (eval-when (:load-toplevel :execute)
+       (c::%%defconstant ',var ,val ',doc (c::source-location)))))
+
+(defun set-defvar-source-location (name source-location)
+  (setf (info :source-location :defvar name) source-location))
+
+;;; %Defconstant, %%Defconstant  --  Internal
+;;;
+;;;    Like the other %mumbles except that we currently actually do something
+;;; interesting at load time, namely checking if the constant is being
+;;; redefined.
+;;;
+(defun c::%defconstant (name value doc)
+  (c::%%defconstant name value doc nil))
+;;;
+(defun c::%%defconstant (name value doc source-location)
+  (when doc
+    (setf (documentation name 'variable) doc))
+  (when (boundp name)
+    (unless (equalp (symbol-value name) value)
+      (cerror "Go ahead and change the value."
+	      "Constant ~S being redefined." name)))
+  (setf (symbol-value name) value)
+  (setf (info variable kind name) :constant)
+  (clear-info variable constant-value name)
+  (set-defvar-source-location name source-location)
+  name)
+
+
+(defmacro defvar (var &optional (val nil valp) (doc nil docp))
+  "For defining global variables at top level.  Declares the variable
+  SPECIAL and, optionally, initializes it.  If the variable already has a
+  value, the old value is not clobbered.  The third argument is an optional
+  documentation string for the variable."
+  `(progn
+    (declaim (special ,var))
+     ,@(when valp
+	 `((unless (boundp ',var)
+	     (setq ,var ,val))))
+    ,@(when docp
+	`((setf (documentation ',var 'variable) ',doc)))
+    (set-defvar-source-location ',var (c::source-location))
+    ',var))
+
+(defmacro defparameter (var val &optional (doc nil docp))
+  "Defines a parameter that is not normally changed by the program,
+  but that may be changed without causing an error.  Declares the
+  variable special and sets its value to VAL.  The third argument is
+  an optional documentation string for the parameter."
+  `(progn
+    (declaim (special ,var))
+    (setq ,var ,val)
+    ,@(when docp
+	`((setf (documentation ',var 'variable) ',doc)))
+    (set-defvar-source-location ',var (c::source-location))
+    ',var))
diff --git a/code/describe.lisp b/code/describe.lisp
index b2970c569..d9cb926af 100644
--- a/code/describe.lisp
+++ b/code/describe.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/code/describe.lisp,v 1.42 2003/03/26 17:15:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.43 2004/05/06 14:36:47 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -448,4 +448,10 @@
       ((null plist) ())
     (unless (member (car plist) *implementation-properties*)
       (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
-      (describe (cadr plist)))))
+      (describe (cadr plist))))
+
+  ;; Describe where it was defined.
+  (let ((locn (info :source-location :defvar x)))
+    (when locn
+      (format t "~&It is defined in:~&~A" (c::file-source-location-pathname locn)))))
+
diff --git a/code/macros.lisp b/code/macros.lisp
index 41e5a7c67..b2e7f0666 100644
--- a/code/macros.lisp
+++ b/code/macros.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/code/macros.lisp,v 1.98 2004/04/14 17:01:22 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.99 2004/05/06 14:36:47 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -387,7 +387,10 @@
      (eval-when (:compile-toplevel)
        (c::do-defconstant-compile-time ',var ,val ',doc))
      (eval-when (:load-toplevel :execute)
-       (c::%%defconstant ',var ,val ',doc))))
+       (c::%%defconstant ',var ,val ',doc (c::source-location)))))
+
+(defun set-defvar-source-location (name source-location)
+  (setf (info :source-location :defvar name) source-location))
 
 ;;; %Defconstant, %%Defconstant  --  Internal
 ;;;
@@ -396,9 +399,9 @@
 ;;; redefined.
 ;;;
 (defun c::%defconstant (name value doc)
-  (c::%%defconstant name value doc))
+  (c::%%defconstant name value doc nil))
 ;;;
-(defun c::%%defconstant (name value doc)
+(defun c::%%defconstant (name value doc source-location)
   (when doc
     (setf (documentation name 'variable) doc))
   (when (boundp name)
@@ -408,6 +411,7 @@
   (setf (symbol-value name) value)
   (setf (info variable kind name) :constant)
   (clear-info variable constant-value name)
+  (set-defvar-source-location name source-location)
   name)
 
 
@@ -423,6 +427,7 @@
 	     (setq ,var ,val))))
     ,@(when docp
 	`((setf (documentation ',var 'variable) ',doc)))
+    (set-defvar-source-location ',var (c::source-location))
     ',var))
 
 (defmacro defparameter (var val &optional (doc nil docp))
@@ -435,6 +440,7 @@
     (setq ,var ,val)
     ,@(when docp
 	`((setf (documentation ',var 'variable) ',doc)))
+    (set-defvar-source-location ',var (c::source-location))
     ',var))
 
 
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index f90add329..92c211405 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.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/globaldb.lisp,v 1.46 2003/10/05 11:41:21 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.47 2004/05/06 14:36:47 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1165,6 +1165,11 @@
 (define-info-class random-documentation)
 (define-info-type random-documentation stuff list ())
 
+;;; Used to record the source-location of definitions.
+;;;
+(define-info-class source-location)
+(define-info-type source-location defvar (or form-numbers null) nil)
+		   
 ); defun other-info-init
 
 (declaim (freeze-type info-env))
-- 
GitLab