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   (/show0 "failing in MUST-SUPPLY-THIS")
  27   (error "missing type method for ~S" foo))
  28
  29 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
  30 ;;; contains functions which are methods on that kind of type, but is
  31 ;;; also used in EQ comparisons to determined if two types have the
  32 ;;; "same kind".
  33 (def!struct (type-class
  34              #-no-ansi-print-object
  35              (:print-object (lambda (x stream)
  36                               (print-unreadable-object (x stream :type t)
  37                                 (prin1 (type-class-name x) stream)))))
  38   ;; the name of this type class (used to resolve references at load time)
  39   (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
  40   ;; Dyadic type methods. If the classes of the two types are EQ, then
  41   ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
  42   ;; either type's class has a COMPLEX-xxx method, then we call it.
  43   ;;
  44   ;; Although it is undefined which method will get precedence when
  45   ;; both types have a complex method, the complex method can assume
  46   ;; that the second arg always is in its class, and the first always
  47   ;; is not. The arguments to commutative operations will be swapped
  48   ;; if the first argument has a complex method.
  49   ;;
  50   ;; Since SUBTYPEP is not commutative, we have two complex methods.
  51   ;; The ARG1 method is only called when the first argument is in its
  52   ;; class, and the ARG2 method is only called when called when the
  53   ;; second type is. If either is specified, both must be.
  54   (simple-subtypep #'must-supply-this :type function)
  55   (complex-subtypep-arg1 nil :type (or function null))
  56   (complex-subtypep-arg2 nil :type (or function null))
  57   ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
  58   ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
  59   ;; a new type which expresses the result nicely, better than could
  60   ;; be done by just stuffing the two component types into an
  61   ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
  62   ;; failure, or a CTYPE for success.
  63   ;;
  64   ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
  65   ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
  66   ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
  67   ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
  68   ;; wants to simplify unions and intersections by considering all
  69   ;; possible pairwise simplifications (where the CMU CL code only
  70   ;; considered simplifications between types which happened to appear
  71   ;; next to each other the argument sequence).
  72   ;;
  73   ;; Differences in detail from old CMU CL methods:
  74   ;;   * SBCL's methods are more parallel between union and
  75   ;;     intersection forms. Each returns one values, (OR NULL CTYPE).
  76   ;;   * SBCL doesn't use type methods to deal with unions or
  77   ;;     intersections of the COMPOUND-TYPE of the corresponding form.
  78   ;;     Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
  79   ;;     TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
  80   ;;     (and deal with canonicalization/simplification issues at the
  81   ;;     same time).
  82   ;;
  83   ;; FIXME: SIMPLE-UNION and COMPLEX-UNION methods haven't been
  84   ;; converted to the new scheme yet. (Thus they never return NIL, I
  85   ;; think. -- WHN 2001-03-11)
  86   (simple-union #'vanilla-union :type function)
  87   (complex-union nil :type (or function null))
  88   (simple-intersection2 #'hierarchical-intersection2 :type function)
  89   (complex-intersection2 nil :type (or function null))
  90   (simple-= #'must-supply-this :type function)
  91   (complex-= nil :type (or function null))
  92   ;; a function which returns a Common Lisp type specifier
  93   ;; representing this type
  94   (unparse #'must-supply-this :type function)
  95
  96   #|
  97   Not used, and not really right. Probably we want a TYPE= alist for the
  98   unary operations, since there are lots of interesting unary predicates that
  99   aren't equivalent to an entire class
 100   ;; Names of functions used for testing the type of objects in this type
 101   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
 102   ;; passed both the object and the CTYPE. Normally one or the other will be
 103   ;; supplied for any type that can be passed to TYPEP; there is no point in
 104   ;; supplying both.
 105   (unary-typep nil :type (or symbol null))
 106   (typep nil :type (or symbol null))
 107   ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
 108   ;; type.
 109   (unary-coerce nil :type (or symbol null))
 110   (coerce :type (or symbol null))
 111   |#
 112   )
 113
 114 (eval-when (:compile-toplevel :load-toplevel :execute)
 115
 116 ;;; Copy TYPE-CLASS object X, using only operations which will work early in
 117 ;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs
 118 ;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO
 119 ;;; isn't initialized early in cold load.)
 120 ;;;
 121 ;;; FIXME: It's nasty having to maintain this hand-written copy function. And
 122 ;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
 123 ;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
 124 ;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
 125 ;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
 126 ;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
 127 ;;; instead. (For even more improvement, it'd be good to move the raw slots
 128 ;;; into the same object as the ordinary slots, instead of having the
 129 ;;; unfortunate extra level of indirection. But that'd probably require a lot
 130 ;;; of work, including updating the garbage collector to understand it.)
 131 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 132 (defun copy-type-class-coldly (x)
 133   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
 134   ;; to be hand-tweaked to match. -- WHN 19991021
 135   (make-type-class :name                  (type-class-name x)
 136                    :simple-subtypep       (type-class-simple-subtypep x)
 137                    :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
 138                    :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
 139                    :simple-union          (type-class-simple-union x)
 140                    :complex-union         (type-class-complex-union x)
 141                    :simple-intersection2  (type-class-simple-intersection2 x)
 142                    :complex-intersection2 (type-class-complex-intersection2 x)
 143                    :simple-=              (type-class-simple-= x)
 144                    :complex-=             (type-class-complex-= x)
 145                    :unparse               (type-class-unparse x)))
 146
 147 ;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 148 ;;; will have to be tweaked to match. -- WHN 19991021
 149 (defparameter *type-class-function-slots*
 150   '((:simple-subtypep . type-class-simple-subtypep)
 151     (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 152     (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 153     (:simple-union . type-class-simple-union)
 154     (:complex-union . type-class-complex-union)
 155     (:simple-intersection2 . type-class-simple-intersection2)
 156     (:complex-intersection2 . type-class-complex-intersection2)
 157     (:simple-= . type-class-simple-=)
 158     (:complex-= . type-class-complex-=)
 159     (:unparse . type-class-unparse)))
 160
 161 (defun class-function-slot-or-lose (name)
 162   (or (cdr (assoc name *type-class-function-slots*))
 163       (error "~S is not a defined type class method." name)))
 164 ;;; FIXME: This seems to be called at runtime by cold init code.
 165 ;;; Make sure that it's not being called at runtime anywhere but
 166 ;;; one-time toplevel initialization code.
 167
 168 ) ; EVAL-WHEN
 169
 170 (defmacro !define-type-method ((class method &rest more-methods)
 171                                lambda-list &body body)
 172   (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
 173     `(progn
 174        (defun ,name ,lambda-list
 175          ,@body)
 176        (!cold-init-forms
 177         ,@(mapcar (lambda (method)
 178                     `(setf (,(class-function-slot-or-lose method)
 179                             (type-class-or-lose ',class))
 180                            #',name))
 181                   (cons method more-methods)))
 182        ',name)))
 183
 184 (defmacro !define-type-class (name &key inherits)
 185   `(!cold-init-forms
 186      ,(once-only ((n-class (if inherits
 187                                `(copy-type-class-coldly (type-class-or-lose
 188                                                          ',inherits))
 189                                '(make-type-class))))
 190         `(progn
 191            (setf (type-class-name ,n-class) ',name)
 192            (setf (gethash ',name *type-classes*) ,n-class)
 193            ',name))))
 194
 195 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
 196 ;;; same class, invoke the simple method. Otherwise, invoke any
 197 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
 198 ;;; then swap the arguments when calling TYPE1's method. If no
 199 ;;; applicable method, return DEFAULT.
 200 ;;;
 201 ;;; KLUDGE: It might be a lot easier to understand this and the rest
 202 ;;; of the type system code if we used CLOS to express it instead of
 203 ;;; trying to maintain this squirrely hand-crufted object system.
 204 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
 205 ;;; all the compilation can get done by the cross-compiler, which I
 206 ;;; suspect is hard, so we'll bear with the old system for the time
 207 ;;; being. -- WHN 2001-03-11
 208 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
 209                                       (default '(values nil t))
 210                                       (complex-arg1 :foo complex-arg1-p))
 211   (declare (type keyword simple complex-arg1 complex-arg2))
 212   `(multiple-value-bind (result-a result-b valid-p)
 213        (%invoke-type-method ',(class-function-slot-or-lose simple)
 214                             ',(class-function-slot-or-lose
 215                                (if complex-arg1-p
 216                                  complex-arg1
 217                                  complex-arg2))
 218                             ',(class-function-slot-or-lose complex-arg2)
 219                             ,complex-arg1-p
 220                             ,type1
 221                             ,type2)
 222      (if valid-p
 223        (values result-a result-b)
 224        ,default)))
 225
 226 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 227 ;;;
 228 ;;; KLUDGE: This function must be INLINE in order for cold init to
 229 ;;; work, because the first three arguments are TYPE-CLASS structure
 230 ;;; accessor functions whose calls have to be compiled inline in order
 231 ;;; to work in calls to this function early in cold init. So don't
 232 ;;; conditionalize this INLINE declaration with #!-SB-FLUID or
 233 ;;; anything, unless you also rearrange things to cause the full
 234 ;;; function definitions of the relevant structure accessors to be
 235 ;;; available sufficiently early in cold init. -- WHN 19991015
 236 (declaim (inline %invoke-type-method))
 237 (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
 238   (declare (type symbol simple cslot1 cslot2))
 239   (multiple-value-bind (result-a result-b)
 240       (let ((class1 (type-class-info type1))
 241             (class2 (type-class-info type2)))
 242         (if (eq class1 class2)
 243           (funcall (funcall simple class1) type1 type2)
 244           (let ((complex2 (funcall cslot2 class2)))
 245             (if complex2
 246               (funcall complex2 type1 type2)
 247               (let ((complex1 (funcall cslot1 class1)))
 248                 (if complex1
 249                   (if complex-arg1-p
 250                     (funcall complex1 type1 type2)
 251                     (funcall complex1 type2 type1))
 252                   ;; No meaningful result was found: the caller should
 253                   ;; use the default value instead.
 254                   (return-from %invoke-type-method (values nil nil nil))))))))
 255     ;; If we get to here (without breaking out by calling RETURN-FROM)
 256     ;; then a meaningful result was found, and we return it.
 257     (values result-a result-b t)))
 258
 259 (!defun-from-collected-cold-init-forms !type-class-cold-init)