From df871446529da0e83d670f35a9566c11d814be32 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 20 Jun 2009 13:48:46 +0000 Subject: [PATCH] 1.0.29.23: simple-fun and closure cleanups * Reorganize things a bit between kernel.lisp and target-misc.lisp for clarity, ditto for the package-data-lisp.expr. * Define SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCE types, and use them instead of manually checking for widetags in various places. * Implement (SETF %FUN-LAMBDA-LIST), and make it work on interpreted functions as well by giving them an DEBUG-LAMBDA-LIST. Use in DEFMACRO and DEFINE-COMPILER-MACRO instead of looking at the widetags. * Make (SETF %FUN-NAME) to work: on closures just change the name of the underlying function and let the callers beware. On interpreted functions change the new DEBUG-NAME slot instead of NAME. Use in DEFMACRO and DEFINE-COMPILER-MACRO. * Implement and use DO-CLOSURE-VALUES to walk over closure environment instead of manually iterating over indexes. * Use %FUN-FUN in FUN-DEBUG-FUN, and %FUN-LAMBDA-LIST in the SB-ACLREPL::INSPECTED-PARTS. * Remove the commented out (SETF %FUN-NAME) from DEFUN: the compiler does the right thing, and for the debugger to have a useful name it has to be on the SIMPLE-FUN at any rate, so... * Slightly nicer DESCRIBE of interpreted functions. --- contrib/sb-aclrepl/inspect.lisp | 7 +-- contrib/sb-introspect/sb-introspect.lisp | 2 +- package-data-list.lisp-expr | 39 ++++++++++--- src/code/debug-int.lisp | 53 ++++++++--------- src/code/defboot.lisp | 6 -- src/code/defmacro.lisp | 11 +--- src/code/describe.lisp | 40 ++++++------- src/code/early-full-eval.lisp | 11 +++- src/code/fdefinition.lisp | 16 +++--- src/code/kernel.lisp | 50 ++++++++++++++-- src/code/macros.lisp | 11 +--- src/code/ntrace.lisp | 11 ++-- src/code/target-defstruct.lisp | 6 +- src/code/target-misc.lisp | 92 +++++++++++++----------------- version.lisp-expr | 2 +- 15 files changed, 190 insertions(+), 167 deletions(-) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 071411a..cf19fb7 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -817,12 +817,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (list components (length components) :named nil))) (defmethod inspected-parts ((object function)) - (let* ((type (sb-kernel:widetag-of object)) - (object (if (= type sb-vm:closure-header-widetag) - (sb-kernel:%closure-fun object) - object)) - (components (list (cons "arglist" - (sb-kernel:%simple-fun-arglist object))))) + (let ((components (list (cons "arglist" (sb-kernel:%fun-lambda-list object))))) (list components (length components) :named nil))) (defmethod inspected-parts ((object vector)) diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index aca9fdc..e986d14 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -573,7 +573,7 @@ constant pool." ;; from the table if available. (let* ((simple-fun (get-simple-fun value)) (xrefs (when simple-fun - (sb-vm::%simple-fun-xrefs simple-fun))) + (sb-kernel:%simple-fun-xrefs simple-fun))) (array (when xrefs (aref xrefs kind-index)))) ;; Loop through the name/path xref entries in the table diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2926841..6037122 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1231,7 +1231,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%CHECK-BOUND" "%CHECK-GENERIC-SEQUENCE-BOUNDS" "%CHECK-VECTOR-SEQUENCE-BOUNDS" - "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COMPARE-AND-SWAP-CAR" "%COMPARE-AND-SWAP-CDR" "%COMPARE-AND-SWAP-INSTANCE-REF" @@ -1244,9 +1243,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF" "%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT" "%FIND-POSITION-IF-NOT-VECTOR-MACRO" - "%FUN-DOC" - "%FUN-FUN" - "%FUN-NAME" "%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LAST0" "%LAST1" @@ -1694,6 +1690,30 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "UB64-BASH-COPY" "SYSTEM-AREA-UB64-COPY" "COPY-UB64-TO-SYSTEM-AREA" "COPY-UB64-FROM-SYSTEM-AREA" + ;; SIMPLE-FUN type and accessors + "SIMPLE-FUN" + "SIMPLE-FUN-P" + "%SIMPLE-FUN-ARGLIST" + "%SIMPLE-FUN-NAME" + "%SIMPLE-FUN-NEXT" + "%SIMPLE-FUN-SELF" + "%SIMPLE-FUN-TYPE" + "%SIMPLE-FUN-XREFS" + + ;; CLOSURE type and accessors + "CLOSURE" + "CLOSUREP" + "DO-CLOSURE-VALUES" + "%CLOSURE-FUN" + "%CLOSURE-INDEX-REF" + "%CLOSURE-VALUES" + + ;; Abstract function accessors + "%FUN-DOC" + "%FUN-FUN" + "%FUN-LAMBDA-LIST" + "%FUN-NAME" + "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUN" "FDEFN-MAKUNBOUND" "OUTER-FDEFN" "%COERCE-CALLABLE-TO-FUN" "FUN-SUBTYPE" @@ -1713,19 +1733,18 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "DD-RAW-LENGTH" "NOTE-NAME-DEFINED" "%CODE-CODE-SIZE" "DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM" "%IMAGPART" "DSD-ACCESSOR-NAME" "%CODE-DEBUG-INFO" - "LAYOUT-CLASSOID" "LAYOUT-INVALID" "%SIMPLE-FUN-NAME" + "LAYOUT-CLASSOID" "LAYOUT-INVALID" "DSD-TYPE" "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION" - "%SIMPLE-FUN-ARGLIST" "%SIMPLE-FUN-NEXT" "DD-PREDICATE-NAME" "CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO" "%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR" - "LAYOUT-OF" "%SIMPLE-FUN-SELF" "%REALPART" + "LAYOUT-OF" "%REALPART" "STRUCTURE-CLASSOID-P" "DSD-INDEX" "STRUCTURE-CLASSOID" - "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%SIMPLE-FUN-TYPE" + "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME" "%NUMERATOR" "CLASSOID-TYPEP" "DSD-READ-ONLY" "DSD-DEFAULT" "LAYOUT-INHERITS" "DD-LENGTH" - "%CODE-ENTRY-POINTS" "%DENOMINATOR" "%SIMPLE-FUN-XREFS" + "%CODE-ENTRY-POINTS" "%DENOMINATOR" "%OTHER-POINTER-P" "STANDARD-CLASSOID" "CLASSOID-OF" @@ -2681,7 +2700,9 @@ structure representations" :export ("INTERPRETED-FUNCTION" "INTERPRETED-FUNCTION-P" "INTERPRETED-FUNCTION-NAME" + "INTERPRETED-FUNCTION-DEBUG-NAME" "INTERPRETED-FUNCTION-LAMBDA-LIST" + "INTERPRETED-FUNCTION-DEBUG-LAMBDA-LIST" "INTERPRETED-FUNCTION-DOCUMENTATION" "INTERPRETED-FUNCTION-BODY" "INTERPRETED-FUNCTION-SOURCE-LOCATION" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 19da16e..d02edae 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1206,35 +1206,30 @@ register." ;;; Return a DEBUG-FUN that represents debug information for FUN. (defun fun-debug-fun (fun) (declare (type function fun)) - (ecase (widetag-of fun) - (#.sb!vm:closure-header-widetag - (fun-debug-fun (%closure-fun fun))) - (#.sb!vm:funcallable-instance-header-widetag - (fun-debug-fun (funcallable-instance-fun fun))) - (#.sb!vm:simple-fun-header-widetag - (let* ((name (%simple-fun-name fun)) - (component (fun-code-header fun)) - (res (find-if - (lambda (x) - (and (sb!c::compiled-debug-fun-p x) - (eq (sb!c::compiled-debug-fun-name x) name) - (eq (sb!c::compiled-debug-fun-kind x) nil))) - (sb!c::compiled-debug-info-fun-map - (%code-debug-info component))))) - (if res - (make-compiled-debug-fun res component) - ;; KLUDGE: comment from CMU CL: - ;; This used to be the non-interpreted branch, but - ;; William wrote it to return the debug-fun of fun's XEP - ;; instead of fun's debug-fun. The above code does this - ;; more correctly, but it doesn't get or eliminate all - ;; appropriate cases. It mostly works, and probably - ;; works for all named functions anyway. - ;; -- WHN 20000120 - (debug-fun-from-pc component - (* (- (fun-word-offset fun) - (get-header-data component)) - sb!vm:n-word-bytes))))))) + (let ((simple-fun (%fun-fun fun))) + (let* ((name (%simple-fun-name simple-fun)) + (component (fun-code-header simple-fun)) + (res (find-if + (lambda (x) + (and (sb!c::compiled-debug-fun-p x) + (eq (sb!c::compiled-debug-fun-name x) name) + (eq (sb!c::compiled-debug-fun-kind x) nil))) + (sb!c::compiled-debug-info-fun-map + (%code-debug-info component))))) + (if res + (make-compiled-debug-fun res component) + ;; KLUDGE: comment from CMU CL: + ;; This used to be the non-interpreted branch, but + ;; William wrote it to return the debug-fun of fun's XEP + ;; instead of fun's debug-fun. The above code does this + ;; more correctly, but it doesn't get or eliminate all + ;; appropriate cases. It mostly works, and probably + ;; works for all named functions anyway. + ;; -- WHN 20000120 + (debug-fun-from-pc component + (* (- (fun-word-offset simple-fun) + (get-header-data component)) + sb!vm:n-word-bytes)))))) ;;; Return the kind of the function, which is one of :OPTIONAL, ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 13d0618..d83ca1a 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -231,12 +231,6 @@ evaluated as a PROGN." (sb!c::note-name-defined name :function) - ;; FIXME: I want to do this here (and fix bug 137), but until the - ;; breathtaking CMU CL function name architecture is converted into - ;; something sane, (1) doing so doesn't really fix the bug, and - ;; (2) doing probably isn't even really safe. - #+nil (setf (%fun-name def) name) - (when doc (setf (fdocumentation name 'function) doc) #!+sb-eval diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index 5bc4f47..41a8d10 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -93,15 +93,8 @@ (setf (sb!xc:macro-function name) definition (fdocumentation name 'function) doc) ,(when set-p - `(case (widetag-of definition) - (#.sb!vm:closure-header-widetag - (setf (%simple-fun-arglist (%closure-fun definition)) - lambda-list - (%simple-fun-name (%closure-fun definition)) - debug-name)) - (#.sb!vm:simple-fun-header-widetag - (setf (%simple-fun-arglist definition) lambda-list - (%simple-fun-name definition) debug-name)))) + `(setf (%fun-lambda-list definition) lambda-list + (%fun-name definition) debug-name)) name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 7da9cd7..b4f1b94 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -217,16 +217,16 @@ (format s "~@:_~@" 'function-lambda-expression (nth-value 2 (function-lambda-expression x))) - (case (widetag-of x) - (#.sb-vm:closure-header-widetag + (typecase x + (closure (%describe-fun-compiled (%closure-fun x) s kind name) (format s "~&Its closure environment is:") - (loop for value in (%closure-values x) - for i = 0 then (1+ i) - do (format s "~& ~S: ~S" i value))) - (#.sb-vm:simple-fun-header-widetag + (let ((i -1)) + (do-closure-values (value x) + (format s "~& ~S: ~S" (incf i) value)))) + (simple-fun (%describe-fun-compiled x s kind name)) - (#.sb-vm:funcallable-instance-header-widetag + (funcallable-instance ;; Only STANDARD-GENERIC-FUNCTION would be handled here, but ;; since it has its own DESCRIBE-OBJECT method, it should've been ;; picked off before getting here. So hopefully we never get here. @@ -252,27 +252,23 @@ 'function-lambda-expression (nth-value 2 (function-lambda-expression x))) (format s "~&It is an interpreted function.~%") - (let ((args (sb-eval:interpreted-function-lambda-list x))) - (cond ((not args) - (write-string "There are no arguments." s)) - (t - (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) - (write-string " " s) - (let ((*print-pretty* t) - (*print-escape* t) - (*print-base* 10) - (*print-radix* nil)) - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (format s "~A" args))))) - (format s "~&It was defined as: ") + (let ((args (sb-eval:interpreted-function-debug-lambda-list x))) + (format s "Its lambda-list is: ") + (let ((*print-pretty* t) + (*print-escape* t) + (*print-base* 10) + (*print-radix* nil)) + (pprint-logical-block (s nil) + (pprint-indent :current 2) + (format s "~A" args))) + (format s "~&It was defined as:~% ") (let ((*print-pretty* t) (*print-escape* t) (*print-base* 10) (*print-radix* nil)) (pprint-logical-block (s nil) (pprint-indent :current 2) - (format s "~A" (function-lambda-expression x)))))) + (format s "~S" (function-lambda-expression x)))))) (terpri s)) (defmethod describe-object ((x function) s) diff --git a/src/code/early-full-eval.lisp b/src/code/early-full-eval.lisp index 97c85ef..aa95aaa 100644 --- a/src/code/early-full-eval.lisp +++ b/src/code/early-full-eval.lisp @@ -21,7 +21,12 @@ ;; compiler/main and code/deftypes-for-target. (sb!kernel::!defstruct-with-alternate-metaclass interpreted-function - :slot-names (name lambda-list env declarations documentation body source-location) + ;; DEBUG-NAME and DEBUG-LAMBDA-LIST are initially a copies of the proper + ;; ones, but is analogous to SIMPLE-FUN-NAME and ARGLIST in the sense that it + ;; is they are there only for debugging, and do not affect behaviour of the + ;; function -- so DEFMACRO can set them to more informative values. + :slot-names (name debug-name lambda-list debug-lambda-list env + declarations documentation body source-location) :boa-constructor %make-interpreted-function :superclass-name function :metaclass-name static-classoid @@ -34,8 +39,8 @@ (defun make-interpreted-function (&key name lambda-list env declarations documentation body source-location) (let ((function (%make-interpreted-function - name lambda-list env declarations documentation body - source-location))) + name name lambda-list lambda-list env + declarations documentation body source-location))) (setf (sb!kernel:funcallable-instance-fun function) #'(lambda (&rest args) (interpreted-apply function args))) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 710b24c..0dd857c 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -120,18 +120,16 @@ ;;; This is like FIND-IF, except that we do it on a compiled closure's ;;; environment. -(defun find-if-in-closure (test fun) - (declare (type function test)) - (dotimes (index (1- (get-closure-length fun))) - (let ((elt (%closure-index-ref fun index))) - (when (funcall test elt) - (return elt))))) +(defun find-if-in-closure (test closure) + (declare (closure closure)) + (do-closure-values (value closure) + (when (funcall test value) + (return value)))) ;;; Find the encapsulation info that has been closed over. (defun encapsulation-info (fun) - (and (functionp fun) - (= (widetag-of fun) sb!vm:closure-header-widetag) - (find-if-in-closure #'encapsulation-info-p fun))) + (when (closurep fun) + (find-if-in-closure #'encapsulation-info-p fun))) ;;; When removing an encapsulation, we must remember that ;;; encapsulating definitions close over a reference to the diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp index ad5d815..6eb5781 100644 --- a/src/code/kernel.lisp +++ b/src/code/kernel.lisp @@ -21,8 +21,13 @@ (defun set-header-data (x val) (set-header-data x val)) -;;; the length of the closure X, i.e. one more than the -;;; number of variables closed over +;;; Return the 24 bits of data in the header of object X, which must +;;; be a fun-pointer object. +;;; +;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better +;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we +;;; could just use it instead -- or at least this could just be a function on +;;; top of the same VOP. (defun get-closure-length (x) (get-closure-length x)) @@ -73,6 +78,15 @@ (defun (setf fun-subtype) (type function) (setf (fun-subtype function) type)) +;;;; SIMPLE-FUN and accessors + +(declaim (inline simple-fun-p)) +(defun simple-fun-p (object) + (= sb!vm:simple-fun-header-widetag (widetag-of object))) + +(deftype simple-fun () + '(satisfies simple-fun-p)) + ;;; Extract the arglist from the function header FUNC. (defun %simple-fun-arglist (func) (%simple-fun-arglist func)) @@ -94,19 +108,43 @@ (defun %simple-fun-self (simple-fun) (%simple-fun-self simple-fun)) +;;;; CLOSURE type and accessors + +(declaim (inline closurep)) +(defun closurep (object) + (= sb!vm:closure-header-widetag (widetag-of object))) + +(deftype closure () + '(satisfies closurep)) + +(defmacro do-closure-values ((value closure) &body body) + (with-unique-names (i nclosure) + `(let ((,nclosure ,closure)) + (declare (closure ,nclosure)) + (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset)) + (let ((,value (%closure-index-ref ,nclosure ,i))) + ,@body))))) + +(defun %closure-values (closure) + (declare (closure closure)) + (let (values) + (do-closure-values (elt closure) + (push elt closure)) + (nreverse values))) + ;;; Extract the function from CLOSURE. (defun %closure-fun (closure) (%closure-fun closure)) +;;; Extract the INDEXth slot from CLOSURE. +(defun %closure-index-ref (closure index) + (%closure-index-ref closure index)) + ;;; Return the length of VECTOR. There is no reason to use this in ;;; ordinary code, 'cause length (the vector foo)) is the same. (defun sb!c::vector-length (vector) (sb!c::vector-length vector)) -;;; Extract the INDEXth slot from CLOSURE. -(defun %closure-index-ref (closure index) - (%closure-index-ref closure index)) - ;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and ;;; WORDS words long. Note: it is your responsibility to ensure that the ;;; relation between LENGTH and WORDS is correct. diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 5365f83..b3e3c03 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -154,15 +154,8 @@ invoked. In that case it will store into PLACE and start over." (setf (sb!xc:compiler-macro-function name) definition) (setf (fdocumentation name 'compiler-macro) doc) ,(when set-p - `(case (widetag-of definition) - (#.sb!vm:closure-header-widetag - (setf (%simple-fun-arglist (%closure-fun definition)) - lambda-list - (%simple-fun-name (%closure-fun definition)) - debug-name)) - (#.sb!vm:simple-fun-header-widetag - (setf (%simple-fun-arglist definition) lambda-list - (%simple-fun-name definition) debug-name)))) + `(setf (%fun-lambda-list definition) lambda-list + (%fun-name definition) debug-name)) name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index b645387..ce60ee6 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -127,14 +127,17 @@ (values (fdefinition x) t)))) (function x) (t (values (fdefinition x) t))) - (case (sb-kernel:widetag-of res) - (#.sb-vm:closure-header-widetag + (typecase res + (closure (values (sb-kernel:%closure-fun res) named-p :compiled-closure)) - (#.sb-vm:funcallable-instance-header-widetag + (funcallable-instance (values res named-p :funcallable-instance)) - (t (values res named-p :compiled))))) + ;; FIXME: What about SB!EVAL:INTERPRETED-FUNCTION -- it gets picked off + ;; by the FIN above, is that right? + (t + (values res named-p :compiled))))) ;;; When a function name is redefined, and we were tracing that name, ;;; then untrace the old definition and trace the new one. diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 5d580c7..a646257 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -103,7 +103,11 @@ (defun %make-funcallable-instance (len) (%make-funcallable-instance len)) -(defun funcallable-instance-p (x) (funcallable-instance-p x)) +(defun funcallable-instance-p (x) + (funcallable-instance-p x)) + +(deftype funcallable-instance () + `(satisfies funcallable-instance-p)) (defun %funcallable-instance-info (fin i) (%funcallable-instance-info fin i)) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 0f65c71..1440394 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -58,72 +58,60 @@ (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))) - -(defun %fun-type (function) - (%simple-fun-type (%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 (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 (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 %fun-doc (x) ;; FIXME: This business of going through %FUN-NAME and then globaldb diff --git a/version.lisp-expr b/version.lisp-expr index ef1d43e..17d08ae 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.21" +"1.0.29.23" -- 1.7.10.4