(error "~S is not a defined type class." name)))
(defun must-supply-this (&rest foo)
+ (/show0 "failing in MUST-SUPPLY-THIS")
(error "missing type method for ~S" foo))
;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains
: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
-(defconstant type-class-function-slots
+;;; 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)
(:unparse . type-class-unparse)))
(defun class-function-slot-or-lose (name)
- (or (cdr (assoc name type-class-function-slots))
+ (or (cdr (assoc name *type-class-function-slots*))
(error "~S is not a defined type class method." name)))
;;; FIXME: This seems to be called at runtime by cold init code.
;;; Make sure that it's not being called at runtime anywhere but
) ; EVAL-WHEN
-(defmacro define-type-method ((class method &rest more-methods)
- lambda-list &body body)
- #!+sb-doc
- "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*"
+(defmacro !define-type-method ((class method &rest more-methods)
+ lambda-list &body forms-and-decls)
(let ((name (symbolicate CLASS "-" method "-TYPE-METHOD")))
- `(progn
- (defun ,name ,lambda-list ,@body)
- (!cold-init-forms
- ,@(mapcar #'(lambda (method)
- `(setf (,(class-function-slot-or-lose method)
- (type-class-or-lose ',class))
- #',name))
- (cons method more-methods)))
- ',name)))
-
-(defmacro define-type-class (name &key inherits)
+ (multiple-value-bind (forms decls) (parse-body forms-and-decls)
+ `(progn
+ (defun ,name ,lambda-list
+ ,@decls
+ (block punt-type-method
+ ,@forms))
+ (!cold-init-forms
+ ,@(mapcar #'(lambda (method)
+ `(setf (,(class-function-slot-or-lose method)
+ (type-class-or-lose ',class))
+ #',name))
+ (cons method more-methods)))
+ ',name))))
+
+(defmacro !define-type-class (name &key inherits)
`(!cold-init-forms
,(once-only ((n-class (if inherits
`(copy-type-class-coldly (type-class-or-lose
(setf (gethash ',name *type-classes*) ,n-class)
',name))))
-;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same
-;;; class, invoke the simple method. Otherwise, invoke any complex method. If
-;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when
-;;; calling TYPE1's method. If no applicable method, return DEFAULT.
-(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key
- (default '(values nil t))
- (complex-arg1 :foo complex-arg1-p))
+;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
+;;; same class, invoke the simple method. Otherwise, invoke any
+;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
+;;; then swap the arguments when calling TYPE1's method. If no
+;;; applicable method, return DEFAULT.
+(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
+ (default '(values nil t))
+ (complex-arg1 :foo complex-arg1-p))
(declare (type keyword simple complex-arg1 complex-arg2))
`(multiple-value-bind (result-a result-b valid-p)
(%invoke-type-method ',(class-function-slot-or-lose simple)
(values result-a result-b)
,default)))
-;;; most of the implementation of INVOKE-TYPE-METHOD
+;;; most of the implementation of !INVOKE-TYPE-METHOD
;;;
-;;; KLUDGE: This function must be INLINE in order for cold init to work,
-;;; because the first three arguments are TYPE-CLASS structure accessor
-;;; functions whose calls have to be compiled inline in order to work in calls
-;;; to this function early in cold init. So don't conditionalize this INLINE
-;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things
-;;; to cause the full function definitions of the relevant structure accessors
-;;; to be available sufficiently early in cold init. -- WHN 19991015
-#!-sb-fluid (declaim (inline %invoke-type-method))
+;;; KLUDGE: This function must be INLINE in order for cold init to
+;;; work, because the first three arguments are TYPE-CLASS structure
+;;; accessor functions whose calls have to be compiled inline in order
+;;; to work in calls to this function early in cold init. So don't
+;;; conditionalize this INLINE declaration with #!-SB-FLUID or
+;;; anything, unless you also rearrange things to cause the full
+;;; function definitions of the relevant structure accessors to be
+;;; available sufficiently early in cold init. -- WHN 19991015
+(declaim (inline %invoke-type-method))
(defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
(declare (type symbol simple cslot1 cslot2))
(multiple-value-bind (result-a result-b)
(if complex-arg1-p
(funcall complex1 type1 type2)
(funcall complex1 type2 type1))
- ;; No meaningful result was found: the caller should use the
- ;; default value instead.
+ ;; No meaningful result was found: the caller should
+ ;; use the default value instead.
(return-from %invoke-type-method (values nil nil nil))))))))
- ;; If we get to here (without breaking out by calling RETURN-FROM) then
- ;; a meaningful result was found, and we return it.
+ ;; If we get to here (without breaking out by calling RETURN-FROM)
+ ;; then a meaningful result was found, and we return it.
(values result-a result-b t)))
(!defun-from-collected-cold-init-forms !type-class-cold-init)