Changeset 285

Timestamp:

Jan 13, 2004, 5:06:25 PM (21 years ago)

Author:

Gary Byers

Message:

Recognize that SLOT-MISSING might return if it's specialized. Call it with
the symbol SETF, not '(SETF SLOT-VALUE).

File:

• trunk/ccl/level-1/l1-clos-boot.lisp (modified) (11 diffs)

trunk/ccl/level-1/l1-clos-boot.lisp

@@ -176 +176 @@
            instance slot-id))
 (defun %slot-id-ref-missing (instance slot-id)
-  (slot-missing (class-of instance) instance (slot-id.name slot-id) 'slot-value))
+  (values (slot-missing (class-of instance) instance (slot-id.name slot-id) 'slot-value)))
 
 (defun %slot-id-set-obsolete (instance slot-id new-value)
@@ -184 +184 @@
 
 (defun %slot-id-set-missing (instance slot-id new-value)
-  (slot-missing (class-of instance) instance (slot-id.name slot-id) '(setf slot-value) new-value))
+  (slot-missing (class-of instance) instance (slot-id.name slot-id) 'setf new-value)
+  new-value
+  )
 
 
@@ -550 +552 @@
     (when (and def (not (typep def 'generic-function)))
       (cerror "Try to remove any global non-generic function or macro definition."
-              "~s is defined as something other than a generic function." function-name)
+              (make-condition 'simple-program-error :format-control "The functio ~s is defined as something other than a generic function." :format-arguments (list function-name)))
       (fmakunbound function-name)
       (setq def nil))
@@ -1063 +1065 @@
                  nil
                  nil
-                 #'(lambda (x y) (vanilla-union x y))
+                 #'(lambda (x y) (hierarchical-union2 x y))
                  nil
-                 #'(lambda (x y) (vanilla-intersection x y))
+                 #'(lambda (x y) (hierarchical-intersection2 x y))
                  nil
                  #'missing-type-method
@@ -1101 +1103 @@
 (new-type-class 'foreign)
 (new-type-class 'cons)
+(new-type-class 'intersection)
+(new-type-class 'negation)
 (defparameter *class-type-class* (new-type-class 'class))
 
@@ -1585 +1589 @@
 (make-built-in-class 'foreign-ctype *ctype-class*)
 (make-built-in-class 'class-ctype *ctype-class*)
+(make-built-in-class 'negation-ctype *ctype-class*)
+(make-built-in-class 'intersection-ctype *ctype-class*)
 
 
@@ -2294 +2300 @@
       (if slotd
         (slot-value-using-class class instance slotd)
-        (slot-missing class instance slot-name 'slot-value))))
+        (values (slot-missing class instance slot-name 'slot-value)))))
     
 
@@ -2320 +2326 @@
         (if slotd
           (setf (slot-value-using-class class instance slotd) value)
-          (slot-missing class instance name '(setf slot-value) value))))
+          (progn            
+            (slot-missing class instance name 'setf value)
+            value))))
 
 (defsetf slot-value set-slot-value)
 
 (defun slot-makunbound (instance name)
-    (let* ((class (class-of instance))
-           (slotd (find-slotd name (%class-slots class))))
-      (if slotd
-        (slot-makunbound-using-class class instance slotd)
-        (slot-missing class instance name 'slot-makunbound))))
+  (let* ((class (class-of instance))
+         (slotd (find-slotd name (%class-slots class))))
+    (if slotd
+      (slot-makunbound-using-class class instance slotd)
+      (slot-missing class instance name 'slot-makunbound))
+    instance))
 
 (defun %std-slot-vector-boundp (slot-vector slotd)
@@ -2359 +2368 @@
     (if slotd
       (slot-boundp-using-class class instance slotd)
-      (slot-missing class instance name 'slot-boundp))))
+      (values (slot-missing class instance name 'slot-boundp)))))
 
 (defun slot-value-if-bound (instance name &optional default)
@@ -2648 +2657 @@
             (if bad-keys?
               (if errorp
-                (error #'(lambda (stream key name class vect)
-                           (let ((*print-array* t))
-                             (format stream 
-                                     "~s is an invalid initarg to ~s for ~s.~%~
+                (signal-program-error
+                 "~s is an invalid initarg to ~s for ~s.~%~
                                     Valid initargs: ~s."
-                                     key name class vect)))
-                       bad-key (function-name (car functions)) class initvect)
+                 bad-key
+                 (function-name (car functions))
+                 class (coerce initvect 'list))
                 (values bad-keys? bad-key))))
         (if (eq initarg :allow-other-keys)
@@ -3075 +3083 @@
   (cond ((equal apo req) nil)
         ((not (eql (length apo) (length req)))
-         (error "Lengths of ~S and ~S differ." apo req))
+         (signal-program-error "Lengths of ~S and ~S differ." apo req))
         (t (let ((res nil))
              (dolist (arg apo (nreverse res))