* 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
;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
- "NAMED-LAMBDA"
"NAMED-LET"
"ONCE-ONLY"
"DEFENUM"
"%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"
"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"
;; 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"))
(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))
;; 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
(/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))
(: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)
(%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))))
\f
;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler
;;;; files for more information.
(in-package "SB!IMPL")
+\f
+;;;; 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)))))
+\f
+;;; various environment inquiries
(defvar *features* '#.sb-cold:*shebang-features*
#!+sb-doc
"a list of symbols that describe features provided by the
implementation")
-\f
-;;; various environment inquiries
(defun machine-instance ()
#!+sb-doc
())
(defknown %setnth (index list t) t (unsafe))
(defknown %set-fill-pointer (vector index) index (unsafe))
+\f
+;;;; miscellaneous internal utilities
+
+(defknown %fun-name (function) t (flushable))
+(defknown (setf %fun-name) (t function) t (unsafe))
(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
(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))))
(specifier-type 'function))))
(values))
-\f
-;;;; 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))
;;; 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,
;;; 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"
projects / sbcl.git / commitdiff