X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftype-class.lisp;h=fcd47069489fc4026a9a064d61bf626cf130785b;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=ee4bf5fc6ccfc71e486ab354cfb2c27c89df9144;hpb=143edab8d233c784cde14bce6c5165219ea84bf4;p=sbcl.git diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index ee4bf5f..fcd4706 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -36,7 +36,7 @@ (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. @@ -85,6 +85,8 @@ (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) @@ -100,8 +102,8 @@ ;; 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)) |# @@ -110,7 +112,7 @@ (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-function-slots* + (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) @@ -120,10 +122,11 @@ (: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 @@ -147,20 +150,19 @@ ;;; 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-FUNCTION-SLOTS*, the slots here will + ;; 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-function-slot) + (make-type-class :name (type-class-name x) + . #.(mapcan (lambda (type-class-fun-slot) (destructuring-bind (keyword . slot-accessor) - type-class-function-slot + type-class-fun-slot `(,keyword (,slot-accessor x)))) - *type-class-function-slots*))) + *type-class-fun-slots*))) -(defun class-function-slot-or-lose (name) - (or (cdr (assoc name *type-class-function-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 @@ -176,7 +178,7 @@ ,@body) (!cold-init-forms ,@(mapcar (lambda (method) - `(setf (,(class-function-slot-or-lose method) + `(setf (,(class-fun-slot-or-lose method) (type-class-or-lose ',class)) #',name)) (cons method more-methods))) @@ -211,18 +213,18 @@ (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 + (%invoke-type-method ',(class-fun-slot-or-lose simple) + ',(class-fun-slot-or-lose (if complex-arg1-p - complex-arg1 - complex-arg2)) - ',(class-function-slot-or-lose complex-arg2) + complex-arg1 + complex-arg2)) + ',(class-fun-slot-or-lose complex-arg2) ,complex-arg1-p ,type1 ,type2) (if valid-p - (values result-a result-b) - ,default))) + (values result-a result-b) + ,default))) ;;; most of the implementation of !INVOKE-TYPE-METHOD ;;; @@ -241,20 +243,60 @@ (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)))))))) + (funcall (the function (funcall simple class1)) type1 type2) + (let ((complex2 (funcall cslot2 class2))) + (declare (type (or function null) complex2)) + (if complex2 + (funcall complex2 type1 type2) + (let ((complex1 (funcall cslot1 class1))) + (declare (type (or function null) complex1)) + (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))) +;;; 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 +;;; +;;; (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)