;;; also used in EQ comparisons to determined if two types have the
;;; "same kind".
(def!struct (type-class
- #-no-ansi-print-object
- (:print-object (lambda (x stream)
- (print-unreadable-object (x stream :type t)
- (prin1 (type-class-name x) stream)))))
+ #-no-ansi-print-object
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (type-class-name x) stream)))))
;; the name of this type class (used to resolve references at load time)
- (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
+ (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default?
;; Dyadic type methods. If the classes of the two types are EQ, then
;; we call the SIMPLE-xxx method. If the classes are not EQ, and
;; either type's class has a COMPLEX-xxx method, then we call it.
;; be done by just stuffing the two component types into an
;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
;; failure, or a CTYPE for success.
- ;;
+ ;;
;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
(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)
+ ;; a function which returns T if the CTYPE is inhabited by a single
+ ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
+ ;; The default case (NIL) is interpreted as a function that always
+ ;; returns NIL, NIL.
+ (singleton-p nil :type (or function null))
#|
Not used, and not really right. Probably we want a TYPE= alist for the
;; supplying both.
(unary-typep nil :type (or symbol null))
(typep nil :type (or symbol null))
- ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
- ;; type.
+ ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
+ ;; the type.
(unary-coerce nil :type (or symbol null))
(coerce :type (or symbol null))
|#
)
(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
+ ;; will have to be tweaked to match. -- WHN 19991021
+ (defparameter *type-class-fun-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-=)
+ (:negate . type-class-negate)
+ (:unparse . type-class-unparse)
+ (:singleton-p . type-class-singleton-p))))
-;;; 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 LAYOUT-INFO, and LAYOUT-INFO
-;;; isn't initialized early in cold load.)
+(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
+;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
+;;; load.)
;;;
-;;; FIXME: It's nasty having to maintain this hand-written copy function. And
-;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
-;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
-;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
-;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
-;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
-;;; instead. (For even more improvement, it'd be good to move the raw slots
+;;; FIXME: It's nasty having to maintain this hand-written copy
+;;; function. And it seems intrinsically dain-bramaged to have
+;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
+;;; LAYOUT. We should fix this:
+;;; * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
+;;; * Rewrite the various CHECK-LAYOUT-related functions so that
+;;; they check RAW-INDEX and RAW-LENGTH too.
+;;; * Remove this special hacked copy function, just use
+;;; COPY-STRUCTURE instead.
+;;; (For even more improvement, it might be good to move the raw slots
;;; into the same object as the ordinary slots, instead of having the
-;;; unfortunate extra level of indirection. But that'd probably require a lot
-;;; of work, including updating the garbage collector to understand it.)
-(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
+;;; unfortunate extra level of indirection. But that'd probably
+;;; require a lot of work, including updating the garbage collector to
+;;; understand it. And it might even hurt overall performance, because
+;;; 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.)
(defun copy-type-class-coldly (x)
- ;; 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*))
(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)
+ lambda-list &body body)
(let ((name (symbolicate class "-" method "-TYPE-METHOD")))
`(progn
(defun ,name ,lambda-list
- ,@body)
+ ,@body)
(!cold-init-forms
- ,@(mapcar (lambda (method)
- `(setf (,(class-function-slot-or-lose method)
- (type-class-or-lose ',class))
- #',name))
- (cons method more-methods)))
+ ,@(mapcar (lambda (method)
+ `(setf (,(class-fun-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
- ',inherits))
- '(make-type-class))))
- `(progn
- (setf (type-class-name ,n-class) ',name)
- (setf (gethash ',name *type-classes*) ,n-class)
- ',name))))
+ `(copy-type-class-coldly (type-class-or-lose
+ ',inherits))
+ '(make-type-class))))
+ `(progn
+ (setf (type-class-name ,n-class) ',name)
+ (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
;;; suspect is hard, so we'll bear with the old system for the time
;;; being. -- WHN 2001-03-11
(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
- (default '(values nil t))
- (complex-arg1 :foo complex-arg1-p))
+ (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)
- ',(class-function-slot-or-lose
- (if complex-arg1-p
- complex-arg1
- complex-arg2))
- ',(class-function-slot-or-lose complex-arg2)
- ,complex-arg1-p
- ,type1
- ,type2)
- (if valid-p
- (values result-a result-b)
- ,default)))
-
-;;; most of the implementation of !INVOKE-TYPE-METHOD
+ (let ((simple (class-fun-slot-or-lose simple))
+ (cslot1 (class-fun-slot-or-lose
+ (if complex-arg1-p complex-arg1 complex-arg2)))
+ (cslot2 (class-fun-slot-or-lose complex-arg2)))
+ (once-only ((ntype1 type1)
+ (ntype2 type2))
+ (once-only ((class1 `(type-class-info ,ntype1))
+ (class2 `(type-class-info ,ntype2)))
+ `(if (eq ,class1 ,class2)
+ (funcall (,simple ,class1) ,ntype1 ,ntype2)
+ ,(once-only ((complex2 `(,cslot2 ,class2)))
+ `(if ,complex2
+ (funcall ,complex2 ,ntype1 ,ntype2)
+ ,(once-only ((complex1 `(,cslot1 ,class1)))
+ `(if ,complex1
+ (if ,complex-arg1-p
+ (funcall ,complex1 ,ntype1 ,ntype2)
+ (funcall ,complex1 ,ntype2 ,ntype1))
+ ,default)))))))))
+
+;;; This is a very specialized implementation of CLOS-style
+;;; CALL-NEXT-METHOD within our twisty little type class object
+;;; system, which works given that it's called from within a
+;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
+;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
+;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
+;;; so instead of just complacently returning (VALUES NIL NIL) from a
+;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
+;;;
+;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
+;;; everything would Just Work without us having to think about it. In
+;;; our goofy type dispatch system, it's messier to express. It's also
+;;; more fragile, since (0) there's no check that it's called from
+;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
+;;; rely on our global knowledge that the next (and only) relevant
+;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
+;;; knowledge of the appropriate default for the CSUBTYPEP function
+;;; when no next method exists. -- WHN 2002-04-07
;;;
-;;; 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)
- (let ((class1 (type-class-info type1))
- (class2 (type-class-info type2)))
- (if (eq class1 class2)
- (funcall (funcall simple class1) type1 type2)
- (let ((complex2 (funcall cslot2 class2)))
- (if complex2
- (funcall complex2 type1 type2)
- (let ((complex1 (funcall cslot1 class1)))
- (if complex1
- (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.
- (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.
- (values result-a result-b t)))
+;;; (We miss CLOS! -- CSR and WHN)
+(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 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)
projects / sbcl.git / blobdiff