(defun check-fun-name (name)
(typecase name
(list
- (unless (and (consp name) (consp (cdr name))
- (null (cddr name)) (eq (car name) 'setf)
- (symbolp (cadr name)))
+ (unless (legal-fun-name-p name)
(compiler-error "illegal function name: ~S" name)))
(symbol
(when (eq (info :function :kind name) :special-form)
#!+sb-doc
"True of any Lisp object that has a constant value: types that eval to
themselves, keywords, constants, and list whose car is QUOTE."
- ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
- ;; They eval to themselves..
- ;;
;; FIXME: Someday it would be nice to make the code recognize foldable
;; functions and call itself recursively on their arguments, so that
;; more of the examples in the ANSI CL definition are recognized.
;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
(declare (ignore environment))
(typecase object
- (number t)
- (character t)
- (array t)
;; (Note that the following test on INFO catches KEYWORDs as well as
;; explicitly DEFCONSTANT symbols.)
(symbol (eq (info :variable :kind object) :constant))
- (list (eq (car object) 'quote))))
+ (list (and (eq (car object) 'quote)
+ (consp (cdr object))))
+ (t t)))
+
+(defun constant-form-value (form)
+ (typecase form
+ (symbol (info :variable :constant-value form))
+ ((cons (eql quote) cons)
+ (second form))
+ (t form)))
-(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
(defun sb!xc:macro-function (symbol &optional env)
#!+sb-doc
"If SYMBOL names a macro in ENV, returns the expansion function,
#!+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))
(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
(error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
(when (eq (info :function :kind name) :special-form)
(error "~S names a special form." name))
- (setf (info :function :compiler-macro-function name) function)
- function)
+ (with-single-package-locked-error
+ (:symbol name "setting the compiler-macro-function of ~A")
+ (setf (info :function :compiler-macro-function name) function)
+ function))
\f
;;;; a subset of DOCUMENTATION functionality for bootstrapping
(typecase x
(structure-class (values (info :type :documentation (class-name x))))
(t (and (typep x 'symbol) (values (info :type :documentation x))))))
- (setf (info :setf :documentation x))
+ (setf (values (info :setf :documentation x)))
((t)
(typecase x
(function (%fun-doc x))