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   (simple-union2 #'hierarchical-union2 :type function)
  83   (complex-union2 nil :type (or function null))
  84   (simple-intersection2 #'hierarchical-intersection2 :type function)
  85   (complex-intersection2 nil :type (or function null))
  86   (simple-= #'must-supply-this :type function)
  87   (complex-= nil :type (or function null))
  88   ;; a function which returns a Common Lisp type specifier
  89   ;; representing this type
  90   (unparse #'must-supply-this :type function)
  91
  92   #|
  93   Not used, and not really right. Probably we want a TYPE= alist for the
  94   unary operations, since there are lots of interesting unary predicates that
  95   aren't equivalent to an entire class
  96   ;; Names of functions used for testing the type of objects in this type
  97   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
  98   ;; passed both the object and the CTYPE. Normally one or the other will be
  99   ;; supplied for any type that can be passed to TYPEP; there is no point in
 100   ;; supplying both.
 101   (unary-typep nil :type (or symbol null))
 102   (typep nil :type (or symbol null))
 103   ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
 104   ;; type.
 105   (unary-coerce nil :type (or symbol null))
 106   (coerce :type (or symbol null))
 107   |#
 108   )
 109
 110 (eval-when (:compile-toplevel :load-toplevel :execute)
 111
 112 ;;; Copy TYPE-CLASS object X, using only operations which will work early in
 113 ;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs
 114 ;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO
 115 ;;; isn't initialized early in cold load.)
 116 ;;;
 117 ;;; FIXME: It's nasty having to maintain this hand-written copy function. And
 118 ;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
 119 ;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
 120 ;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
 121 ;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
 122 ;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
 123 ;;; instead. (For even more improvement, it'd be good to move the raw slots
 124 ;;; into the same object as the ordinary slots, instead of having the
 125 ;;; unfortunate extra level of indirection. But that'd probably require a lot
 126 ;;; of work, including updating the garbage collector to understand it.)
 127 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 128 (defun copy-type-class-coldly (x)
 129   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
 130   ;; to be hand-tweaked to match. -- WHN 19991021
 131   (make-type-class :name                  (type-class-name x)
 132                    :simple-subtypep       (type-class-simple-subtypep x)
 133                    :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
 134                    :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
 135                    :simple-union2         (type-class-simple-union2 x)
 136                    :complex-union2        (type-class-complex-union2 x)
 137                    :simple-intersection2  (type-class-simple-intersection2 x)
 138                    :complex-intersection2 (type-class-complex-intersection2 x)
 139                    :simple-=              (type-class-simple-= x)
 140                    :complex-=             (type-class-complex-= x)
 141                    :unparse               (type-class-unparse x)))
 142
 143 ;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 144 ;;; will have to be tweaked to match. -- WHN 19991021
 145 (defparameter *type-class-function-slots*
 146   '((:simple-subtypep . type-class-simple-subtypep)
 147     (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 148     (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 149     (:simple-union2 . type-class-simple-union2)
 150     (:complex-union2 . type-class-complex-union2)
 151     (:simple-intersection2 . type-class-simple-intersection2)
 152     (:complex-intersection2 . type-class-complex-intersection2)
 153     (:simple-= . type-class-simple-=)
 154     (:complex-= . type-class-complex-=)
 155     (:unparse . type-class-unparse)))
 156
 157 (defun class-function-slot-or-lose (name)
 158   (or (cdr (assoc name *type-class-function-slots*))
 159       (error "~S is not a defined type class method." name)))
 160 ;;; FIXME: This seems to be called at runtime by cold init code.
 161 ;;; Make sure that it's not being called at runtime anywhere but
 162 ;;; one-time toplevel initialization code.
 163
 164 ) ; EVAL-WHEN
 165
 166 (defmacro !define-type-method ((class method &rest more-methods)
 167                                lambda-list &body body)
 168   (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
 169     `(progn
 170        (defun ,name ,lambda-list
 171          ,@body)
 172        (!cold-init-forms
 173         ,@(mapcar (lambda (method)
 174                     `(setf (,(class-function-slot-or-lose method)
 175                             (type-class-or-lose ',class))
 176                            #',name))
 177                   (cons method more-methods)))
 178        ',name)))
 179
 180 (defmacro !define-type-class (name &key inherits)
 181   `(!cold-init-forms
 182      ,(once-only ((n-class (if inherits
 183                                `(copy-type-class-coldly (type-class-or-lose
 184                                                          ',inherits))
 185                                '(make-type-class))))
 186         `(progn
 187            (setf (type-class-name ,n-class) ',name)
 188            (setf (gethash ',name *type-classes*) ,n-class)
 189            ',name))))
 190
 191 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
 192 ;;; same class, invoke the simple method. Otherwise, invoke any
 193 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
 194 ;;; then swap the arguments when calling TYPE1's method. If no
 195 ;;; applicable method, return DEFAULT.
 196 ;;;
 197 ;;; KLUDGE: It might be a lot easier to understand this and the rest
 198 ;;; of the type system code if we used CLOS to express it instead of
 199 ;;; trying to maintain this squirrely hand-crufted object system.
 200 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
 201 ;;; all the compilation can get done by the cross-compiler, which I
 202 ;;; suspect is hard, so we'll bear with the old system for the time
 203 ;;; being. -- WHN 2001-03-11
 204 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
 205                                       (default '(values nil t))
 206                                       (complex-arg1 :foo complex-arg1-p))
 207   (declare (type keyword simple complex-arg1 complex-arg2))
 208   `(multiple-value-bind (result-a result-b valid-p)
 209        (%invoke-type-method ',(class-function-slot-or-lose simple)
 210                             ',(class-function-slot-or-lose
 211                                (if complex-arg1-p
 212                                  complex-arg1
 213                                  complex-arg2))
 214                             ',(class-function-slot-or-lose complex-arg2)
 215                             ,complex-arg1-p
 216                             ,type1
 217                             ,type2)
 218      (if valid-p
 219        (values result-a result-b)
 220        ,default)))
 221
 222 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 223 ;;;
 224 ;;; KLUDGE: This function must be INLINE in order for cold init to
 225 ;;; work, because the first three arguments are TYPE-CLASS structure
 226 ;;; accessor functions whose calls have to be compiled inline in order
 227 ;;; to work in calls to this function early in cold init. So don't
 228 ;;; conditionalize this INLINE declaration with #!-SB-FLUID or
 229 ;;; anything, unless you also rearrange things to cause the full
 230 ;;; function definitions of the relevant structure accessors to be
 231 ;;; available sufficiently early in cold init. -- WHN 19991015
 232 (declaim (inline %invoke-type-method))
 233 (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
 234   (declare (type symbol simple cslot1 cslot2))
 235   (multiple-value-bind (result-a result-b)
 236       (let ((class1 (type-class-info type1))
 237             (class2 (type-class-info type2)))
 238         (if (eq class1 class2)
 239           (funcall (funcall simple class1) type1 type2)
 240           (let ((complex2 (funcall cslot2 class2)))
 241             (if complex2
 242               (funcall complex2 type1 type2)
 243               (let ((complex1 (funcall cslot1 class1)))
 244                 (if complex1
 245                   (if complex-arg1-p
 246                     (funcall complex1 type1 type2)
 247                     (funcall complex1 type2 type1))
 248                   ;; No meaningful result was found: the caller should
 249                   ;; use the default value instead.
 250                   (return-from %invoke-type-method (values nil nil nil))))))))
 251     ;; If we get to here (without breaking out by calling RETURN-FROM)
 252     ;; then a meaningful result was found, and we return it.
 253     (values result-a result-b t)))
 254
 255 (!defun-from-collected-cold-init-forms !type-class-cold-init)