- (n-form (gensym))
- (n-env (gensym)))
- (multiple-value-bind (body decls doc)
- (parse-defmacro lambda-list n-form body name "special form"
- :environment n-env
- :error-fun 'convert-condition-into-compiler-error
- :wrap-block nil)
- `(progn
- (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
- ,fn-name))
- (defun ,fn-name (,start-var ,next-var ,result-var ,n-form
- &aux (,n-env *lexenv*))
- (declare (ignorable ,start-var ,next-var ,result-var))
- ,@decls
- ,body
- (values))
- ,@(when doc
- `((setf (fdocumentation ',name 'function) ,doc)))
- ;; FIXME: Evidently "there can only be one!" -- we overwrite any
- ;; other :IR1-CONVERT value. This deserves a warning, I think.
- (setf (info :function :ir1-convert ',name) #',fn-name)
- ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
- ;; the 1990s?
- (setf (info :function :kind ',name) :special-form)
- ;; It's nice to do this for error checking in the target
- ;; SBCL, but it's not nice to do this when we're running in
- ;; the cross-compilation host Lisp, which owns the
- ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
- #-sb-xc-host
- (let ((fun (lambda (&rest rest)
- (declare (ignore rest))
- (error 'special-form-function :name ',name))))
- (setf (%simple-fun-arglist fun) ',lambda-list)
- (setf (symbol-function ',name) fun))
- ',name))))
+ (guard-name (symbolicate name "-GUARD")))
+ (with-unique-names (whole-var n-env)
+ (multiple-value-bind (body decls doc)
+ (parse-defmacro lambda-list whole-var body name "special form"
+ :environment n-env
+ :error-fun 'compiler-error
+ :wrap-block nil)
+ `(progn
+ (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
+ ,fn-name))
+ (defun ,fn-name (,start-var ,next-var ,result-var ,whole-var
+ &aux (,n-env *lexenv*))
+ (declare (ignorable ,start-var ,next-var ,result-var))
+ ,@decls
+ ,body
+ (values))
+ #-sb-xc-host
+ ;; It's nice to do this for error checking in the target
+ ;; SBCL, but it's not nice to do this when we're running in
+ ;; the cross-compilation host Lisp, which owns the
+ ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. These guard
+ ;; functions also provide the documentation for special forms.
+ (progn
+ (defun ,guard-name (&rest args)
+ ,@(when doc (list doc))
+ (declare (ignore args))
+ (error 'special-form-function :name ',name))
+ (let ((fun #',guard-name))
+ (setf (%simple-fun-arglist fun) ',lambda-list
+ (%simple-fun-name fun) ',name
+ (symbol-function ',name) fun)
+ (fmakunbound ',guard-name)))
+ ;; FIXME: Evidently "there can only be one!" -- we overwrite any
+ ;; other :IR1-CONVERT value. This deserves a warning, I think.
+ (setf (info :function :ir1-convert ',name) #',fn-name)
+ ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
+ ;; the 1990s?
+ (setf (info :function :kind ',name) :special-form)
+ ',name)))))