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