[Sbcl-commits] CVS: sbcl/src/pcl braid.lisp,1.28,1.29 documentation.lisp,1.6,1.7

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv30389/src/pcl

Modified Files:
	braid.lisp documentation.lisp 
Log Message:
0.7.12.47:
	Merge patch from Gerd for improvement to SB-PCL:FIND-CLASS.
	... propagate information through the braid
	... now CLASS-DIRECT-SUPERCLASSES and CLASS-DIRECT-SUBCLASSES
		should agree, even on BUILT-IN-CLASS classes
	Merge patch from Gerd for DISASSEMBLE/COMPILED-FUN-OR-LOSE
	... allow generalized function names
	Also audit the rest of the codebase (by grep for "'setf") and
		fix issues revealed
	... DOCUMENTATION LIST 'FUNCTION (and %DEFUN)
	... EVAL (not actually a real bug)
	... COERCE #!+HIGH-SECURITY
	... %DEFKNOWN
	... LOOP (in possibly dead code, though)


Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- braid.lisp	15 Feb 2003 11:16:34 -0000	1.28
+++ braid.lisp	19 Feb 2003 17:11:39 -0000	1.29
@@ -294,6 +294,22 @@
       (set-slot 'direct-slots direct-slots)
       (set-slot 'slots slots)
       (set-slot 'initialize-info nil))
+
+    ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
+    ;; a direct subclass of SUPER.  Note that METACLASS-NAME doesn't
+    ;; matter here for the slot DIRECT-SUBCLASSES, since every class
+    ;; inherits the slot from class CLASS.
+    (dolist (super direct-supers)
+      (let* ((super (find-class super))
+	     (subclasses (!bootstrap-get-slot metaclass-name super
+					      'direct-subclasses)))
+	(cond ((eq +slot-unbound+ subclasses)
+	       (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+				    (list class)))
+	      ((not (memq class subclasses))
+	       (!bootstrap-set-slot metaclass-name super 'direct-subclasses
+				    (cons class subclasses))))))
+
     (if (eq metaclass-name 'structure-class)
 	(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
 	  (set-slot 'predicate-name (or (cadr (assoc name

Index: documentation.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/documentation.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- documentation.lisp	19 Dec 2001 20:04:10 -0000	1.6
+++ documentation.lisp	19 Feb 2003 17:11:39 -0000	1.7
@@ -31,12 +31,9 @@
   (%fun-doc x))
 
 (defmethod documentation ((x list) (doc-type (eql 'function)))
-  ;; FIXME: could test harder to see whether it's a SETF function name,
-  ;; then call WARN
-  (when (eq (first x) 'setf)	; Give up if not a setf function name.
-    (or (values (info :setf :documentation (second x)))
-	;; Try the pcl function documentation.
-	(and (fboundp x) (documentation (fdefinition x) t)))))
+  (and (legal-fun-name-p x)
+       (fboundp x)
+       (documentation (fdefinition x) t)))
 
 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
   (or (values (info :function :documentation x))
@@ -47,7 +44,7 @@
   (values (info :setf :documentation x)))
 
 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
-  (setf (info :setf :documentation (cadr x)) new-value))
+  (setf (info :function :documentation x) new-value))
 
 (defmethod (setf documentation) (new-value
 				 (x symbol)