(defun sb!xc:macro-function (symbol &optional env)
#!+sb-doc
"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."
+else returns NIL. If ENV is unspecified or NIL, use the global environment
+only."
(declare (symbol symbol))
- (let* ((fenv (when env (sb!c::lexenv-funs env)))
+ (let* ((fenv (when env (lexenv-funs env)))
(local-def (cdr (assoc symbol fenv))))
(cond (local-def
(if (and (consp local-def) (eq (car local-def) 'macro))
(error 'undefined-function :name symbol)))
function)
+(defun fun-locally-defined-p (name env)
+ (and env
+ (let ((fun (cdr (assoc name (lexenv-funs env) :test #'equal))))
+ (and fun (not (global-var-p fun))))))
+
(defun sb!xc:compiler-macro-function (name &optional env)
#!+sb-doc
"If NAME names a compiler-macro in ENV, return the expansion function, else
- return NIL. Can be set with SETF when ENV is NIL."
- (declare (ignore env))
+return NIL. Can be set with SETF when ENV is NIL."
(legal-fun-name-or-type-error name)
- ;; Note: CMU CL used to return NIL here when a NOTINLINE declaration
- ;; was in force. That's fairly logical, given the specified effect
- ;; of NOTINLINE declarations on compiler-macro expansion. However,
- ;; (1) it doesn't seem to be consistent with the ANSI spec for
- ;; COMPILER-MACRO-FUNCTION, and (2) it would give surprising
- ;; behavior for (SETF (COMPILER-MACRO-FUNCTION FOO) ...) in the
- ;; presence of a (PROCLAIM '(NOTINLINE FOO)). So we don't do it.
- (values (info :function :compiler-macro-function name)))
+ ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
+ ;; not only creates a new local function or macro definition, but
+ ;; also shadows[2] the compiler macro.
+ (unless (fun-locally-defined-p name env)
+ ;; Note: CMU CL used to return NIL here when a NOTINLINE
+ ;; declaration was in force. That's fairly logical, given the
+ ;; specified effect of NOTINLINE declarations on compiler-macro
+ ;; expansion. However, (1) it doesn't seem to be consistent with
+ ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
+ ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
+ ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
+ ;; we don't do it.
+ (values (info :function :compiler-macro-function name))))
+
(defun (setf sb!xc:compiler-macro-function) (function name &optional env)
(declare (type (or symbol list) name)
(type (or function null) function))
(t
(reference-constant start next result form))))
(t
- (let ((opname (car form)))
- (cond ((or (symbolp opname) (leaf-p opname))
- (let ((lexical-def (if (leaf-p opname)
- opname
- (lexenv-find opname funs))))
- (typecase lexical-def
- (null
- (ir1-convert-global-functoid start next result
- form))
- (functional
- (ir1-convert-local-combination start next result
- form
- lexical-def))
- (global-var
- (ir1-convert-srctran start next result
- lexical-def form))
- (t
- (aver (and (consp lexical-def)
- (eq (car lexical-def) 'macro)))
- (ir1-convert start next result
- (careful-expand-macro
- (cdr lexical-def)
- form))))))
- ((or (atom opname) (not (eq (car opname) 'lambda)))
- (compiler-error "illegal function call"))
- (t
- ;; implicitly (LAMBDA ..) because the LAMBDA
- ;; expression is the CAR of an executed form
- (ir1-convert-combination start next result
- form
- (ir1-convert-lambda
- opname
- :debug-name (debug-name
- 'lambda-car
- opname))))))))))
+ (ir1-convert-functoid start next result form)))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
(ir1-convert start next result `(%heap-alien ',var)))))
(values))
-;;; Convert anything that looks like a special form, global function
-;;; or compiler-macro call.
-(defun ir1-convert-global-functoid (start next result form)
- (declare (type ctran start next) (type (or lvar null) result) (list form))
- (let* ((fun-name (first form))
- (translator (info :function :ir1-convert fun-name))
- (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*)))
+;;; Find a compiler-macro for a form, taking FUNCALL into account.
+(defun find-compiler-macro (opname form)
+ (if (eq opname 'funcall)
+ (let ((fun-form (cadr form)))
+ (cond ((and (consp fun-form) (eq 'function (car fun-form)))
+ (let ((real-fun (cadr fun-form)))
+ (if (legal-fun-name-p real-fun)
+ (values (sb!xc:compiler-macro-function real-fun *lexenv*)
+ real-fun)
+ (values nil nil))))
+ ((sb!xc:constantp fun-form *lexenv*)
+ (let ((fun (constant-form-value fun-form *lexenv*)))
+ (if (legal-fun-name-p fun)
+ ;; CLHS tells us that local functions must shadow
+ ;; compiler-macro-functions, but since the call is
+ ;; through a name, we are obviously interested
+ ;; in the global function.
+ (values (sb!xc:compiler-macro-function fun nil) fun)
+ (values nil nil))))
+ (t
+ (values nil nil))))
+ (if (legal-fun-name-p opname)
+ (values (sb!xc:compiler-macro-function opname *lexenv*) opname)
+ (values nil nil))))
+
+;;; Picks of special forms and compiler-macro expansions, and hands
+;;; the rest to IR1-CONVERT-COMMON-FUNCTOID
+(defun ir1-convert-functoid (start next result form)
+ (let* ((op (car form))
+ (translator (and (symbolp op) (info :function :ir1-convert op))))
(cond (translator
- (when cmacro-fun
+ (when (sb!xc:compiler-macro-function op *lexenv*)
(compiler-warn "ignoring compiler macro for special form"))
(funcall translator start next result form))
- ((and cmacro-fun
- ;; gotcha: If you look up the DEFINE-COMPILER-MACRO
- ;; macro in the ANSI spec, you might think that
- ;; suppressing compiler-macro expansion when NOTINLINE
- ;; is some pre-ANSI hack. However, if you look up the
- ;; NOTINLINE declaration, you'll find that ANSI
- ;; requires this behavior after all.
- (not (eq (info :function :inlinep fun-name) :notinline)))
- (let ((res (careful-expand-macro cmacro-fun form)))
- (if (eq res form)
- (ir1-convert-global-functoid-no-cmacro
- start next result form fun-name)
- (ir1-convert start next result res))))
(t
- (ir1-convert-global-functoid-no-cmacro start next result
- form fun-name)))))
+ (multiple-value-bind (cmacro-fun cmacro-fun-name)
+ (find-compiler-macro op form)
+ (if (and cmacro-fun
+ ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
+ ;; suppresses compiler-macros.
+ (not (fun-lexically-notinline-p cmacro-fun-name)))
+ (let ((res (careful-expand-macro cmacro-fun form)))
+ (if (eq res form)
+ (ir1-convert-common-functoid start next result form
+ op)
+ (ir1-convert start next result res)))
+ (ir1-convert-common-functoid start next result form op)))))))
+
+;;; Handles the "common" cases: any other forms except special forms
+;;; and compiler-macros.
+(defun ir1-convert-common-functoid (start next result form op)
+ (cond ((or (symbolp op) (leaf-p op))
+ (let ((lexical-def (if (leaf-p op) op (lexenv-find op funs))))
+ (typecase lexical-def
+ (null
+ (ir1-convert-global-functoid start next result form op))
+ (functional
+ (ir1-convert-local-combination start next result form
+ lexical-def))
+ (global-var
+ (ir1-convert-srctran start next result lexical-def form))
+ (t
+ (aver (and (consp lexical-def) (eq (car lexical-def) 'macro)))
+ (ir1-convert start next result
+ (careful-expand-macro (cdr lexical-def) form))))))
+ ((or (atom op) (not (eq (car op) 'lambda)))
+ (compiler-error "illegal function call"))
+ (t
+ ;; implicitly (LAMBDA ..) because the LAMBDA expression is
+ ;; the CAR of an executed form.
+ (ir1-convert-combination
+ start next result form
+ (ir1-convert-lambda op
+ :debug-name (debug-name 'inline-lambda op))))))
-;;; Handle the case of where the call was not a compiler macro, or was
-;;; a compiler macro and passed.
-(defun ir1-convert-global-functoid-no-cmacro (start next result form fun)
+;;; Convert anything that looks like a global function call.
+(defun ir1-convert-global-functoid (start next result form fun)
(declare (type ctran start next) (type (or lvar null) result)
(list form))
;; FIXME: Couldn't all the INFO calls here be converted into
- ;; standard CL functions, like MACRO-FUNCTION or something?
- ;; And what happens with lexically-defined (MACROLET) macros
- ;; here, anyway?
+ ;; standard CL functions, like MACRO-FUNCTION or something? And what
+ ;; happens with lexically-defined (MACROLET) macros here, anyway?
(ecase (info :function :kind fun)
(:macro
(ir1-convert start next result
(type-error (c) (assert (eq (type-error-expected-type c) 'integer)))
(:no-error (&rest vals) (error "no error"))))
-;;; FUNCALL forms in compiler macros
+;;; Basic compiler-macro expansion
+(define-compiler-macro test-cmacro-0 () ''expanded)
+
+(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
+
+;;; FUNCALL forms in compiler macros, lambda-list parsing
(define-compiler-macro test-cmacro-1
(&whole whole a &optional b &rest c &key d)
(list whole a b c d))
(test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3)
(test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13))
+;;; FUNCALL forms in compiler macros, expansions
+(define-compiler-macro test-cmacro-2 () ''ok)
+
+(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
+
+;;; Shadowing of compiler-macros by local functions
+(define-compiler-macro test-cmacro-3 () ''global)
+
+(defmacro find-cmacro-3 (&environment env)
+ (compiler-macro-function 'test-cmacro-3 env))
+
+(assert (funcall (lambda () (find-cmacro-3))))
+(assert (not (funcall (lambda () (flet ((test-cmacro-3 ()))
+ (find-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (test-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (funcall #'test-cmacro-3))))))
+(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (funcall 'test-cmacro-3))))))
+
+;;; Local NOTINLINE & INLINE
+(defun test-cmacro-4 () 'fun)
+(define-compiler-macro test-cmacro-4 () ''macro)
+
+(assert (eq 'fun (funcall (lambda ()
+ (declare (notinline test-cmacro-4))
+ (test-cmacro-4)))))
+
+(assert (eq 'macro (funcall (lambda ()
+ (declare (inline test-cmacro-4))
+ (test-cmacro-4)))))
+
;;; success
projects / sbcl.git / commitdiff