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