From: William Harold Newman Date: Wed, 19 Dec 2001 20:04:09 +0000 (+0000) Subject: 0.pre7.92: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cd176690400f8b6fa23faa4dc6fa8494bcbce480;p=sbcl.git 0.pre7.92: made function names (as returned by FUNCTION-LAMBDA-EXPRESSION and used by BACKTRACE) for DEFUNed functions mostly reasonable again, e.g. PRINT instead of "top level locall PRINT" ...made SETFable %FUN-NAME to encapsulate this ...renamed FUNCTION-DOC to %FUN-DOC for consistency ...got rid of NAMED-LAMBDA, since cold-load issues make it awkward to use it in DEFUN where I intended to use it, and there's no urgent other place to use it ...made %DEFUN use SETF %FUN-NAME (There are still function-name infelicities left, especially for closures where there's no good implementation of SETFable FUN-NAME until weak hash tables work, but at least most BACKTRACE entries look better now.) --- diff --git a/TODO b/TODO index b8c0638..3ee7fe6 100644 --- a/TODO +++ b/TODO @@ -16,9 +16,13 @@ for 0.7.0: * global style systematization: ** s/#'(lambda/(lambda/ ** four-space indentation in C +* pending patches that go in (or else get rejected) before 0.7.0: + ** Nathan Froyd "Goodbye ITERATE" 2001-12-15 ======================================================================= for early 0.7.x: +* patches postponed until after 0.7.0: + ** Christophe Rhodes "rough patch to fix bug 106" 2001-10-28 * building with CLISP (or explaining why not) * faster bootstrapping (both make.sh and slam.sh) ** added mechanisms for automatically finding dead code, and diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4d1dc50..3c04e60 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -743,7 +743,6 @@ retained, possibly temporariliy, because it might be used internally." ;; ..and macros.. "COLLECT" "DO-ANONYMOUS" "DOHASH" "DOVECTOR" - "NAMED-LAMBDA" "NAMED-LET" "ONCE-ONLY" "DEFENUM" @@ -928,6 +927,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%FIND-POSITION" "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF" "%FIND-POSITION-IF-VECTOR-MACRO" + "%FUN-DOC" "%FUN-NAME" "%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" @@ -1037,7 +1037,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" "FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION" "FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" - "FUN-CODE-HEADER" "FUNCTION-DOC" + "FUN-CODE-HEADER" "FUN-TYPE" "FUN-TYPE-ALLOWP" "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" "FUN-TYPE-NARGS" "FUN-TYPE-OPTIONAL" @@ -1380,7 +1380,7 @@ definitely not guaranteed to be present in later versions of SBCL." ;; is unscrewed, since until it is there are too many things which ;; conflict between the two packages. :use ("CL" "SB!ITERATE" "SB!WALKER" "SB!INT" "SB!EXT") - :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "FUNCTION-DOC" + :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "%FUN-DOC" "PACKAGE-DOC-STRING" "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS")) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index b8a9ddd..73cf753 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -170,10 +170,12 @@ (unless (symbol-package (fun-name-block-name name)) (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) - (let* ((lambda `(lambda ,args - ,@decls - (block ,(fun-name-block-name name) - ,@forms))) + (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA + (lambda-guts `(,args + ,@decls + (block ,(fun-name-block-name name) + ,@forms))) + (lambda `(lambda ,@lambda-guts)) (inline-lambda (cond (;; Does the user not even want to inline? (not (inline-fun-name-p name)) @@ -197,7 +199,7 @@ ;; simplified way. `(sb!c:lambda-with-lexenv nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS - ,@(rest lambda)))))) + ,@lambda-guts))))) `(progn ;; In cross-compilation of toplevel DEFUNs, we arrange @@ -225,6 +227,7 @@ (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) (setf (sb!xc:fdefinition name) def) + (setf (%fun-name def) name) (when doc ;; FIXME: This should use shared SETF-name-parsing logic. (if (and (consp name) (eq (first name) 'setf)) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 01baacc..4b1aa1d 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -194,6 +194,9 @@ (:macro (format s "Macro-function: ~S" x)) (:function (format s "Function: ~S" x)) ((nil) (format s "~S is a function." x))) + (format s "~@:_Its associated name (as in ~S) is ~S." + 'function-lambda-expression + (%fun-name x)) (case (widetag-of x) (#.sb-vm:closure-header-widetag (%describe-function-compiled (%closure-fun x) s kind name) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index da49162..6e8b10f 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -156,32 +156,6 @@ (%eval original-exp)))))) (t exp)))) - -(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 - to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition - might have been enclosed in some non-null lexical environment, and - NAME is some name (for debugging only) or NIL if there is no name." - (declare (type function fun)) - (let* ((fun (%simple-fun-self fun)) - (name (%simple-fun-name fun)) - (code (sb!di::fun-code-header fun)) - (info (sb!kernel:%code-debug-info code))) - (if info - (let ((source (first (sb!c::compiled-debug-info-source info)))) - (cond ((and (eq (sb!c::debug-source-from source) :lisp) - (eq (sb!c::debug-source-info source) fun)) - (values (second (svref (sb!c::debug-source-name source) 0)) - nil name)) - ((stringp name) - (values nil t name)) - (t - (let ((exp (fun-name-inline-expansion name))) - (if exp - (values exp nil name) - (values nil t name)))))) - (values nil t name)))) ;;; miscellaneous full function definitions of things which are ;;; ordinarily handled magically by the compiler diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index e4c9acd..64d4fb3 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -13,28 +13,106 @@ ;;;; files for more information. (in-package "SB!IMPL") + +;;;; function names and documentation + +;;;; the ANSI interface to function names (and to other stuff too) +(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 + to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition + might have been enclosed in some non-null lexical environment, and + NAME is some name (for debugging only) or NIL if there is no name." + (declare (type function fun)) + (let* ((fun (%simple-fun-self fun)) + (name (%fun-name fun)) + (code (sb!di::fun-code-header fun)) + (info (sb!kernel:%code-debug-info code))) + (if info + (let ((source (first (sb!c::compiled-debug-info-source info)))) + (cond ((and (eq (sb!c::debug-source-from source) :lisp) + (eq (sb!c::debug-source-info source) fun)) + (values (second (svref (sb!c::debug-source-name source) 0)) + nil + name)) + ((stringp name) + (values nil t name)) + (t + (let ((exp (fun-name-inline-expansion name))) + (if exp + (values exp nil name) + (values nil t name)))))) + (values nil t name)))) + +;;; 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 (fun) + (case (widetag-of fun) + (#.sb!vm:closure-header-widetag + (%simple-fun-name (%closure-fun fun))) + ((#.sb!vm:simple-fun-header-widetag + #.sb!vm:closure-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). + (%simple-fun-name fun)) + (#.sb!vm:funcallable-instance-header-widetag + (%simple-fun-name + (funcallable-instance-fun fun))))) + +(defun (setf %fun-name) (new-name fun) + (let ((widetag (widetag-of fun))) + (case widetag + ((#.sb!vm:simple-fun-header-widetag + #.sb!vm:closure-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) -;;; cobbled from stuff in describe.lisp. -(defun function-doc (x) - (let ((name - (case (widetag-of x) - (#.sb!vm:closure-header-widetag - (%simple-fun-name (%closure-fun x))) - ((#.sb!vm:simple-fun-header-widetag - #.sb!vm:closure-fun-header-widetag) - (%simple-fun-name x)) - (#.sb!vm:funcallable-instance-header-widetag - (%simple-fun-name - (funcallable-instance-fun x)))))) +(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))))) + +;;; various environment inquiries (defvar *features* '#.sb-cold:*shebang-features* #!+sb-doc "a list of symbols that describe features provided by the implementation") - -;;; various environment inquiries (defun machine-instance () #!+sb-doc diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 2fe4324..7215ff4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1341,3 +1341,8 @@ ()) (defknown %setnth (index list t) t (unsafe)) (defknown %set-fill-pointer (vector index) index (unsafe)) + +;;;; miscellaneous internal utilities + +(defknown %fun-name (function) t (flushable)) +(defknown (setf %fun-name) (t function) t (unsafe)) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 9e41aeb..2319a83 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -240,7 +240,7 @@ (symbol (values (info :variable :documentation x))))) (function (cond ((functionp x) - (function-doc x)) + (%fun-doc x)) ((legal-fun-name-p x) ;; FIXME: Is it really right to make ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to @@ -259,7 +259,7 @@ (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)))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 950f3c7..8f68038 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -2023,18 +2023,3 @@ (specifier-type 'function)))) (values)) - -;;;; hacking function names - -;;; This is like LAMBDA, except the result is tweaked so that FUN-NAME -;;; can extract a name. (Also possibly the name could also be used at -;;; compile time to emit more-informative name-based compiler -;;; diagnostic messages as well.) -(defmacro-mundanely named-lambda (name args &body body) - - ;; FIXME: For now, in this stub version, we just discard the name. A - ;; non-stub version might use either macro-level LOAD-TIME-VALUE - ;; hackery or customized IR1-transform level magic to actually put - ;; the name in place. - (aver (legal-fun-name-p name)) - `(lambda ,args ,@body)) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 451b459..15ae5d0 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -25,10 +25,10 @@ ;;; functions, macros, and special forms (defmethod documentation ((x function) (doc-type (eql 't))) - (function-doc x)) + (%fun-doc x)) (defmethod documentation ((x function) (doc-type (eql 'function))) - (function-doc x)) + (%fun-doc x)) (defmethod documentation ((x list) (doc-type (eql 'function))) ;; FIXME: could test harder to see whether it's a SETF function name, diff --git a/version.lisp-expr b/version.lisp-expr index 02f4b9e..5c0ff8b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.91" +"0.pre7.92"