global variables. (thanks to Lars Rune Nøstdal)
* bug fix: foreign function names should now appear in backtraces on
FC6 as well. (reported by Tomasz Skutnik and obias Rautenkranz)
+ * bug fix: SETF compiler macro documentation strings are not discarded
+ anymore.
changes in sbcl-1.0.29 relative to 1.0.28:
* IMPORTANT: bug database has moved from the BUGS file to Launchpad
"POINTER-HASH"
#!+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*"
"PUNT-PRINT-IF-TOO-LONG"
+ "RANDOM-DOCUMENTATION"
"RAW-INSTANCE-SLOTS-EQUALP"
"READER-IMPOSSIBLE-NUMBER-ERROR"
"READER-EOF-ERROR"
Associated with this condition are always the restarts STEP-INTO,
STEP-NEXT, and STEP-CONTINUE."))
-#!+sb-doc
-(setf (fdocumentation 'step-condition-source-path 'function)
- "Source-path of the original form associated with the
-STEP-FORM-CONDITION or NIL."
- (fdocumentation 'step-condition-pathname 'function)
- "Pathname of the original source-file associated with the
-STEP-FORM-CONDITION or NIL.")
-
(define-condition step-result-condition (step-condition)
((result :initarg :result :reader step-condition-result)))
;; FIXME: warn about incompatible lambda list with
;; respect to parent function?
(setf (sb!xc:compiler-macro-function name) definition)
- ;; FIXME: Add support for (SETF FDOCUMENTATION) when
- ;; object is a list and type is COMPILER-MACRO. (Until
- ;; then, we have to discard any compiler macro
- ;; documentation for (SETF FOO).)
- (unless (listp name)
- (setf (fdocumentation name 'compiler-macro) doc))
+ (setf (fdocumentation name 'compiler-macro) doc)
,(when set-p
`(case (widetag-of definition)
(#.sb!vm:closure-header-widetag
(:stream stream) (:use-labels t))
null)
-(defknown fdocumentation (t symbol)
- (or string null)
- (flushable))
-
(defknown describe (t &optional (or stream (member t nil))) (values))
(defknown inspect (t) (values))
(defknown room (&optional (member t nil :default)) (values))
(defknown %set-symbol-value (symbol t) t (unsafe))
(defknown (setf symbol-function) (function symbol) function (unsafe))
(defknown %set-symbol-plist (symbol list) list (unsafe))
-(defknown (setf fdocumentation) ((or string null) t symbol)
- (or string null)
- ())
(defknown %setnth (unsigned-byte list t) t (unsafe)
:destroyed-constant-args (nth-constant-args 2))
(defknown %set-fill-pointer (vector index) index (unsafe)
;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
;;; 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))))))
- (case doc-type
- (variable
- (typecase 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))))))
- (structure
- (typecase x
- (symbol (cond
- ((eq (info :type :kind x) :instance)
- (values (info :type :documentation x)))
- ((info :typed-structure :info x)
- (values (info :typed-structure :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 (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))))
- (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)))))))
+ (case doc-type
+ (variable
+ (typecase x
+ (symbol (values (info :variable :documentation x)))))
+ (function
+ (cond ((functionp x)
+ (%fun-doc x))
+ ((legal-fun-name-p x)
+ (values (info :function :documentation x)))))
+ (structure
+ (typecase x
+ (symbol (cond
+ ((eq (info :type :kind x) :instance)
+ (values (info :type :documentation x)))
+ ((info :typed-structure :info x)
+ (values (info :typed-structure :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 (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))))
+ ((or symbol cons)
+ (random-documentation x doc-type))))
+ (t
+ (when (typep x '(or symbol cons))
+ (random-documentation 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
- ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
- ;; should be done?
+ (declare (type (or null string) string))
(case doc-type
(variable (setf (info :variable :documentation name) string))
- (function (setf (info :function :documentation name) string))
+ (function
+ (when (legal-fun-name-p name)
+ (setf (info :function :documentation name) string)))
(structure (cond
((eq (info :type :kind name) :instance)
(setf (info :type :documentation name) string))
((info :typed-structure :info name)
- (setf (info :typed-structure :documentation name) string))
- (t
- (error "~S is not a structure name." name))))
+ (setf (info :typed-structure :documentation name) string))))
(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))))))
+ (when (typep name '(or symbol cons))
+ (setf (random-documentation name doc-type) string))))
string)
+
+(defun random-documentation (name type)
+ (cdr (assoc type (info :random-documentation :stuff name))))
+
+(defun (setf random-documentation) (new-value name type)
+ (let ((pair (assoc type (info :random-documentation :stuff name))))
+ (if pair
+ (setf (cdr pair) new-value)
+ (push (cons type new-value)
+ (info :random-documentation :stuff name))))
+ new-value)
(define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
(valid-function-name-p (cadr list)))
-(defun sb-pcl::random-documentation (name type)
- (cdr (assoc type (info :random-documentation :stuff name))))
-
-(defun sb-pcl::set-random-documentation (name type new-value)
- (let ((pair (assoc type (info :random-documentation :stuff name))))
- (if pair
- (setf (cdr pair) new-value)
- (push (cons type new-value)
- (info :random-documentation :stuff name))))
- new-value)
-
-(defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation)
-
;;;; SLOT-VALUE optimizations
(defknown slot-value (t symbol) t (any))
(in-package "SB-PCL")
-;;; FIXME: Lots of bare calls to INFO here could be handled
-;;; more cleanly by calling the FDOCUMENTATION function instead.
-
(defun fun-doc (x)
(etypecase x
(generic-function
(random-documentation x 'compiler-macro))
(defmethod documentation ((x symbol) (doc-type (eql 'function)))
- (or (values (info :function :documentation x))
+ (or (fdocumentation x 'function)
;; Try the pcl function documentation.
(and (fboundp x) (documentation (fdefinition x) t))))
(random-documentation x 'compiler-macro))
(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
- (values (info :setf :documentation x)))
+ (fdocumentation x 'setf))
(defmethod documentation ((x symbol) (doc-type (eql 'optimize)))
(random-documentation x 'optimize))
(setf (sb-eval:interpreted-function-documentation x)
new-value))
(function
- (let ((name (%fun-name x)))
- (when (valid-function-name-p name)
- (setf (info :function :documentation name) new-value)))))
+ (setf (focumentation (%fun-name x) 'function) new-value)))
new-value)
(setf (fun-doc x) new-value))
(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
- (setf (info :function :documentation x) new-value))
+ (setf (fdocumentation x 'function) new-value))
(defmethod (setf documentation)
(new-value (x list) (doc-type (eql 'compiler-macro)))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'function)))
- (setf (info :function :documentation x) new-value))
+ (setf (fdocumentation x 'function) new-value))
(defmethod (setf documentation)
(new-value (x symbol) (doc-type (eql 'compiler-macro)))
(setf (random-documentation x 'compiler-macro) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
- (setf (info :setf :documentation x) new-value))
+ (setf (fdocumentation x 'setf) new-value))
\f
;;; method combinations
(defmethod documentation ((x method-combination) (doc-type (eql 't)))
\f
;;; types, classes, and structure names
(defmethod documentation ((x structure-class) (doc-type (eql 't)))
- (values (info :type :documentation (class-name x))))
+ (fdocumentation (class-name x) 'type))
(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
- (values (info :type :documentation (class-name x))))
+ (fdocumentation (class-name x) 'type))
(defmethod documentation ((x standard-class) (doc-type (eql 't)))
(slot-value x '%documentation))
;;; condition-class is in fact not implemented as a standard-class or
;;; structure-class).
(defmethod documentation ((x condition-class) (doc-type (eql 't)))
- (values (info :type :documentation (class-name x))))
+ (fdocumentation (class-name x) 'type))
(defmethod documentation ((x condition-class) (doc-type (eql 'type)))
- (values (info :type :documentation (class-name x))))
+ (fdocumentation (class-name x) 'type))
(defmethod documentation ((x symbol) (doc-type (eql 'type)))
- (or (values (info :type :documentation x))
+ (or (fdocumentation x 'type)
(let ((class (find-class x nil)))
(when class
(slot-value class '%documentation)))))
(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
- (cond
- ((structure-type-p x)
- (values (info :type :documentation x)))
- ((info :typed-structure :info x)
- (values (info :typed-structure :documentation x)))
- (t nil)))
+ (fdocumentation x 'structure))
(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 't)))
- (setf (info :type :documentation (class-name x)) new-value))
+ (setf (fdocumentation (class-name x) 'type) new-value))
(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 'type)))
- (setf (info :type :documentation (class-name x)) new-value))
+ (setf (fdocumentation (class-name x) 'type) new-value))
(defmethod (setf documentation) (new-value
(x standard-class)
(defmethod (setf documentation) (new-value
(x condition-class)
(doc-type (eql 't)))
- (setf (info :type :documentation (class-name x)) new-value))
+ (setf (fdocumentation (class-name x) 'type) new-value))
(defmethod (setf documentation) (new-value
(x condition-class)
(doc-type (eql 'type)))
- (setf (info :type :documentation (class-name x)) new-value))
+ (setf (fdocumentation (class-name x) 'type) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
(if (or (structure-type-p x) (condition-type-p x))
- (setf (info :type :documentation x) new-value)
+ (setf (fdocumentation x 'type) new-value)
(let ((class (find-class x nil)))
(if class
(setf (slot-value class '%documentation) new-value)
- (setf (info :type :documentation x) new-value)))))
+ (setf (fdocumentation x 'type) new-value)))))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'structure)))
- (cond
- ((structure-type-p x)
- (setf (info :type :documentation x) new-value))
- ((info :typed-structure :info x)
- (setf (info :typed-structure :documentation x) new-value))
- (t new-value)))
+ (setf (fdocumentation x 'structure) new-value))
\f
;;; variables
(defmethod documentation ((x symbol) (doc-type (eql 'variable)))
- (values (info :variable :documentation x)))
+ (fdocumentation x 'variable))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'variable)))
- (setf (info :variable :documentation x) new-value))
+ (setf (fdocumentation x 'variable) new-value))
\f
;;; default if DOC-TYPE doesn't match one of the specified types
(defmethod documentation (object doc-type)
(assert (string= (documentation 'frob 'structure) "FROB"))
(setf (documentation 'frob 'structure) "NEW5")
(assert (string= (documentation 'frob 'structure) "NEW5"))
+
+(define-compiler-macro cmacro (x)
+ "compiler macro"
+ x)
+
+(define-compiler-macro (setf cmacro) (y x)
+ "setf compiler macro"
+ y)
+
+(with-test (:name (documentation 'compiler-macro))
+ (unless (equal "compiler macro"
+ (documentation 'cmacro 'compiler-macro))
+ (error "got ~S for cmacro"
+ (documentation 'cmacro 'compiler-macro)))
+ (unless (equal "setf compiler macro"
+ (documentation '(setf cmacro) 'compiler-macro))
+ (error "got ~S for setf macro" (documentation '(setf cmacro) 'compiler-macro))))
\f
;;;; success
projects / sbcl.git / commitdiff