src/code/defmacro.lisp

   1 ;;;; DEFMACRO machinery
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-C")
  13
  14 (defun macro-function (symbol &optional env)
  15   "If SYMBOL names a macro in ENV, returns the expansion function,
  16 else returns NIL. If ENV is unspecified or NIL, use the global environment
  17 only."
  18   ;; local function definitions (ordinary) can shadow a global macro
  19   (typecase env
  20     #+(and sb-fasteval (not sb-xc-host))
  21     (sb-interpreter:basic-env
  22      (multiple-value-bind (kind def)
  23          (sb-interpreter:find-lexical-fun env symbol)
  24        (when def
  25          (return-from macro-function (when (eq kind :macro) def)))))
  26     (lexenv
  27      (let ((def (cdr (assoc symbol (lexenv-funs env)))))
  28        (when def
  29          (return-from macro-function
  30            (when (typep def '(cons (eql macro))) (cdr def)))))))
  31   (values (info :function :macro-function symbol)))
  32
  33 (defvar *setf-macro-function-hook* nil
  34   "A list of functions that (SETF MACRO-FUNCTION) invokes before storing the new
  35    value. The functions take the macro name and the new value.")
  36
  37 (defun (setf macro-function) (function symbol &optional environment)
  38   (declare (symbol symbol) (type function function))
  39   (when environment
  40     ;; Note: Technically there could be an ENV optional argument to
  41     ;; SETF MACRO-FUNCTION, but since ANSI says that the consequences
  42     ;; of supplying a non-nil one are undefined, we don't allow it.
  43     ;; (Thus our implementation of this unspecified behavior is to
  44     ;; complain. Since the behavior is unspecified, this is
  45     ;; conforming.:-)
  46     (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
  47            symbol environment))
  48   (when (eq (info :function :kind symbol) :special-form)
  49     (error "~S names a special form." symbol))
  50   (when (boundp '*setf-macro-function-hook*) ; unbound during cold init
  51     (dolist (f *setf-macro-function-hook*)
  52       (funcall f symbol function)))
  53   (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S")
  54     (clear-info :function :type symbol)
  55     (setf (info :function :kind symbol) :macro)
  56     (setf (info :function :macro-function symbol) function)
  57     #-sb-xc-host (install-guard-function symbol `(:macro ,symbol)))
  58   function)
  59
  60 (let ()
  61   (defmacro sb-xc:defmacro (name lambda-list &body body)
  62     (check-designator name 'defmacro)
  63     ;; When we are building the cross-compiler, we could be in a host
  64     ;; lisp which implements CL macros (e.g. CL:AND) as special
  65     ;; operators (while still providing a macroexpansion for
  66     ;; compliance): therefore can't use the host's SPECIAL-OPERATOR-P
  67     ;; as a discriminator, but that's OK because the set of forms the
  68     ;; cross-compiler compiles is tightly controlled.  -- CSR,
  69     ;; 2003-04-20
  70     #-sb-xc-host
  71     (when (special-operator-p name)
  72       (error "The special operator ~S can't be redefined as a macro."
  73              name))
  74     ;; The name of the lambda is (MACRO-FUNCTION name)
  75     ;; which does not conflict with any legal function name.
  76     (let ((def (make-macro-lambda (debug-name 'macro-function name)
  77                                   lambda-list body 'defmacro name)))
  78       `(progn
  79          ;; %COMPILER-DEFMACRO just performs a check for duplicate definitions
  80          ;; within a file.
  81          (eval-when (:compile-toplevel)
  82            (%compiler-defmacro :macro-function ',name))
  83          (eval-when (:compile-toplevel :load-toplevel :execute)
  84            (%defmacro ',name ,def (source-location)))))))
  85
  86 ;;; Detect duplicate definitions within a file. However, no package
  87 ;;; lock check is necessary - it's handled elsewhere.
  88 ;;;
  89 ;;; Additionally, this is a STYLE-WARNING, not a WARNING, because there is
  90 ;;; meaningful behavior that can be ascribed to some redefinitions, e.g.
  91 ;;;  (defmacro foo () first-definition)
  92 ;;;  (defun f () (use-it (foo )))
  93 ;;;  (defmacro foo () other-definition)
  94 ;;; will use the first definition when compiling F, but make the second available
  95 ;;; in the loaded fasl. In this usage it would have made sense to wrap the
  96 ;;; respective definitions with EVAL-WHEN for different situations,
  97 ;;; but as long as the compile-time behavior is deterministic, it's just bad style
  98 ;;; and not flat-out wrong, though there is indeed some waste in the fasl.
  99 ;;;
 100 ;;; KIND is the globaldb KIND of this NAME
 101 (defun %compiler-defmacro (kind name)
 102   (let ((name-key `(,kind ,name)))
 103     (when (boundp '*lexenv*)
 104       ;; a slight OAOO issue here wrt %COMPILER-DEFUN
 105       (if (member name-key (fun-names-in-this-file *compilation*) :test #'equal)
 106           (compiler-style-warn 'same-file-redefinition-warning :name name)
 107           (push name-key (fun-names-in-this-file *compilation*))))))
 108
 109 (defun %defmacro (name definition source-location)
 110   (declare (ignorable source-location)) ; xc-host doesn't use
 111             ;; old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO
 112             ;; should deal with clearing old compiler information for
 113             ;; the functional value."
 114   (let ((kind (info :function :kind name)))
 115               ;; Check for special form before package locks.
 116     (when (eq :special-form kind)
 117       (error "The special operator ~S can't be redefined as a macro."
 118              name))
 119     (with-single-package-locked-error (:symbol name "defining ~S as a macro")
 120       (when (eq :function kind)
 121         (style-warn
 122          "~S is being redefined as a macro when it was previously ~(~A~) to be a function."
 123          name (info :function :where-from name))
 124         (undefine-fun-name name))
 125       (clear-info :function :where-from name)
 126       #-sb-xc-host
 127       (when (fboundp name)
 128                   ;; Someday we could check for macro arguments
 129                   ;; being incompatibly redefined. Doing this right
 130                   ;; will involve finding the old macro lambda-list
 131                   ;; and comparing it with the new one.
 132         (warn 'redefinition-with-defmacro :name name
 133               :new-function definition :new-location source-location))
 134       (setf (macro-function name) definition)))
 135   name)