* 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.
(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)
(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))))
(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
(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)))
(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)
(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)
(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)))
\f
;;; variables
(defmethod documentation ((x symbol) (doc-type (eql 'variable)))
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
}
(error "misbehavior in DESCRIBE of ~S" i))))
\f
+;;; 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"))
+\f
;;;; success
;;; 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"
projects / sbcl.git / commitdiff