From f598476946491030dce54042c61146d666e2a542 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 4 Apr 1992 01:09:25 +0000
Subject: [PATCH] Added COMPILER-MACRO-FUNCTION, COMPILER-MACROEXPAND, and
 COMPILER- MACROEXPAND-1.  Fixed things that invoke *MACROEXPAND-HOOK* to
 coerce it to a function before calling it as per X3J13 cleanup
 FUNCTION-TYPE:X3J13- MARCH-88 by introducing KERNEL:INVOKE-MACROEXPAND-HOOK,
 which does that and then funcalls it.  Also, fixed MACRO-FUNCTION to take an
 environment argument as per X3J13 cleanup MACRO-FUNCTION-ENVIRONMENT:YES.

---
 code/eval.lisp | 166 ++++++++++++++++++++++++++++++++++---------------
 1 file changed, 116 insertions(+), 50 deletions(-)

diff --git a/code/eval.lisp b/code/eval.lisp
index 694e5e34e..5b2d93cb0 100644
--- a/code/eval.lisp
+++ b/code/eval.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.15 1992/03/26 16:40:54 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.16 1992/04/04 01:09:25 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,6 +17,8 @@
 	  do do* dotimes dolist progv and or cond if the
 	  macro-function special-form-p *macroexpand-hook*
 	  macroexpand-1 macroexpand block return-from
+	  compiler-macroexpand compiler-macroexpand-1
+	  compiler-macro-function
 	  return function setq psetq apply funcall
 	  compiler-let progv flet labels macrolet
 	  mapcar maplist mapc mapl mapcan mapcon
