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