(in-package "SB!C")
\f
+;;;; internal utilities defined in terms of INFO
+
;;; Check that NAME is a valid function name, returning the name if
;;; OK, and signalling an error if not. In addition to checking for
;;; basic well-formedness, we also check that symbol names are not NIL
;;; or the name of a special form.
-(defun check-function-name (name)
+(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)
(compiler-error "Special form is an illegal function name: ~S" name)))
(t
(compiler-error "illegal function name: ~S" name)))
- name)
+ (values))
;;; Record a new function definition, and check its legality.
-(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
-(defun proclaim-as-function-name (name)
- (check-function-name name)
+(defun proclaim-as-fun-name (name)
+
+ ;; legal name?
+ (check-fun-name name)
+
+ ;; scrubbing old data I: possible collision with old definition
(when (fboundp name)
(ecase (info :function :kind name)
- (:function
- (let ((accessor-for (info :function :accessor-for name)))
- (when accessor-for
- (compiler-style-warning
- "~@<The function ~
- ~2I~_~S ~
- ~I~_was previously defined as a slot accessor for ~
- ~2I~_~S.~:>"
- name
- accessor-for)
- (clear-info :function :accessor-for name))))
- (:macro
- (compiler-style-warning "~S was previously defined as a macro." name)
+ (:function) ; happy case
+ ((nil)) ; another happy case
+ (:macro ; maybe-not-so-good case
+ (compiler-style-warn "~S was previously defined as a macro." name)
(setf (info :function :where-from name) :assumed)
- (clear-info :function :macro-function name))
- ((nil))))
+ (clear-info :function :macro-function name))))
+
+ ;; scrubbing old data II: dangling forward references
+ ;;
+ ;; (This could happen if someone executes PROCLAIM FTYPE at
+ ;; macroexpansion time, which is bad style, or at compile time, e.g.
+ ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
+ ;; case it's reasonable style. Either way, NAME is no longer a free
+ ;; function.)
+ (when (boundp '*free-funs*) ; when compiling
+ (remhash name *free-funs*))
+
+ ;; recording the ordinary case
(setf (info :function :kind name) :function)
- (note-if-setf-function-and-macro name)
- name)
+ (note-if-setf-fun-and-macro name)
+
+ (values))
;;; This is called to do something about SETF functions that overlap
;;; with SETF macros. Perhaps we should interact with the user to see
;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
;;; can't assume that they aren't just naming a function (SETF FOO)
;;; for the heck of it. NAME is already known to be well-formed.
-(defun note-if-setf-function-and-macro (name)
+(defun note-if-setf-fun-and-macro (name)
(when (consp name)
(when (or (info :setf :inverse name)
(info :setf :expander name))
- (compiler-style-warning
+ (compiler-style-warn
"defining as a SETF function a name that already has a SETF macro:~
~% ~S"
name)))
;;; Make NAME no longer be a function name: clear everything back to
;;; the default.
-(defun undefine-function-name (name)
+(defun undefine-fun-name (name)
(when name
(macrolet ((frob (type &optional val)
`(unless (eq (info :function ,type name) ,val)
(frob :where-from :assumed)
(frob :inlinep)
(frob :kind)
- (frob :accessor-for)
- (frob :inline-expansion)
+ (frob :inline-expansion-designator)
(frob :source-transform)
(frob :assumed-type)))
(values))
;;; part of what happens with DEFUN, also with some PCL stuff: Make
;;; NAME known to be a function definition.
-(defun become-defined-function-name (name)
- (proclaim-as-function-name name)
+(defun become-defined-fun-name (name)
+ (proclaim-as-fun-name name)
(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))))
+
+;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
+;;; value into a lambda expression, or return NIL if there is none.
+(declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
+(defun fun-name-inline-expansion (fun-name)
+ (let ((info (info :function :inline-expansion-designator fun-name)))
+ (if (functionp info)
+ (funcall info)
+ info)))
\f
;;;; ANSI Common Lisp functions which are defined in terms of the info
;;;; database
#!+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)
else returns NIL. If ENV is unspecified or NIL, use the global
environment only."
(declare (symbol symbol))
- (let* ((fenv (when env (sb!c::lexenv-functions env)))
+ (let* ((fenv (when env (sb!c::lexenv-funs env)))
(local-def (cdr (assoc symbol fenv))))
(cond (local-def
(if (and (consp local-def) (eq (car local-def) 'MACRO))
(defun sb!xc:compiler-macro-function (name &optional env)
#!+sb-doc
- "If NAME names a compiler-macro, returns the expansion function,
- else returns 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-functions env)
- :test #'equal)))))
- (unless (eq (cond ((sb!c::defined-function-p found)
- (sb!c::defined-function-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."
+ (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
+ ;; 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))
+ (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)
(symbol (values (info :variable :documentation x)))))
(function
(cond ((functionp x)
- (function-doc x))
- ((legal-function-name-p 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
- (function-name-block-name x))))))
+ (fun-name-block-name x))))))
(structure
(typecase x
(symbol (when (eq (info :type :kind x) :instance)
(setf (info :setf :documentation x))
((t)
(typecase x
- (function (function-doc 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))))
projects / sbcl.git / blobdiff