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!IMPL")
  13
  14 (let ()
  15   (defmacro sb!xc:defmacro (name lambda-list &body body)
  16     (unless (symbolp name)
  17       (error "The macro name ~S is not a symbol." name))
  18     ;; When we are building the cross-compiler, we could be in a host
  19     ;; lisp which implements CL macros (e.g. CL:AND) as special
  20     ;; operators (while still providing a macroexpansion for
  21     ;; compliance): therefore can't use the host's SPECIAL-OPERATOR-P
  22     ;; as a discriminator, but that's OK because the set of forms the
  23     ;; cross-compiler compiles is tightly controlled.  -- CSR,
  24     ;; 2003-04-20
  25     #-sb-xc-host
  26     (when (special-operator-p name)
  27       (error "The special operator ~S can't be redefined as a macro."
  28              name))
  29     ;; The name of the lambda is (MACRO-FUNCTION name)
  30     ;; which does not conflict with any legal function name.
  31     (let ((def (make-macro-lambda (sb!c::debug-name 'macro-function name)
  32                                   lambda-list body 'defmacro name)))
  33       `(progn
  34          ;; %COMPILER-DEFMACRO just performs a check for duplicate definitions
  35          ;; within a file.
  36          (eval-when (:compile-toplevel)
  37            (sb!c::%compiler-defmacro :macro-function ',name t))
  38          (eval-when (:compile-toplevel :load-toplevel :execute)
  39            (sb!c::%defmacro ',name ,def (sb!c:source-location)))))))
  40
  41 (defun sb!c::%defmacro (name definition source-location)
  42   (declare (ignorable source-location)) ; xc-host doesn't use
  43             ;; old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO
  44             ;; should deal with clearing old compiler information for
  45             ;; the functional value."
  46   (let ((kind (info :function :kind name)))
  47               ;; Check for special form before package locks.
  48     (when (eq :special-form kind)
  49       (error "The special operator ~S can't be redefined as a macro."
  50              name))
  51     (with-single-package-locked-error (:symbol name "defining ~S as a macro")
  52       (when (eq :function kind)
  53         (style-warn
  54          "~S is being redefined as a macro when it was previously ~(~A~) to be a function."
  55          name (info :function :where-from name))
  56         (undefine-fun-name name))
  57       (clear-info :function :where-from name)
  58       #-sb-xc-host
  59       (when (fboundp name)
  60                   ;; Someday we could check for macro arguments
  61                   ;; being incompatibly redefined. Doing this right
  62                   ;; will involve finding the old macro lambda-list
  63                   ;; and comparing it with the new one.
  64         (warn 'redefinition-with-defmacro :name name
  65               :new-function definition :new-location source-location))
  66       (setf (sb!xc:macro-function name) definition)))
  67   name)
  68
  69 #+sb-xc-host
  70 (let ((real-expander (macro-function 'sb!xc:defmacro)))
  71   ;; Inform the cross-compiler how to expand SB!XC:DEFMACRO (= DEFMACRO).
  72   (setf (sb!xc:macro-function 'sb!xc:defmacro)
  73         (lambda (form env)
  74           (declare (ignore env))
  75           ;; Since SB!KERNEL:LEXENV isn't compatible with the host,
  76           ;; just pass NIL. The expansion correctly captures a non-null
  77           ;; environment, but the expander doesn't need it.
  78           (funcall real-expander form nil)))
  79   ;; Building the cross-compiler should skip the compile-time-too
  80   ;; processing SB!XC:DEFMACRO.
  81   (setf (macro-function 'sb!xc:defmacro)
  82         (lambda (form env) `(let () ,(funcall real-expander form env)))))