X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=e47f2879df16427c474d0fb1b12a47a783e1b02a;hb=444d2072bc52e60a41af62ee22e343e76109212f;hp=18ff9b5a8708a20d9ebf18457b3b01f62eda0da1;hpb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 18ff9b5..e47f287 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -26,9 +26,7 @@ (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) @@ -78,7 +76,7 @@ (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" @@ -90,8 +88,8 @@ (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) @@ -109,7 +107,7 @@ (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. @@ -117,29 +115,12 @@ (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))) ;;;; 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: 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 - ;; (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)) - (t t))) - -(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, @@ -147,24 +128,26 @@ environment only." (declare (symbol symbol)) (let* ((fenv (when env (sb!c::lexenv-funs env))) - (local-def (cdr (assoc symbol fenv)))) + (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) @@ -175,11 +158,11 @@ ;; 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 sb!xc:compiler-macro-function (name &optional env) @@ -198,14 +181,16 @@ (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)) ;;;; a subset of DOCUMENTATION functionality for bootstrapping @@ -227,45 +212,45 @@ ;;; 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 (when (eq (info :type :kind x) :instance) + (values (info :type :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 @@ -275,14 +260,14 @@ (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))) + (setf (info :type :documentation name) string) + (error "~S is not the name of a structure type." 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)