X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-misc.lisp;h=5432caed863c4b1fb4e1094c068b7a8fe468a85f;hb=9c3a9502bc872f024c365412d991ef43fd866e4c;hp=feb1cf558e2a71a798fb4ad2cf555343703ad2fc;hpb=c3ba3bc968894227fd936ffd777f94c100bdea7d;p=sbcl.git diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index feb1cf5..5432cae 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -17,6 +17,13 @@ ;;;; function names and documentation ;;;; the ANSI interface to function names (and to other stuff too) +;;; Note: this function gets called by the compiler (as of 1.0.17.x, +;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says +;;; we're allowed to return NIL here freely, it seems plausible that +;;; small changes to the circumstances under which this function +;;; returns non-NIL might have subtle consequences on the compiler. +;;; So it might be desirable to have the compiler not rely on this +;;; function, eventually. (defun function-lambda-expression (fun) "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument @@ -29,8 +36,11 @@ (sb!eval:interpreted-function (let ((name (sb!eval:interpreted-function-name fun)) (lambda-list (sb!eval:interpreted-function-lambda-list fun)) + (declarations (sb!eval:interpreted-function-declarations fun)) (body (sb!eval:interpreted-function-body fun))) - (values `(lambda ,lambda-list ,@body) + (values `(lambda ,lambda-list + ,@(when declarations `((declare ,@declarations))) + ,@body) t name))) (function (let* ((fun (%simple-fun-self (%fun-fun fun))) @@ -39,9 +49,9 @@ (info (sb!kernel:%code-debug-info code))) (if info (let ((source (sb!c::debug-info-source info))) - (cond ((and (eq (sb!c::debug-source-from source) :lisp) + (cond ((and (sb!c::debug-source-form source) (eq (sb!c::debug-source-function source) fun)) - (values (svref (sb!c::debug-source-name source) 0) + (values (sb!c::debug-source-form source) nil name)) ((legal-fun-name-p name) @@ -51,86 +61,83 @@ (values nil t name)))) (values nil t name)))))) -(defun closurep (object) - (= sb!vm:closure-header-widetag (widetag-of object))) +;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs +;;; Underlying SIMPLE-FUN (defun %fun-fun (function) (declare (function function)) - (case (widetag-of function) - (#.sb!vm:simple-fun-header-widetag + (typecase function + (simple-fun function) - (#.sb!vm:closure-header-widetag + (closure (%closure-fun function)) - (#.sb!vm:funcallable-instance-header-widetag + (funcallable-instance (%fun-fun (funcallable-instance-fun function))))) -(defun %closure-values (object) - (declare (function object)) - (loop for index from 0 - below (- (get-closure-length object) (1- sb!vm:closure-info-offset)) - collect (%closure-index-ref object index))) +(defun %fun-lambda-list (function) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (sb!eval:interpreted-function-debug-lambda-list function)) + (t + (%simple-fun-arglist (%fun-fun function))))) -(defun %fun-lambda-list (object) - (%simple-fun-arglist (%fun-fun object))) +(defun (setf %fun-lambda-list) (new-value function) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (setf (sb!eval:interpreted-function-debug-lambda-list function) new-value)) + ;; FIXME: Eliding general funcallable-instances for now. + ((or simple-fun closure) + (setf (%simple-fun-arglist (%fun-fun function)) new-value))) + new-value) + +(defun %fun-type (function) + (%simple-fun-type (%fun-fun function))) ;;; a SETFable function to return the associated debug name for FUN ;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION), ;;; or NIL if there's none (defun %fun-name (function) - (%simple-fun-name (%fun-fun function))) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (sb!eval:interpreted-function-debug-name function)) + (t + (%simple-fun-name (%fun-fun function))))) -(defun %fun-type (function) - (%simple-fun-type (%fun-fun function))) +(defun (setf %fun-name) (new-value function) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (setf (sb!eval:interpreted-function-debug-name function) new-value)) + ;; FIXME: Eliding general funcallable-instances for now. + ((or simple-fun closure) + (setf (%simple-fun-name (%fun-fun function)) new-value))) + new-value) -(defun (setf %fun-name) (new-name fun) - (aver nil) ; since this is unsafe 'til bug 137 is fixed - (let ((widetag (widetag-of fun))) - (case widetag - (#.sb!vm:simple-fun-header-widetag - ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure - ;; functions is left over from CMU CL (modulo various renaming - ;; that's gone on since the fork). - (setf (%simple-fun-name fun) new-name)) - (#.sb!vm:closure-header-widetag - ;; FIXME: It'd be nice to be able to set %FUN-NAME here on - ;; per-closure basis. Instead, we are still using the CMU CL - ;; approach of closures being named after their closure - ;; function, which doesn't work right e.g. for structure - ;; accessors, and might not be quite right for DEFUN - ;; in a non-null lexical environment either. - ;; When/if weak hash tables become supported - ;; again, it'll become easy to fix this, but for now there - ;; seems to be no easy way (short of the ugly way of adding a - ;; slot to every single closure header), so we don't. - ;; - ;; Meanwhile, users might encounter this problem by doing DEFUN - ;; in a non-null lexical environment, so we try to give a - ;; reasonably meaningful user-level "error" message (but only - ;; as a warning because this is optional debugging - ;; functionality anyway, not some hard ANSI requirement). - (warn "can't set name for closure, leaving name unchanged")) - (t - ;; The other function subtype names are also un-settable - ;; but this problem seems less likely to be tickled by - ;; user-level code, so we can give a implementor-level - ;; "error" (warning) message. - (warn "can't set function name ((~S function)=~S), leaving it unchanged" - 'widetag-of widetag)))) - new-name) +(defun %fun-doc (function) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (sb!eval:interpreted-function-documentation function)) + (t + (%simple-fun-doc (%fun-fun function))))) -(defun %fun-doc (x) - ;; FIXME: This business of going through %FUN-NAME and then globaldb - ;; is the way CMU CL did it, but it doesn't really seem right. - ;; When/if weak hash tables become supported again, using a weak - ;; hash table to maintain the object/documentation association would - ;; probably be better. - (let ((name (%fun-name x))) - (when (and name (typep name '(or symbol cons))) - (values (info :function :documentation name))))) +(defun (setf %fun-doc) (new-value function) + (declare (type (or null string) new-value)) + (typecase function + #!+sb-eval + (sb!eval:interpreted-function + (setf (sb!eval:interpreted-function-documentation function) new-value)) + ((or simple-fun closure) + (setf (%simple-fun-doc (%fun-fun function)) new-value))) + new-value) ;;; various environment inquiries -(defvar *features* '#.sb-cold:*shebang-features* +(defvar *features* + '#.(sort (copy-list sb-cold:*shebang-features*) #'string<) #!+sb-doc "a list of symbols that describe features provided by the implementation")