From c593dc26733b179db6c12c7085ed76b762ac256b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 20 Jun 2009 11:37:25 +0000 Subject: [PATCH] 1.0.29.22: smattering of DOCUMENTATION cleanups * Delete stale function documentation: STEP-CONDITION-SOURCE-PATH and STEP-CONDITION-PATHNAME no longer exist. * Move RANDOM-DOCUMENTATION to SB-KERNEL, use it in FDOCUMENTATION. * Replace bare INFO calls from DOCUMENTATION methods with calls to FDOCUMENTATION, as per FIXME. * Make FDOCUMENTATION work on '(SETF FOO) names, and delete the DEFKNOWNs for it. --- NEWS | 2 + package-data-list.lisp-expr | 1 + src/code/condition.lisp | 8 --- src/code/macros.lisp | 7 +-- src/compiler/fndb.lisp | 7 --- src/compiler/info-functions.lisp | 106 ++++++++++++++++++-------------------- src/pcl/compiler-support.lisp | 13 ----- src/pcl/documentation.lisp | 57 ++++++++------------ tests/interface.impure.lisp | 17 ++++++ 9 files changed, 92 insertions(+), 126 deletions(-) diff --git a/NEWS b/NEWS index 960c984..8bd29ad 100644 --- a/NEWS +++ b/NEWS @@ -30,6 +30,8 @@ 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2d839e2..2926841 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1575,6 +1575,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 317d8bc..7592df6 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1281,14 +1281,6 @@ holds the source-path to the original form within that file or NIL. 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))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index f9f2bd3..5365f83 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -152,12 +152,7 @@ invoked. In that case it will store into PLACE and start over." ;; 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 diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 0b553f5..a070e62 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1320,10 +1320,6 @@ (: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)) @@ -1535,9 +1531,6 @@ (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) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 685d3b7..293b123 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -222,70 +222,64 @@ return NIL. Can be set with SETF when ENV is NIL." ;;; 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) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index e00deee..f7da509 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -86,19 +86,6 @@ (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)) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index cb4c2a7..281d94e 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -8,9 +8,6 @@ (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 @@ -37,7 +34,7 @@ (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)))) @@ -45,7 +42,7 @@ (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)) @@ -59,9 +56,7 @@ (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) @@ -74,7 +69,7 @@ (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))) @@ -83,14 +78,14 @@ (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)) ;;; method combinations (defmethod documentation ((x method-combination) (doc-type (eql 't))) @@ -141,10 +136,10 @@ ;;; 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)) @@ -157,34 +152,29 @@ ;;; 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) @@ -199,39 +189,34 @@ (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)) ;;; 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)) ;;; default if DOC-TYPE doesn't match one of the specified types (defmethod documentation (object doc-type) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index 60795ad..1b7978b 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -168,5 +168,22 @@ (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)))) ;;;; success -- 1.7.10.4