(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)
(defun note-if-setf-fun-and-macro (name)
(when (consp name)
(when (or (info :setf :inverse name)
- (info :setf :expander name))
+ (info :setf :expander name))
(compiler-style-warn
"defining as a SETF function a name that already has a SETF macro:~
~% ~S"
(defun undefine-fun-name (name)
(when name
(macrolet ((frob (type &optional val)
- `(unless (eq (info :function ,type name) ,val)
- (setf (info :function ,type name) ,val))))
+ `(unless (eq (info :function ,type name) ,val)
+ (setf (info :function ,type name) ,val))))
(frob :info)
(frob :type (specifier-type 'function))
(frob :where-from :assumed)
(when (eq (info :function :where-from name) :assumed)
(setf (info :function :where-from name) :defined)
(if (info :function :assumed-type name)
- (setf (info :function :assumed-type name) nil))))
+ (setf (info :function :assumed-type name) nil))))
;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
;;; value into a lambda expression, or return NIL if there is none.
(defun fun-name-inline-expansion (fun-name)
(let ((info (info :function :inline-expansion-designator fun-name)))
(if (functionp info)
- (funcall info)
- info)))
+ (funcall info)
+ info)))
\f
;;;; ANSI Common Lisp functions which are defined in terms of the info
;;;; database
-(defun sb!xc:constantp (object &optional environment)
- #!+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))))
-
-(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,
- 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)))
- (local-def (cdr (assoc symbol fenv))))
+ (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))
- (cdr local-def)
- nil))
- ((eq (info :function :kind symbol) :macro)
- (values (info :function :macro-function symbol)))
- (t
- nil))))
+ (if (and (consp local-def) (eq (car local-def) 'macro))
+ (cdr local-def)
+ nil))
+ ((eq (info :function :kind symbol) :macro)
+ (values (info :function :macro-function symbol)))
+ (t
+ nil))))
-;;; Note: Technically there could be an ENV optional argument to SETF
-;;; MACRO-FUNCTION, but since ANSI says that the consequences of
-;;; supplying that optional argument are undefined, we don't allow it.
-;;; (Thus our implementation of this unspecified behavior is to
-;;; complain that the wrong number of arguments was supplied. Since
-;;; the behavior is unspecified, this is conforming.:-)
-(defun (setf sb!xc:macro-function) (function symbol)
+(defun (setf sb!xc:macro-function) (function symbol &optional environment)
(declare (symbol symbol) (type function function))
+ (when environment
+ ;; Note: Technically there could be an ENV optional argument to SETF
+ ;; MACRO-FUNCTION, but since ANSI says that the consequences of
+ ;; supplying a non-nil one are undefined, we don't allow it.
+ ;; (Thus our implementation of this unspecified behavior is to
+ ;; complain. SInce the behavior is unspecified, this is conforming.:-)
+ (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
+ symbol environment))
(when (eq (info :function :kind symbol) :special-form)
(error "~S names a special form." symbol))
(setf (info :function :kind symbol) :macro)
;; cross-compilation host's COMMON-LISP package.
#-sb-xc-host
(setf (symbol-function symbol)
- (lambda (&rest args)
- (declare (ignore args))
- ;; (ANSI specification of FUNCALL says that this should be
- ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
- (error 'undefined-function :name symbol)))
+ (lambda (&rest args)
+ (declare (ignore args))
+ ;; (ANSI specification of FUNCALL says that this should be
+ ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
+ (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, return the expansion function, else
- return NIL. Note: if the name is shadowed in ENV by a local definition,
- or declared NOTINLINE, NIL is returned. Can be set with SETF."
- (let ((found (and env
- (cdr (assoc name (sb!c::lexenv-funs env)
- :test #'equal)))))
- (unless (eq (cond ((sb!c::defined-fun-p found)
- (sb!c::defined-fun-inlinep found))
- (found :notinline)
- (t
- (info :function :inlinep name)))
- :notinline)
- (values (info :function :compiler-macro-function name)))))
-(defun (setf sb!xc:compiler-macro-function) (function name)
+ "If NAME names a compiler-macro in ENV, return the expansion function, else
+return NIL. Can be set with SETF when ENV is NIL."
+ (legal-fun-name-or-type-error 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))
+ (type (or function null) function))
+ (when env
+ ;; ANSI says this operation is undefined.
+ (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
;;; and slamming them into PCL once PCL gets going.
(defun fdocumentation (x doc-type)
(flet ((try-cmucl-random-doc (x doc-type)
- (declare (symbol doc-type))
- (cdr (assoc doc-type
- (values (info :random-documentation :stuff x))))))
+ (declare (symbol doc-type))
+ (cdr (assoc doc-type
+ (values (info :random-documentation :stuff x))))))
(case doc-type
(variable
(typecase x
- (symbol (values (info :variable :documentation x)))))
+ (symbol (values (info :variable :documentation x)))))
(function
(cond ((functionp x)
- (%fun-doc x))
- ((legal-fun-name-p x)
- ;; FIXME: Is it really right to make
- ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
- ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
- ;; did, so we do it, but I'm not sure it's what ANSI wants.
- (values (info :function :documentation
- (fun-name-block-name x))))))
+ (%fun-doc x))
+ ((legal-fun-name-p x)
+ ;; FIXME: Is it really right to make
+ ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
+ ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
+ ;; did, so we do it, but I'm not sure it's what ANSI wants.
+ (values (info :function :documentation
+ (fun-name-block-name x))))))
(structure
(typecase x
- (symbol (when (eq (info :type :kind x) :instance)
- (values (info :type :documentation x))))))
+ (symbol (cond
+ ((eq (info :type :kind x) :instance)
+ (values (info :type :documentation x)))
+ ((info :typed-structure :info x)
+ (values (info :typed-structure :documentation x)))))))
(type
(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))
+ (structure-class (values (info :type :documentation (class-name x))))
+ (t (and (typep x 'symbol) (values (info :type :documentation x))))))
+ (setf (values (info :setf :documentation x)))
((t)
(typecase x
- (function (%fun-doc x))
- (package (package-doc-string x))
- (structure-class (values (info :type :documentation (class-name x))))
- (symbol (try-cmucl-random-doc x doc-type))))
+ (function (%fun-doc x))
+ (package (package-doc-string x))
+ (structure-class (values (info :type :documentation (class-name x))))
+ (symbol (try-cmucl-random-doc x doc-type))))
(t
(typecase x
- ;; FIXME: This code comes from CMU CL, but
- ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
- ;; in CMU CL. Perhaps it could be defined by analogy with the
- ;; corresponding SETF FDOCUMENTATION code.
- (symbol (try-cmucl-random-doc x doc-type)))))))
+ ;; FIXME: This code comes from CMU CL, but
+ ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
+ ;; in CMU CL. Perhaps it could be defined by analogy with the
+ ;; corresponding SETF FDOCUMENTATION code.
+ (symbol (try-cmucl-random-doc x doc-type)))))))
(defun (setf fdocumentation) (string name doc-type)
;; FIXME: I think it should be possible to set documentation for
;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
(case doc-type
(variable (setf (info :variable :documentation name) string))
(function (setf (info :function :documentation name) string))
- (structure (if (eq (info :type :kind name) :instance)
- (setf (info :type :documentation name) string)
- (error "~S is not the name of a structure type." name)))
+ (structure (cond
+ ((eq (info :type :kind name) :instance)
+ (setf (info :type :documentation name) string))
+ ((info :typed-structure :info name)
+ (setf (info :typed-structure :documentation name) string))
+ (t
+ (error "~S is not a structure name." name))))
(type (setf (info :type :documentation name) string))
(setf (setf (info :setf :documentation name) string))
(t
(let ((pair (assoc doc-type (info :random-documentation :stuff name))))
(if pair
- (setf (cdr pair) string)
- (push (cons doc-type string)
- (info :random-documentation :stuff name))))))
+ (setf (cdr pair) string)
+ (push (cons doc-type string)
+ (info :random-documentation :stuff name))))))
string)
projects / sbcl.git / blobdiff