- ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
- ;; to be hand-tweaked to match. -- WHN 19991021
- (make-type-class :name (type-class-name x)
- :simple-subtypep (type-class-simple-subtypep x)
- :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
- :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
- :simple-union2 (type-class-simple-union2 x)
- :complex-union2 (type-class-complex-union2 x)
- :simple-intersection2 (type-class-simple-intersection2 x)
- :complex-intersection2 (type-class-complex-intersection2 x)
- :simple-= (type-class-simple-= x)
- :complex-= (type-class-complex-= x)
- :unparse (type-class-unparse x)))
-
-;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
-;;; will have to be tweaked to match. -- WHN 19991021
-(defparameter *type-class-function-slots*
- '((:simple-subtypep . type-class-simple-subtypep)
- (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
- (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
- (:simple-union2 . type-class-simple-union2)
- (:complex-union2 . type-class-complex-union2)
- (:simple-intersection2 . type-class-simple-intersection2)
- (:complex-intersection2 . type-class-complex-intersection2)
- (:simple-= . type-class-simple-=)
- (:complex-= . type-class-complex-=)
- (:unparse . type-class-unparse)))
-
-(defun class-function-slot-or-lose (name)
- (or (cdr (assoc name *type-class-function-slots*))
+ ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
+ ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
+ ;; have to be hand-tweaked to match. -- WHN 2001-03-19
+ (make-type-class :name (type-class-name x)
+ . #.(mapcan (lambda (type-class-fun-slot)
+ (destructuring-bind (keyword . slot-accessor)
+ type-class-fun-slot
+ `(,keyword (,slot-accessor x))))
+ *type-class-fun-slots*)))
+
+(defun class-fun-slot-or-lose (name)
+ (or (cdr (assoc name *type-class-fun-slots*))