src/code/type-class.lisp

   1 ;;;; stuff related to the TYPE-CLASS structure
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (!begin-collecting-cold-init-forms)
  15
  16 (defvar *type-classes*)
  17 (!cold-init-forms
  18   (unless (boundp '*type-classes*) ; FIXME: How could this be bound?
  19     (setq *type-classes* (make-hash-table :test 'eq))))
  20
  21 (defun type-class-or-lose (name)
  22   (or (gethash name *type-classes*)
  23       (error "~S is not a defined type class." name)))
  24
  25 (defun must-supply-this (&rest foo)
  26   (error "missing type method for ~S" foo))
  27
  28 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains
  29 ;;; functions which are methods on that kind of type, but is also used in EQ
  30 ;;; comparisons to determined if two types have the "same kind".
  31 (def!struct (type-class
  32              #-no-ansi-print-object
  33              (:print-object (lambda (x stream)
  34                               (print-unreadable-object (x stream :type t)
  35                                 (prin1 (type-class-name x) stream)))))
  36   ;; the name of this type class (used to resolve references at load time)
  37   (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
  38   ;; Dyadic type methods. If the classes of the two types are EQ, then
  39   ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
  40   ;; either type's class has a COMPLEX-xxx method, then we call it.
  41   ;;
  42   ;; Although it is undefined which method will get precedence when
  43   ;; both types have a complex method, the complex method can assume
  44   ;; that the second arg always is in its class, and the first always
  45   ;; is not. The arguments to commutative operations will be swapped
  46   ;; if the first argument has a complex method.
  47   ;;
  48   ;; Since SUBTYPEP is not commutative, we have two complex methods.
  49   ;; The ARG1 method is only called when the first argument is in its
  50   ;; class, and the ARG2 method is only called when called when the
  51   ;; second type is. If either is specified, both must be.
  52   (simple-subtypep #'must-supply-this :type function)
  53   (complex-subtypep-arg1 nil :type (or function null))
  54   (complex-subtypep-arg2 nil :type (or function null))
  55   ;; SIMPLE-UNION combines two types of the same class into a single
  56   ;; type of that class. If the result is a two-type union, then
  57   ;; return NIL. VANILLA-UNION returns whichever argument is a
  58   ;; supertype of the other, or NIL.
  59   (simple-union #'vanilla-union :type function)
  60   (complex-union nil :type (or function null))
  61   ;; The default intersection methods assume that if one type is a
  62   ;; subtype of the other, then that type is the intersection.
  63   (simple-intersection #'vanilla-intersection :type function)
  64   (complex-intersection nil :type (or function null))
  65   (simple-= #'must-supply-this :type function)
  66   (complex-= nil :type (or function null))
  67   ;; a function which returns a Common Lisp type specifier
  68   ;; representing this type
  69   (unparse #'must-supply-this :type function)
  70
  71   #|
  72   Not used, and not really right. Probably we want a TYPE= alist for the
  73   unary operations, since there are lots of interesting unary predicates that
  74   aren't equivalent to an entire class
  75   ;; Names of functions used for testing the type of objects in this type
  76   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
  77   ;; passed both the object and the CTYPE. Normally one or the other will be
  78   ;; supplied for any type that can be passed to TYPEP; there is no point in
  79   ;; supplying both.
  80   (unary-typep nil :type (or symbol null))
  81   (typep nil :type (or symbol null))
  82   ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
  83   ;; type.
  84   (unary-coerce nil :type (or symbol null))
  85   (coerce :type (or symbol null))
  86   |#
  87   )
  88
  89 (eval-when (:compile-toplevel :load-toplevel :execute)
  90
  91 ;;; Copy TYPE-CLASS object X, using only operations which will work early in
  92 ;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs
  93 ;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO
  94 ;;; isn't initialized early in cold load.)
  95 ;;;
  96 ;;; FIXME: It's nasty having to maintain this hand-written copy function. And
  97 ;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
  98 ;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
  99 ;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
 100 ;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
 101 ;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
 102 ;;; instead. (For even more improvement, it'd be good to move the raw slots
 103 ;;; into the same object as the ordinary slots, instead of having the
 104 ;;; unfortunate extra level of indirection. But that'd probably require a lot
 105 ;;; of work, including updating the garbage collector to understand it.)
 106 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 107 (defun copy-type-class-coldly (x)
 108   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
 109   ;; to be hand-tweaked to match. -- WHN 19991021
 110   (make-type-class :name (type-class-name x)
 111                    :simple-subtypep       (type-class-simple-subtypep x)
 112                    :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
 113                    :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
 114                    :simple-union          (type-class-simple-union x)
 115                    :complex-union        (type-class-complex-union x)
 116                    :simple-intersection   (type-class-simple-intersection x)
 117                    :complex-intersection  (type-class-complex-intersection x)
 118                    :simple-=          (type-class-simple-= x)
 119                    :complex-=        (type-class-complex-= x)
 120                    :unparse            (type-class-unparse x)))
 121
 122 ;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 123 ;;; will have to be tweaked to match. -- WHN 19991021
 124 (defparameter *type-class-function-slots*
 125   '((:simple-subtypep . type-class-simple-subtypep)
 126     (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 127     (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 128     (:simple-union . type-class-simple-union)
 129     (:complex-union . type-class-complex-union)
 130     (:simple-intersection . type-class-simple-intersection)
 131     (:complex-intersection . type-class-complex-intersection)
 132     (:simple-= . type-class-simple-=)
 133     (:complex-= . type-class-complex-=)
 134     (:unparse . type-class-unparse)))
 135
 136 (defun class-function-slot-or-lose (name)
 137   (or (cdr (assoc name *type-class-function-slots*))
 138       (error "~S is not a defined type class method." name)))
 139 ;;; FIXME: This seems to be called at runtime by cold init code.
 140 ;;; Make sure that it's not being called at runtime anywhere but
 141 ;;; one-time toplevel initialization code.
 142
 143 ) ; EVAL-WHEN
 144
 145 (defmacro define-type-method ((class method &rest more-methods)
 146                               lambda-list &body body)
 147   #!+sb-doc
 148   "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*"
 149   (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD")))
 150     `(progn
 151        (defun ,name ,lambda-list ,@body)
 152        (!cold-init-forms
 153          ,@(mapcar #'(lambda (method)
 154                        `(setf (,(class-function-slot-or-lose method)
 155                                (type-class-or-lose ',class))
 156                               #',name))
 157                    (cons method more-methods)))
 158        ',name)))
 159
 160 (defmacro define-type-class (name &key inherits)
 161   `(!cold-init-forms
 162      ,(once-only ((n-class (if inherits
 163                                `(copy-type-class-coldly (type-class-or-lose
 164                                                          ',inherits))
 165                                '(make-type-class))))
 166         `(progn
 167            (setf (type-class-name ,n-class) ',name)
 168            (setf (gethash ',name *type-classes*) ,n-class)
 169            ',name))))
 170
 171 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same
 172 ;;; class, invoke the simple method. Otherwise, invoke any complex method. If
 173 ;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when
 174 ;;; calling TYPE1's method. If no applicable method, return DEFAULT.
 175 (defmacro invoke-type-method (simple complex-arg2 type1 type2 &key
 176                                      (default '(values nil t))
 177                                      (complex-arg1 :foo complex-arg1-p))
 178   (declare (type keyword simple complex-arg1 complex-arg2))
 179   `(multiple-value-bind (result-a result-b valid-p)
 180        (%invoke-type-method ',(class-function-slot-or-lose simple)
 181                             ',(class-function-slot-or-lose
 182                                (if complex-arg1-p
 183                                  complex-arg1
 184                                  complex-arg2))
 185                             ',(class-function-slot-or-lose complex-arg2)
 186                             ,complex-arg1-p
 187                             ,type1
 188                             ,type2)
 189      (if valid-p
 190        (values result-a result-b)
 191        ,default)))
 192
 193 ;;; most of the implementation of INVOKE-TYPE-METHOD
 194 ;;;
 195 ;;; KLUDGE: This function must be INLINE in order for cold init to work,
 196 ;;; because the first three arguments are TYPE-CLASS structure accessor
 197 ;;; functions whose calls have to be compiled inline in order to work in calls
 198 ;;; to this function early in cold init. So don't conditionalize this INLINE
 199 ;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things
 200 ;;; to cause the full function definitions of the relevant structure accessors
 201 ;;; to be available sufficiently early in cold init. -- WHN 19991015
 202 #!-sb-fluid (declaim (inline %invoke-type-method))
 203 (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
 204   (declare (type symbol simple cslot1 cslot2))
 205   (multiple-value-bind (result-a result-b)
 206       (let ((class1 (type-class-info type1))
 207             (class2 (type-class-info type2)))
 208         (if (eq class1 class2)
 209           (funcall (funcall simple class1) type1 type2)
 210           (let ((complex2 (funcall cslot2 class2)))
 211             (if complex2
 212               (funcall complex2 type1 type2)
 213               (let ((complex1 (funcall cslot1 class1)))
 214                 (if complex1
 215                   (if complex-arg1-p
 216                     (funcall complex1 type1 type2)
 217                     (funcall complex1 type2 type1))
 218                   ;; No meaningful result was found: the caller should use the
 219                   ;; default value instead.
 220                   (return-from %invoke-type-method (values nil nil nil))))))))
 221     ;; If we get to here (without breaking out by calling RETURN-FROM) then
 222     ;; a meaningful result was found, and we return it.
 223     (values result-a result-b t)))
 224
 225 (!defun-from-collected-cold-init-forms !type-class-cold-init)