0.pre8.6:

[sbcl.git] / src / pcl / braid.lisp

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 25bc778..b256c00 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -65,7 +65,7 @@
                                              (slots-init nil slots-init-p))
   (let ((fin (%make-pcl-funcallable-instance nil nil
                                             (get-instance-hash-code))))
-    (set-funcallable-instance-fun
+    (set-funcallable-instance-function
      fin
      #'(instance-lambda (&rest args)
         (declare (ignore args))
@@ -255,7 +255,8 @@
        (metaclass-name class name
        class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
        &optional
-       proto direct-slots slots direct-default-initargs default-initargs)
+       (proto nil proto-p)
+       direct-slots slots direct-default-initargs default-initargs)
   (flet ((classes (names) (mapcar #'find-class names))
         (set-slot (slot-name value)
           (!bootstrap-set-slot metaclass-name class slot-name value)))
@@ -323,7 +324,8 @@
          (set-slot 'from-defclass-p t)
          (set-slot 'plist nil)
          (set-slot 'prototype (funcall constructor-sym)))
-       (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+       (set-slot 'prototype
+                 (if proto-p proto (allocate-standard-instance wrapper))))
     class))
 
 (defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
@@ -522,8 +524,6 @@
 (defun wrapper-of (x)
   (wrapper-of-macro x))
 
-(defvar *find-structure-class* nil)
-
 (defun eval-form (form)
   (lambda () (eval form)))
 
@@ -536,22 +536,28 @@
     :initform ,(structure-slotd-init-form slotd)
     :initfunction ,(eval-form (structure-slotd-init-form slotd))))
 
-(defun find-structure-class (symbol)
-  (if (structure-type-p symbol)
-      (unless (eq *find-structure-class* symbol)
-       (let ((*find-structure-class* symbol))
-         (ensure-class symbol
-                       :metaclass 'structure-class
-                       :name symbol
-                       :direct-superclasses
-                        (mapcar #'classoid-name
-                                (classoid-direct-superclasses
-                                 (find-classoid symbol)))
-                       :direct-slots
-                       (mapcar #'slot-initargs-from-structure-slotd
-                               (structure-type-slot-description-list
-                                symbol)))))
-      (error "~S is not a legal structure class name." symbol)))
+(defun ensure-non-standard-class (name)
+  (flet
+      ((ensure (metaclass &optional (slots nil slotsp))
+        (let ((supers
+               (mapcar #'classoid-name (classoid-direct-superclasses
+                                        (find-classoid name)))))
+          (if slotsp
+              (ensure-class-using-class name nil
+                                        :metaclass metaclass :name name
+                                        :direct-superclasses supers
+                                        :direct-slots slots)
+              (ensure-class-using-class name nil
+                                        :metaclass metaclass :name name
+                                        :direct-superclasses supers)))))
+    (cond ((structure-type-p name)
+          (ensure 'structure-class
+                  (mapcar #'slot-initargs-from-structure-slotd
+                          (structure-type-slot-description-list name))))
+         ((condition-type-p name)
+          (ensure 'condition-class))
+         (t
+          (error "~@<~S is not the name of a class.~@:>" name)))))
 \f
 (defun make-class-predicate (class name)
   (let* ((gf (ensure-generic-function name))