(complex-intersection2 nil :type (or function null))
(simple-= #'must-supply-this :type function)
(complex-= nil :type (or function null))
+ ;; monadic functions
+ (negate #'must-supply-this :type function)
;; a function which returns a Common Lisp type specifier
;; representing this type
(unparse #'must-supply-this :type function)
(:complex-intersection2 . type-class-complex-intersection2)
(:simple-= . type-class-simple-=)
(:complex-= . type-class-complex-=)
+ (:negate . type-class-negate)
(:unparse . type-class-unparse))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
+(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; Copy TYPE-CLASS object X, using only operations which will work
;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
;;; because it needs RAW-INDEX and RAW-LENGTH information from
;;; the positive effect of removing indirection could be cancelled by
;;; the negative effect of imposing an unnecessary GC write barrier on
;;; raw data which doesn't actually affect GC.)
-(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
(defun copy-type-class-coldly (x)
;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
;;; when no next method exists. -- WHN 2002-04-07
;;;
;;; (We miss CLOS! -- CSR and WHN)
-(defun invoke-complex-subtypep-arg1-method (type1 type2)
+(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
(let* ((type-class (type-class-info type1))
(method-fun (type-class-complex-subtypep-arg1 type-class)))
(if method-fun
(funcall (the function method-fun) type1 type2)
- (values nil nil))))
+ (values subtypep win))))
+
+;;; KLUDGE: This function is dangerous, as its overuse could easily
+;;; cause stack exhaustion through unbounded recursion. We only use
+;;; it in one place; maybe it ought not to be a function at all?
+(defun invoke-complex-=-other-method (type1 type2)
+ (let* ((type-class (type-class-info type1))
+ (method-fun (type-class-complex-= type-class)))
+ (if method-fun
+ (funcall (the function method-fun) type2 type1)
+ (values nil t))))
(!defun-from-collected-cold-init-forms !type-class-cold-init)