From 6d94caa24f68a3df5ac73e7072cea3e62e9d87f5 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 7 Apr 2006 11:41:44 +0000 Subject: [PATCH] 0.9.11.18: After Gary King (sbcl-devel 2006-04-06), improve DOCUMENTATION on condition classes. ... also improve the 'STRUCTURE doc-type. ... tests. --- NEWS | 5 ++++ src/code/defstruct.lisp | 5 +++- src/compiler/info-functions.lisp | 17 +++++++---- src/pcl/documentation.lisp | 45 +++++++++++++++++++--------- src/runtime/x86-win32-os.c | 60 +++++++++++++++++++------------------- tests/interface.impure.lisp | 47 +++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 131 insertions(+), 50 deletions(-) diff --git a/NEWS b/NEWS index 8baeaae..d69b943 100644 --- a/NEWS +++ b/NEWS @@ -16,6 +16,11 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11: * fixed bug: Tests for the (VECTOR T) type gave the wrong answer when given a vector displaced to an adjustable array. (reported by Utz-Uwe Haus) + * improvements to DOCUMENTATION for TYPE and STRUCTURE doc-types: + allow condition class objects as arguments to DOCUMENTATION and + (SETF DOCUMENTATION); only find and set documentation for + structure names for the STRUCTURE doc-type. (suggested by Gary + King) * fixed some bugs revealed by Paul Dietz' test suite: ** REMOVE-METHOD returns its generic function argument even when the method is not one of the generic functions' methods. diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2cd30d7..12571a1 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -383,7 +383,10 @@ (append (typed-accessor-definitions dd) (typed-predicate-definitions dd) (typed-copier-definitions dd) - (constructor-definitions dd))) + (constructor-definitions dd) + (when (dd-doc dd) + `((setf (fdocumentation ',(dd-name dd) 'structure) + ',(dd-doc dd)))))) ',name))))) (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index e47f287..2691ab2 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -231,8 +231,11 @@ (fun-name-block-name x)))))) (structure (typecase x - (symbol (when (eq (info :type :kind x) :instance) - (values (info :type :documentation 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)))) @@ -259,9 +262,13 @@ (case doc-type (variable (setf (info :variable :documentation name) string)) (function (setf (info :function :documentation name) string)) - (structure (if (eq (info :type :kind name) :instance) - (setf (info :type :documentation name) string) - (error "~S is not the name of a structure type." name))) + (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)))) (type (setf (info :type :documentation name) string)) (setf (setf (info :setf :documentation name) string)) (t diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 2f1d52b..08687ca 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -137,6 +137,16 @@ (defmethod documentation ((x standard-class) (doc-type (eql 'type))) (slot-value x '%documentation)) +;;; although the CLHS doesn't mention this, it is reasonable to assume +;;; that parallel treatment of condition-class was intended (if +;;; 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)))) + +(defmethod documentation ((x condition-class) (doc-type (eql 'type))) + (values (info :type :documentation (class-name x)))) + (defmethod documentation ((x symbol) (doc-type (eql 'type))) (or (values (info :type :documentation x)) (let ((class (find-class x nil))) @@ -144,12 +154,12 @@ (slot-value class '%documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'structure))) - (cond ((eq (info :type :kind x) :instance) - (values (info :type :documentation x))) - ((info :typed-structure :info x) - (values (info :typed-structure :documentation x))) - (t - nil))) + (cond + ((structure-type-p x) + (values (info :type :documentation x))) + ((info :typed-structure :info x) + (values (info :typed-structure :documentation x))) + (t nil))) (defmethod (setf documentation) (new-value (x structure-class) @@ -171,6 +181,16 @@ (doc-type (eql 'type))) (setf (slot-value x '%documentation) new-value)) +(defmethod (setf documentation) (new-value + (x condition-class) + (doc-type (eql 't))) + (setf (info :type :documentation (class-name x)) new-value)) + +(defmethod (setf documentation) (new-value + (x condition-class) + (doc-type (eql 'type))) + (setf (info :type :documentation (class-name x)) 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) @@ -182,13 +202,12 @@ (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure))) - (cond ((eq (info :type :kind x) :instance) - (setf (info :type :documentation x) new-value)) - ((info :typed-structure :info x) - (setf (info :typed-structure :documentation x) new-value)) - (t - nil))) - + (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))) ;;; variables (defmethod documentation ((x symbol) (doc-type (eql 'variable))) diff --git a/src/runtime/x86-win32-os.c b/src/runtime/x86-win32-os.c index c07d1db..0b15ad2 100644 --- a/src/runtime/x86-win32-os.c +++ b/src/runtime/x86-win32-os.c @@ -44,44 +44,44 @@ size_t os_vm_page_size; int arch_os_thread_init(struct thread *thread) { { - void *top_exception_frame; + void *top_exception_frame; void *cur_stack_end; - void *cur_stack_start; + void *cur_stack_start; asm volatile ("movl %%fs:0,%0": "=r" (top_exception_frame)); asm volatile ("movl %%fs:4,%0": "=r" (cur_stack_end)); - /* - * Can't pull stack start from fs:4 or fs:8 or whatever, - * because that's only what currently has memory behind - * it from being used. Our basic options are to know, - * a priori, what the stack size is (1 meg by default) - * or to grub the default size out of the executable - * header in memory by means of hardcoded addresses and - * offsets. - * - * We'll just assume it's 1 megabyte. Easiest that way. - */ - cur_stack_start = cur_stack_end - 0x100000; - - /* - * We use top_exception_frame rather than cur_stack_end - * to elide the last few (boring) stack entries at the - * bottom of the backtrace. - */ - thread->control_stack_start = cur_stack_start; + /* + * Can't pull stack start from fs:4 or fs:8 or whatever, + * because that's only what currently has memory behind + * it from being used. Our basic options are to know, + * a priori, what the stack size is (1 meg by default) + * or to grub the default size out of the executable + * header in memory by means of hardcoded addresses and + * offsets. + * + * We'll just assume it's 1 megabyte. Easiest that way. + */ + cur_stack_start = cur_stack_end - 0x100000; + + /* + * We use top_exception_frame rather than cur_stack_end + * to elide the last few (boring) stack entries at the + * bottom of the backtrace. + */ + thread->control_stack_start = cur_stack_start; thread->control_stack_end = top_exception_frame; #ifndef LISP_FEATURE_SB_THREAD - /* - * Theoretically, threaded SBCL binds directly against - * the thread structure for these values. We don't do - * threads yet, but we'll probably do the same. We do - * need to reset these, though, because they were - * initialized based on the wrong stack space. - */ - SetSymbolValue(CONTROL_STACK_START,(lispobj)thread->control_stack_start,thread); - SetSymbolValue(CONTROL_STACK_END,(lispobj)thread->control_stack_end,thread); + /* + * Theoretically, threaded SBCL binds directly against + * the thread structure for these values. We don't do + * threads yet, but we'll probably do the same. We do + * need to reset these, though, because they were + * initialized based on the wrong stack space. + */ + SetSymbolValue(CONTROL_STACK_START,(lispobj)thread->control_stack_start,thread); + SetSymbolValue(CONTROL_STACK_END,(lispobj)thread->control_stack_end,thread); #endif } diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index ea21552..8b19a64 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -79,4 +79,51 @@ (error "misbehavior in DESCRIBE of ~S" i)))) +;;; Tests of documentation on types and classes +(defclass foo () + () + (:documentation "FOO")) +(defstruct bar "BAR") +(define-condition baz () + () + (:documentation "BAZ")) +(deftype quux () + "QUUX" + 't) +(defstruct (frob (:type vector)) "FROB") +(macrolet + ((do-class (name expected &optional structurep) + `(progn + (assert (string= (documentation ',name 'type) ,expected)) + (assert (string= (documentation (find-class ',name) 'type) ,expected)) + (assert (string= (documentation (find-class ',name) 't) ,expected)) + ,@(when structurep + `((assert (string= (documentation ',name 'structure) ,expected)))) + (let ((new1 (symbol-name (gensym "NEW1"))) + (new2 (symbol-name (gensym "NEW2"))) + (new3 (symbol-name (gensym "NEW3"))) + (new4 (symbol-name (gensym "NEW4")))) + (declare (ignorable new4)) + (setf (documentation ',name 'type) new1) + (assert (string= (documentation (find-class ',name) 'type) new1)) + (setf (documentation (find-class ',name) 'type) new2) + (assert (string= (documentation (find-class ',name) 't) new2)) + (setf (documentation (find-class ',name) 't) new3) + (assert (string= (documentation ',name 'type) new3)) + ,@(when structurep + `((assert (string= (documentation ',name 'structure) new3)) + (setf (documentation ',name 'structure) new4) + (assert (string= (documentation ',name 'structure) new4)))))))) + (do-class foo "FOO") + (do-class bar "BAR" t) + (do-class baz "BAZ")) + +(assert (string= (documentation 'quux 'type) "QUUX")) +(setf (documentation 'quux 'type) "NEW4") +(assert (string= (documentation 'quux 'type) "NEW4")) + +(assert (string= (documentation 'frob 'structure) "FROB")) +(setf (documentation 'frob 'structure) "NEW5") +(assert (string= (documentation 'frob 'structure) "NEW5")) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index cfae898..b8c2988 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".) -"0.9.11.17" +"0.9.11.18" -- 1.7.10.4