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 (MISSING-ARG) default?
  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   ;; monadic functions
  89   (negate #'must-supply-this :type function)
  90   ;; a function which returns a Common Lisp type specifier
  91   ;; representing this type
  92   (unparse #'must-supply-this :type function)
  93   ;; a function which returns T if the CTYPE is inhabited by a single
  94   ;; object and, as a value, the object.  Otherwise, returns NIL, NIL.
  95   ;; The default case (NIL) is interpreted as a function that always
  96   ;; returns NIL, NIL.
  97   (singleton-p nil :type (or function null))
  98
  99   #|
 100   Not used, and not really right. Probably we want a TYPE= alist for the
 101   unary operations, since there are lots of interesting unary predicates that
 102   aren't equivalent to an entire class
 103   ;; Names of functions used for testing the type of objects in this type
 104   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
 105   ;; passed both the object and the CTYPE. Normally one or the other will be
 106   ;; supplied for any type that can be passed to TYPEP; there is no point in
 107   ;; supplying both.
 108   (unary-typep nil :type (or symbol null))
 109   (typep nil :type (or symbol null))
 110   ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
 111   ;; the type.
 112   (unary-coerce nil :type (or symbol null))
 113   (coerce :type (or symbol null))
 114   |#
 115   )
 116
 117 (eval-when (:compile-toplevel :load-toplevel :execute)
 118   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 119   ;; will have to be tweaked to match. -- WHN 19991021
 120   (defparameter *type-class-fun-slots*
 121     '((:simple-subtypep . type-class-simple-subtypep)
 122       (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 123       (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 124       (:simple-union2 . type-class-simple-union2)
 125       (:complex-union2 . type-class-complex-union2)
 126       (:simple-intersection2 . type-class-simple-intersection2)
 127       (:complex-intersection2 . type-class-complex-intersection2)
 128       (:simple-= . type-class-simple-=)
 129       (:complex-= . type-class-complex-=)
 130       (:negate . type-class-negate)
 131       (:unparse . type-class-unparse)
 132       (:singleton-p . type-class-singleton-p))))
 133
 134 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 135 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 136 ;;; Copy TYPE-CLASS object X, using only operations which will work
 137 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 138 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
 139 ;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
 140 ;;; load.)
 141 ;;;
 142 ;;; FIXME: It's nasty having to maintain this hand-written copy
 143 ;;; function. And it seems intrinsically dain-bramaged to have
 144 ;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
 145 ;;; LAYOUT. We should fix this:
 146 ;;;   * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
 147 ;;;   * Rewrite the various CHECK-LAYOUT-related functions so that
 148 ;;;     they check RAW-INDEX and RAW-LENGTH too.
 149 ;;;   * Remove this special hacked copy function, just use
 150 ;;;     COPY-STRUCTURE instead.
 151 ;;; (For even more improvement, it might be good to move the raw slots
 152 ;;; into the same object as the ordinary slots, instead of having the
 153 ;;; unfortunate extra level of indirection. But that'd probably
 154 ;;; require a lot of work, including updating the garbage collector to
 155 ;;; understand it. And it might even hurt overall performance, because
 156 ;;; the positive effect of removing indirection could be cancelled by
 157 ;;; the negative effect of imposing an unnecessary GC write barrier on
 158 ;;; raw data which doesn't actually affect GC.)
 159 (defun copy-type-class-coldly (x)
 160   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
 161   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
 162   ;; have to be hand-tweaked to match. -- WHN 2001-03-19
 163   (make-type-class :name (type-class-name x)
 164                    . #.(mapcan (lambda (type-class-fun-slot)
 165                                  (destructuring-bind (keyword . slot-accessor)
 166                                      type-class-fun-slot
 167                                    `(,keyword (,slot-accessor x))))
 168                                *type-class-fun-slots*)))
 169
 170 (defun class-fun-slot-or-lose (name)
 171   (or (cdr (assoc name *type-class-fun-slots*))
 172       (error "~S is not a defined type class method." name)))
 173 ;;; FIXME: This seems to be called at runtime by cold init code.
 174 ;;; Make sure that it's not being called at runtime anywhere but
 175 ;;; one-time toplevel initialization code.
 176
 177 ) ; EVAL-WHEN
 178
 179 (defmacro !define-type-method ((class method &rest more-methods)
 180                                lambda-list &body body)
 181   (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
 182     `(progn
 183        (defun ,name ,lambda-list
 184          ,@body)
 185        (!cold-init-forms
 186         ,@(mapcar (lambda (method)
 187                     `(setf (,(class-fun-slot-or-lose method)
 188                             (type-class-or-lose ',class))
 189                            #',name))
 190                   (cons method more-methods)))
 191        ',name)))
 192
 193 (defmacro !define-type-class (name &key inherits)
 194   `(!cold-init-forms
 195      ,(once-only ((n-class (if inherits
 196                                `(copy-type-class-coldly (type-class-or-lose
 197                                                          ',inherits))
 198                                '(make-type-class))))
 199         `(progn
 200            (setf (type-class-name ,n-class) ',name)
 201            (setf (gethash ',name *type-classes*) ,n-class)
 202            ',name))))
 203
 204 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
 205 ;;; same class, invoke the simple method. Otherwise, invoke any
 206 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
 207 ;;; then swap the arguments when calling TYPE1's method. If no
 208 ;;; applicable method, return DEFAULT.
 209 ;;;
 210 ;;; KLUDGE: It might be a lot easier to understand this and the rest
 211 ;;; of the type system code if we used CLOS to express it instead of
 212 ;;; trying to maintain this squirrely hand-crufted object system.
 213 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
 214 ;;; all the compilation can get done by the cross-compiler, which I
 215 ;;; suspect is hard, so we'll bear with the old system for the time
 216 ;;; being. -- WHN 2001-03-11
 217 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
 218                                       (default '(values nil t))
 219                                       (complex-arg1 :foo complex-arg1-p))
 220   (declare (type keyword simple complex-arg1 complex-arg2))
 221   (let ((simple (class-fun-slot-or-lose simple))
 222         (cslot1 (class-fun-slot-or-lose
 223                  (if complex-arg1-p complex-arg1 complex-arg2)))
 224         (cslot2 (class-fun-slot-or-lose complex-arg2)))
 225     (once-only ((ntype1 type1)
 226                 (ntype2 type2))
 227       (once-only ((class1 `(type-class-info ,ntype1))
 228                   (class2 `(type-class-info ,ntype2)))
 229         `(if (eq ,class1 ,class2)
 230              (funcall (,simple ,class1) ,ntype1 ,ntype2)
 231              ,(once-only ((complex2 `(,cslot2 ,class2)))
 232                 `(if ,complex2
 233                      (funcall ,complex2 ,ntype1 ,ntype2)
 234                      ,(once-only ((complex1 `(,cslot1 ,class1)))
 235                         `(if ,complex1
 236                              (if ,complex-arg1-p
 237                                  (funcall ,complex1 ,ntype1 ,ntype2)
 238                                  (funcall ,complex1 ,ntype2 ,ntype1))
 239                           ,default)))))))))
 240
 241 ;;; This is a very specialized implementation of CLOS-style
 242 ;;; CALL-NEXT-METHOD within our twisty little type class object
 243 ;;; system, which works given that it's called from within a
 244 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
 245 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
 246 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
 247 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
 248 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
 249 ;;;
 250 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
 251 ;;; everything would Just Work without us having to think about it. In
 252 ;;; our goofy type dispatch system, it's messier to express. It's also
 253 ;;; more fragile, since (0) there's no check that it's called from
 254 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
 255 ;;; rely on our global knowledge that the next (and only) relevant
 256 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
 257 ;;; knowledge of the appropriate default for the CSUBTYPEP function
 258 ;;; when no next method exists. -- WHN 2002-04-07
 259 ;;;
 260 ;;; (We miss CLOS! -- CSR and WHN)
 261 (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
 262   (let* ((type-class (type-class-info type1))
 263          (method-fun (type-class-complex-subtypep-arg1 type-class)))
 264     (if method-fun
 265         (funcall (the function method-fun) type1 type2)
 266         (values subtypep win))))
 267
 268 ;;; KLUDGE: This function is dangerous, as its overuse could easily
 269 ;;; cause stack exhaustion through unbounded recursion.  We only use
 270 ;;; it in one place; maybe it ought not to be a function at all?
 271 (defun invoke-complex-=-other-method (type1 type2)
 272   (let* ((type-class (type-class-info type1))
 273          (method-fun (type-class-complex-= type-class)))
 274     (if method-fun
 275         (funcall (the function method-fun) type2 type1)
 276         (values nil t))))
 277
 278 (!defun-from-collected-cold-init-forms !type-class-cold-init)