@@ -50,6 +52,9 @@
 (in-package "EXTENSIONS")
 (export '(*top-level-auto-declare*))
 
+(in-package "KERNEL")
+(export '(invoke-macroexpand-hook))
+
 (in-package "LISP")
 
 
@@ -257,6 +262,54 @@
   whenever a runtime expansion is needed.  Initially this is set to
   FUNCALL.")
 
+;;; INVOKE-MACROEXPAND-HOOK -- public.
+;;;
+;;; The X3J13 cleanup FUNCTION-TYPE:X3J13-MARCH-88 specifies that:
+;;; 
+;;; "7. Clarify that the value of *MACROEXPAND-HOOK* is first coerced to a
+;;;     function before being called as the expansion interface hook by
+;;;     MACROEXPAND-1."
+;;;
+;;; This is a handy utility function that does just such a coercion.  It also
+;;; stores the result back in *macroexpand-hook* so we don't have to coerce
+;;; it again.
+;;; 
+(defun invoke-macroexpand-hook (fun form env)
+  "Invoke *MACROEXPAND-HOOK* on FUN, FORM, and ENV after coercing it to
+   a function."
+  (unless (functionp *macroexpand-hook*)
+    (setf *macroexpand-hook*
+	  (coerce *macroexpand-hook* 'function)))
+  (funcall *macroexpand-hook* fun form env))
+
+(defun macro-function (symbol &optional env)
+  "If SYMBOL names a macro in ENV, returns the expansion function,
+   else returns NIL.  If ENV is unspecified or NIL, use the global
+   environment only."
+  (declare (symbol symbol))
+  (let* ((fenv (when env (c::lexenv-functions env)))
+	 (local-def (cdr (assoc symbol fenv))))
+    (cond (local-def
+	   (if (and (consp local-def) (eq (car local-def) 'MACRO))
+	       (cdr local-def)
+	       nil))
+	  ((eq (info function kind symbol) :macro)
+	   (values (info function macro-function symbol)))
+	  (t
+	   nil))))
+
+(defun (setf macro-function) (function symbol)
+  (declare (symbol symbol) (type function function))
+
+  (when (eq (info function kind symbol) :special-form)
+    (error "~S names a special form." symbol))
+
+  (setf (info function kind symbol) :macro)
+  (setf (info function macro-function symbol) function)
+  (setf (symbol-function symbol)
+	#'(lambda (&rest args) (declare (ignore args))
+	    (error "Cannot funcall macro functions.")))
+  function)
 
 ;;; Macroexpand-1  --  Public
 ;;;
@@ -264,23 +317,14 @@
 ;;;
 (defun macroexpand-1 (form &optional env)
   "If form is a macro (or symbol macro), expands it once.  Returns two values,
-  the expanded form and a T-or-NIL flag indicating whether the form was, in
-  fact, a macro.  Env is the lexical environment to expand in, which defaults
-  to the null environment."
+   the expanded form and a T-or-NIL flag indicating whether the form was, in
+   fact, a macro.  Env is the lexical environment to expand in, which defaults
+   to the null environment."
   (cond ((and (consp form) (symbolp (car form)))
-	 (let* ((fenv (when env (c::lexenv-functions env)))
-		(local-def (cdr (assoc (car form) fenv))))
-	   (if local-def
-	       (if (and (consp local-def) (eq (car local-def) 'MACRO))
-		   (values (funcall *macroexpand-hook* (cdr local-def)
-				    form env)
-			   t)
-		   (values form nil))
-	       (let ((global-def (macro-function (car form))))
-		 (if global-def
-		     (values (funcall *macroexpand-hook* global-def form env)
-			     t)
-		     (values form nil))))))
+	 (let ((def (macro-function (car form))))
+	   (if def
+	       (values (invoke-macroexpand-hook def form env) t)
+	       (values form nil))))
 	((symbolp form)
 	 (let* ((venv (when env (c::lexenv-variables env)))
 		(local-def (cdr (assoc form venv))))
@@ -291,42 +335,64 @@
 	(t
 	 (values form nil))))
 
-
 (defun macroexpand (form &optional env)
-  "If Form is a macro call, then the form is expanded until the result is not
-  a macro.  Returns as multiple values, the form after any expansion has
-  been done and T if expansion was done, or NIL otherwise.  Env is the
-  lexical environment to expand in, which defaults to the null environment."
-  (prog (flag)
-    (multiple-value-setq (form flag) (macroexpand-1 form env))
-    (unless flag (return (values form nil)))
-    loop
-    (multiple-value-setq (form flag) (macroexpand-1 form env))
-    (if flag (go loop) (return (values form t)))))
-
-
-(defun macro-function (symbol)
-  "If the symbol globally names a macro, returns the expansion function,
-  else returns NIL."
-  (declare (symbol symbol))
-  (if (eq (info function kind symbol) :macro)
-      (info function macro-function symbol)
-      nil))
-
-
-(defun (setf macro-function) (function symbol)
-  (declare (symbol symbol) (type function function))
-
-  (when (eq (info function kind symbol) :special-form)
-    (error "~S names a special form." symbol))
-
-  (setf (info function kind symbol) :macro)
-  (setf (info function macro-function symbol) function)
-  (setf (symbol-function symbol)
-	#'(lambda (&rest args) (declare (ignore args))
-	    (error "Cannot funcall macro functions.")))
+  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
+   Returns the final resultant form, and T if it was expanded.  ENV is the
+   lexical environment to expand in, or NIL (the default) for the null
+   environment."
+  (labels ((frob (form expanded)
+	     (multiple-value-bind
+		 (new-form newly-expanded)
+		 (macroexpand-1 form env)
+	       (if newly-expanded
+		   (frob new-form t)
+		   (values new-form expanded)))))
+    (frob form nil)))
+
+(defun compiler-macro-function (name &optional env)
+  "If NAME names a compiler-macro, returns the expansion function,
+   else returns NIL.  Note: if the name is shadowed in ENV by a local
+   definition, or declared NOTINLINE, NIL is returned.  Can be
+   set with SETF."
+  (unless (or (and env (assoc name (c::lexenv-functions env) :test #'equal))
+	      (eq (or (and env
+			   (cdr (assoc name (c::lexenv-inlines env)
+				       :key #'c::leaf-name :test #'equal)))
+		      (info function inlinep name))
+		  :notinline))
+    (values (info function compiler-macro-function name))))
+
+(defun (setf compiler-macro-function) (function name)
+  (declare (type (or symbol list) name)
+	   (type (or function null) function))
+  (when (eq (info function kind name) :special-form)
+    (error "~S names a special form." name))
+  (setf (info function compiler-macro-function name) function)
   function)
 
+(defun compiler-macroexpand-1 (form &optional env)
+  "If FORM is a function call for which a compiler-macro has been defined,
+   invoke the expander function using *macroexpand-hook* and return the
+   results and T.  Otherwise, return the original form and NIL."
+  (let ((fun (and (consp form) (compiler-macro-function (car form) env))))
+    (if fun
+	(let ((result (invoke-macroexpand-hook fun form env)))
+	  (values result (not (eq result form))))
+	(values form nil))))
+
+(defun compiler-macroexpand (form &optional env)
+  "Repetitively call COMPILER-MACROEXPAND-1 until the form can no longer be
+   expanded.  ENV is the lexical environment to expand in, or NIL (the
+   default) for the null environment."
+  (labels ((frob (form expanded)
+	     (multiple-value-bind
+		 (new-form newly-expanded)
+		 (compiler-macroexpand-1 form env)
+	       (if newly-expanded
+		   (frob new-form t)
+		   (values new-form expanded)))))
+    (frob form env)))
+
 
 (defun constantp (object)
   "True of any Lisp object that has a constant value: types that eval to
-- 
GitLab