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