From 5b6e3a315ec737c9414328ddfe3eb85a25f80abf Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 10 Aug 2000 10:55:35 +0000
Subject: [PATCH] Add support for define-symbol-macro.

---
 code/describe.lisp     |  6 +++++-
 code/eval.lisp         | 15 +++++++++------
 code/exports.lisp      |  5 +++--
 code/macros.lisp       | 30 +++++++++++++++++++++++++++++-
 compiler/globaldb.lisp |  7 +++++--
 compiler/ir1tran.lisp  | 31 ++++++++++++++++++-------------
 6 files changed, 69 insertions(+), 25 deletions(-)

diff --git a/code/describe.lisp b/code/describe.lisp
index 317f8a50c..d4b2cc16e 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.33 1998/06/05 02:53:54 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.34 2000/08/10 10:55:22 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -386,6 +386,7 @@
 		(:special "special variable")
 		(:constant "constant")
 		(:global "undefined variable")
+		(:macro "symbol macro")
 		(:alien nil))))
     (cond
      ((eq kind :alien)
@@ -396,6 +397,9 @@
 		 (alien::heap-alien-info-type info)))
 	(format t "~@<It's current value is ~3I~:_~S.~:>"
 		(eval x))))
+     ((eq kind :macro)
+      (let ((expansion (info variable macro-expansion x)))
+	(format t "~&It is a ~A with expansion: ~S." wot expansion)))
      ((boundp x)
       (let ((value (symbol-value x)))
 	(format t "~&It is a ~A; its value is ~S." wot value)
diff --git a/code/eval.lisp b/code/eval.lisp
index 99bc401b4..553daf452 100644
--- a/code/eval.lisp
+++ b/code/eval.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/eval.lisp,v 1.30 1999/03/04 12:32:45 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.31 2000/08/10 10:55:23 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -167,7 +167,7 @@
 	  (values (info variable constant-value exp)))
 	 ((:special :global)
 	  (symbol-value exp))
-	 (:alien
+	 ((:alien :macro)
 	  (eval:internal-eval original-exp))))
       (list
        (let ((name (first exp))
@@ -402,10 +402,13 @@
 	((symbolp form)
 	 (let* ((venv (when env (c::lexenv-variables env)))
 		(local-def (cdr (assoc form venv))))
-	   (if (and (consp local-def)
-		    (eq (car local-def) 'macro))
-	       (values (cdr local-def) t)
-	       (values form nil))))
+	   (cond ((and (consp local-def)
+		       (eq (car local-def) 'macro))
+		  (values (cdr local-def) t))
+		 ((eq (info variable kind form) :macro)
+		  (values (info variable macro-expansion form) t))
+		 (t
+		  (values form nil)))))
 	(t
 	 (values form nil))))
 
diff --git a/code/exports.lisp b/code/exports.lisp
index 819134361..8f4fd22e3 100644
--- a/code/exports.lisp
+++ b/code/exports.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/exports.lisp,v 1.172 2000/08/08 13:41:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.173 2000/08/10 10:55:23 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -370,7 +370,8 @@
              "COUNT-IF-NOT" "CTYPECASE" "DEBUG" "DECF" "DECLAIM"
              "DECLARATION" "DECLARE" "DECODE-FLOAT" "DECODE-UNIVERSAL-TIME"
              "DEFCONSTANT" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION"
-             "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPACKAGE"
+             "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFINE-SYMBOL-MACRO"
+	     "DEFMACRO" "DEFPACKAGE"
              "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR"
              "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF"
              "DELETE-IF-NOT" "DELETE-PACKAGE"
diff --git a/code/macros.lisp b/code/macros.lisp
index e9cfc3a85..309bdfc81 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.62 2000/07/06 18:36:38 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.63 2000/08/10 10:55:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -144,6 +144,34 @@
   name)
 
 
+
+;;;; DEFINE-SYMBOL-MACRO
+
+;;; define-symbol-macro  --  Public
+;;;
+(defmacro define-symbol-macro (name expansion)
+  `(eval-when (compile load eval)
+     (%define-symbol-macro ',name ',expansion)))
+;;;
+(defun %define-symbol-macro (name expansion)
+  (unless (symbolp name)
+    (error 'simple-type-error :datum name :expected-type 'symbol
+	   :format-control "Symbol macro name is not a symbol: ~S."
+	   :format-arguments (list name)))
+  (ecase (info variable kind name)
+    ((:macro :global nil)
+     (setf (info variable kind name) :macro)
+     (setf (info variable macro-expansion name) expansion))
+    (:special
+     (error 'simple-program-error
+	    :format-control "Symbol macro name already declared special: ~S."
+	    :format-arguments (list name)))
+    (:constant
+     (error 'simple-program-error
+	    :format-control "Symbol macro name already declared constant: ~S."
+	    :format-arguments (list name))))
+  name)
+    
 
 ;;; DEFTYPE is a lot like DEFMACRO.
 
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index 60a569a9c..f4f1bfa2f 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.38 2000/07/07 09:33:01 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.39 2000/08/10 10:55:35 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1070,7 +1070,8 @@
 (define-info-class variable)
 
 ;;; The kind of variable-like thing described.
-(define-info-type variable kind (member :special :constant :global :alien)
+(define-info-type variable kind (member :special :constant :global :alien
+					:macro)
   (if (or (eq (symbol-package name) (symbol-package :end))
 	  (member name '(t nil)))
       :constant
@@ -1091,6 +1092,8 @@
 
 (define-info-type variable alien-info (or heap-alien-info null) nil)
 
+(define-info-type variable macro-expansion t nil)
+
 (define-info-type variable documentation (or string null) nil)
 
 (define-info-class type)
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index d5bebda93..719d82e94 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.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/ir1tran.lisp,v 1.117 2000/07/13 17:30:11 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.118 2000/08/10 10:55:35 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -241,7 +241,7 @@
 ;;; is unknown, then we emit a warning.
 ;;;
 (defun find-free-variable (name)
-  (declare (values (or leaf heap-alien-info)))
+  (declare (values (or leaf cons heap-alien-info)))
   (unless (symbolp name)
     (compiler-error "Variable name is not a symbol: ~S." name))
   (or (gethash name *free-variables*)
@@ -252,17 +252,22 @@
 	  (note-undefined-reference name :variable))
 
 	(setf (gethash name *free-variables*)
-	      (if (eq kind :alien)
-		  (info variable alien-info name)
-		  (multiple-value-bind
-		      (val valp)
-		      (info variable constant-value name)
-		    (if (and (eq kind :constant) valp)
-			(make-constant :value val  :name name
-				       :type (ctype-of val)
-				       :where-from where-from)
-			(make-global-var :kind kind  :name name  :type type
-					 :where-from where-from))))))))
+	      (cond ((eq kind :alien)
+		     (info variable alien-info name))
+		    ((eq kind :macro)
+		     (let ((expansion (info variable macro-expansion name))
+			   (type (type-specifier (info variable type name))))
+		       `(MACRO . (the ,type ,expansion))))
+		    (t
+		     (multiple-value-bind
+			   (val valp)
+			 (info variable constant-value name)
+		       (if (and (eq kind :constant) valp)
+			   (make-constant :value val  :name name
+					  :type (ctype-of val)
+					  :where-from where-from)
+			   (make-global-var :kind kind :name name :type type
+					    :where-from where-from)))))))))
 
 
 
-- 
GitLab