[6] | 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
| 2 | ;;; |
---|
| 3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
| 4 | ;;; This file is part of OpenMCL. |
---|
| 5 | ;;; |
---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
| 10 | ;;; conflict, the preamble takes precedence. |
---|
| 11 | ;;; |
---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
| 13 | ;;; |
---|
| 14 | ;;; The LLGPL is also available online at |
---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
---|
| 16 | |
---|
| 17 | ;; This is a hacked-up version of the CMU CL type system. |
---|
| 18 | |
---|
[2326] | 19 | (in-package "CCL") |
---|
[6] | 20 | |
---|
| 21 | |
---|
[398] | 22 | |
---|
[6] | 23 | ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that |
---|
| 24 | ;;; compiler warnings can be emitted as appropriate. |
---|
| 25 | ;;; |
---|
| 26 | (define-condition parse-unknown-type (condition) |
---|
[8854] | 27 | ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) |
---|
| 28 | (:report (lambda (c s) (print-unreadable-object (c s :type t) |
---|
| 29 | (format s "unknown type ~A" (parse-unknown-type-specifier c)))))) |
---|
[6] | 30 | |
---|
| 31 | (defun parse-lambda-list (list) |
---|
| 32 | (let* ((required) |
---|
| 33 | (optional) |
---|
| 34 | (keys) |
---|
| 35 | (aux)) |
---|
| 36 | (let ((restp nil) |
---|
| 37 | (rest nil) |
---|
| 38 | (keyp nil) |
---|
| 39 | (allowp nil) |
---|
| 40 | (state :required)) |
---|
| 41 | (dolist (arg list) |
---|
| 42 | (if (and (symbolp arg) |
---|
| 43 | (let ((name (symbol-name arg))) |
---|
| 44 | (and (/= (length name) 0) |
---|
| 45 | (char= (char name 0) #\&)))) |
---|
| 46 | (case arg |
---|
| 47 | (&optional |
---|
| 48 | (unless (eq state :required) |
---|
| 49 | (error "Misplaced &optional in lambda-list: ~S." list)) |
---|
| 50 | (setq state '&optional)) |
---|
| 51 | (&rest |
---|
| 52 | (unless (member state '(:required &optional)) |
---|
| 53 | (error "Misplaced &rest in lambda-list: ~S." list)) |
---|
| 54 | (setq state '&rest)) |
---|
| 55 | (&key |
---|
| 56 | (unless (member state '(:required &optional :post-rest |
---|
| 57 | )) |
---|
| 58 | (error "Misplaced &key in lambda-list: ~S." list)) |
---|
| 59 | (setq keyp t) |
---|
| 60 | (setq state '&key)) |
---|
| 61 | (&allow-other-keys |
---|
| 62 | (unless (eq state '&key) |
---|
| 63 | (error "Misplaced &allow-other-keys in lambda-list: ~S." list)) |
---|
| 64 | (setq allowp t state '&allow-other-keys)) |
---|
| 65 | (&aux |
---|
| 66 | (when (member state '(&rest)) |
---|
| 67 | (error "Misplaced &aux in lambda-list: ~S." list)) |
---|
| 68 | (setq state '&aux)) |
---|
| 69 | (t |
---|
| 70 | (error "Unknown &keyword in lambda-list: ~S." arg))) |
---|
| 71 | (case state |
---|
| 72 | (:required (push arg required)) |
---|
| 73 | (&optional (push arg optional)) |
---|
| 74 | (&rest |
---|
| 75 | (setq restp t rest arg state :post-rest)) |
---|
| 76 | (&key (push arg keys)) |
---|
| 77 | (&aux (push arg aux)) |
---|
| 78 | (t |
---|
| 79 | (error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) |
---|
| 80 | |
---|
| 81 | (values (nreverse required) (nreverse optional) restp rest keyp (nreverse keys) allowp (nreverse aux))))) |
---|
| 82 | |
---|
| 83 | (defvar %deftype-expanders% (make-hash-table :test #'eq)) |
---|
| 84 | (defvar *type-translators* (make-hash-table :test #'eq)) |
---|
| 85 | (defvar *builtin-type-info* (make-hash-table :test #'equal)) |
---|
| 86 | (defvar %builtin-type-cells% (make-hash-table :test 'equal)) |
---|
| 87 | |
---|
| 88 | (defvar *use-implementation-types* t) |
---|
| 89 | |
---|
| 90 | (defun info-type-builtin (name) |
---|
| 91 | (gethash name *builtin-type-info*)) |
---|
| 92 | |
---|
| 93 | (defun (setf info-type-builtin) (val name) |
---|
| 94 | (setf (gethash name *builtin-type-info*) val)) |
---|
| 95 | |
---|
| 96 | (defun info-type-translator (name) |
---|
| 97 | (gethash name *type-translators*)) |
---|
| 98 | |
---|
| 99 | |
---|
| 100 | |
---|
| 101 | |
---|
[3963] | 102 | ;;; Allow bootstrapping: mostly, allow us to bootstrap the type system |
---|
| 103 | ;;; by having DEFTYPE expanders defined on built-in classes (the user |
---|
| 104 | ;;; shouldn't be allowed to do so, at least not easily. |
---|
[6] | 105 | |
---|
| 106 | ;(defvar *type-system-initialized* nil) |
---|
| 107 | |
---|
| 108 | (defun %deftype (name fn doc) |
---|
[1148] | 109 | (clear-type-cache) |
---|
[6] | 110 | (cond ((null fn) |
---|
| 111 | (remhash name %deftype-expanders%)) |
---|
| 112 | ((and *type-system-initialized* |
---|
| 113 | (or (built-in-type-p name) (find-class name nil))) |
---|
| 114 | (error "Cannot redefine type ~S" name)) |
---|
| 115 | (t (setf (gethash name %deftype-expanders%) fn) |
---|
| 116 | (record-source-file name 'type))) |
---|
| 117 | (set-documentation name 'type doc) ; nil clears it. |
---|
| 118 | name) |
---|
| 119 | |
---|
| 120 | (defun %define-type-translator (name fn doc) |
---|
| 121 | (declare (ignore doc)) |
---|
| 122 | (setf (gethash name *type-translators*) fn) |
---|
| 123 | name) |
---|
| 124 | |
---|
[3963] | 125 | ;;;(defun %deftype-expander (name) |
---|
| 126 | ;;; (or (gethash name %deftype-expanders%) |
---|
| 127 | ;;; (and *compiling-file* (%cdr (assq name *compile-time-deftype-expanders*))))) |
---|
[6] | 128 | (defun %deftype-expander (name) |
---|
| 129 | (gethash name %deftype-expanders%)) |
---|
| 130 | |
---|
| 131 | (defun process-deftype-arglist (arglist &aux (in-optional? nil)) |
---|
| 132 | "Returns a NEW list similar to arglist except |
---|
| 133 | inserts * as the default default for &optional args." |
---|
| 134 | (mapcar #'(lambda (item) |
---|
| 135 | (cond ((eq item '&optional) (setq in-optional? t) item) |
---|
| 136 | ((memq item lambda-list-keywords) (setq in-optional? nil) item) |
---|
| 137 | ((and in-optional? (symbolp item)) (list item ''*)) |
---|
| 138 | (t item))) |
---|
| 139 | arglist)) |
---|
| 140 | |
---|
[279] | 141 | |
---|
[6] | 142 | (defun expand-type-macro (definer name arglist body env) |
---|
| 143 | (setq name (require-type name 'symbol)) |
---|
| 144 | (multiple-value-bind (lambda doc) |
---|
| 145 | (parse-macro-internal name arglist body env '*) |
---|
[318] | 146 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
---|
[6] | 147 | (,definer ',name |
---|
| 148 | (nfunction ,name ,lambda) |
---|
| 149 | ,doc)))) |
---|
| 150 | |
---|
| 151 | (defmacro deftype (name arglist &body body &environment env) |
---|
[929] | 152 | "Define a new type, with syntax like DEFMACRO." |
---|
[6] | 153 | (expand-type-macro '%deftype name arglist body env)) |
---|
| 154 | |
---|
| 155 | (defmacro def-type-translator (name arglist &body body &environment env) |
---|
| 156 | (expand-type-macro '%define-type-translator name arglist body env)) |
---|
| 157 | |
---|
| 158 | |
---|
| 159 | (defun type-expand (form &optional env &aux def) |
---|
| 160 | (while (setq def (cond ((symbolp form) |
---|
| 161 | (gethash form %deftype-expanders%)) |
---|
| 162 | ((and (consp form) (symbolp (%car form))) |
---|
| 163 | (gethash (%car form) %deftype-expanders%)) |
---|
| 164 | (t nil))) |
---|
| 165 | (setq form (funcall def (if (consp form) form (list form)) env))) |
---|
| 166 | form) |
---|
| 167 | |
---|
| 168 | (defmethod print-object ((tc type-class) stream) |
---|
| 169 | (print-unreadable-object (tc stream :type t :identity t) |
---|
| 170 | (format stream "~s" (type-class-name tc)))) |
---|
| 171 | |
---|
| 172 | (defmethod print-object ((c ctype) stream) |
---|
| 173 | (print-unreadable-object (c stream :type t) |
---|
| 174 | (format stream "~S" (type-specifier c)))) |
---|
| 175 | |
---|
| 176 | (defmethod make-load-form ((c ctype) &optional env) |
---|
| 177 | (declare (ignore env)) |
---|
| 178 | `(specifier-type ',(type-specifier c))) |
---|
| 179 | |
---|
| 180 | |
---|
| 181 | (defun make-key-info (&key name type) |
---|
| 182 | (%istruct 'key-info name type)) |
---|
| 183 | |
---|
| 184 | (defun type-class-or-lose (name) |
---|
| 185 | (or (cdr (assq name *type-classes*)) |
---|
| 186 | (error "~S is not a defined type class." name))) |
---|
| 187 | |
---|
| 188 | (eval-when (:compile-toplevel :execute) |
---|
| 189 | |
---|
| 190 | (defconstant type-class-function-slots |
---|
| 191 | '((:simple-subtypep . #.type-class-simple-subtypep) |
---|
| 192 | (:complex-subtypep-arg1 . #.type-class-complex-subtypep-arg1) |
---|
| 193 | (:complex-subtypep-arg2 . #.type-class-complex-subtypep-arg2) |
---|
| 194 | (:simple-union . #.type-class-simple-union) |
---|
| 195 | (:complex-union . #.type-class-complex-union) |
---|
| 196 | (:simple-intersection . #.type-class-simple-intersection) |
---|
| 197 | (:complex-intersection . #.type-class-complex-intersection) |
---|
| 198 | (:simple-= . #.type-class-simple-=) |
---|
| 199 | (:complex-= . #.type-class-complex-=) |
---|
| 200 | (:unparse . #.type-class-unparse))) |
---|
| 201 | |
---|
| 202 | ) |
---|
| 203 | |
---|
| 204 | (defun class-typep (form class) |
---|
| 205 | (memq class (%inited-class-cpl (class-of form)))) |
---|
| 206 | |
---|
| 207 | ;;; CLASS-FUNCTION-SLOT-OR-LOSE -- Interface |
---|
| 208 | ;;; |
---|
| 209 | (defun class-function-slot-or-lose (name) |
---|
| 210 | (or (cdr (assoc name type-class-function-slots)) |
---|
| 211 | (error "~S is not a defined type class method." name))) |
---|
| 212 | |
---|
| 213 | |
---|
| 214 | (eval-when (:compile-toplevel :execute) |
---|
| 215 | |
---|
| 216 | ;;; INVOKE-TYPE-METHOD -- Interface |
---|
| 217 | ;;; |
---|
| 218 | ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same |
---|
| 219 | ;;; class, invoke the simple method. Otherwise, invoke any complex method. If |
---|
| 220 | ;;; there isn't a distinct complex-arg1 method, then swap the arguments when |
---|
| 221 | ;;; calling type1's method. If no applicable method, return DEFAULT. |
---|
| 222 | ;;; |
---|
| 223 | |
---|
| 224 | (defmacro invoke-type-method (simple complex-arg2 type1 type2 &key |
---|
| 225 | (default '(values nil t)) |
---|
| 226 | complex-arg1) |
---|
| 227 | (let ((simple (class-function-slot-or-lose simple)) |
---|
| 228 | (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2))) |
---|
| 229 | (cslot2 (class-function-slot-or-lose complex-arg2))) |
---|
| 230 | (once-only ((n-type1 type1) |
---|
| 231 | (n-type2 type2)) |
---|
| 232 | (once-only ((class1 `(ctype-class-info ,n-type1)) |
---|
| 233 | (class2 `(ctype-class-info ,n-type2))) |
---|
| 234 | `(if (eq ,class1 ,class2) |
---|
| 235 | (funcall (%svref ,class1 ,simple) ,n-type1 ,n-type2) |
---|
| 236 | ,(once-only ((complex1 `(%svref ,class1 ,cslot1)) |
---|
| 237 | (complex2 `(%svref ,class2 ,cslot2))) |
---|
| 238 | `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2)) |
---|
| 239 | (,complex1 |
---|
| 240 | ,(if complex-arg1 |
---|
| 241 | `(funcall ,complex1 ,n-type1 ,n-type2) |
---|
| 242 | `(funcall ,complex1 ,n-type2 ,n-type1))) |
---|
| 243 | (t ,default)))))))) |
---|
| 244 | |
---|
| 245 | |
---|
| 246 | ;;;; Utilities: |
---|
| 247 | |
---|
| 248 | ;;; ANY-TYPE-OP, EVERY-TYPE-OP -- Interface |
---|
| 249 | ;;; |
---|
| 250 | ;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates. |
---|
| 251 | ;;; If the result is uncertain, then we return Default from the block PUNT. |
---|
| 252 | ;;; If LIST-FIRST is true, then the list element is the first arg, otherwise |
---|
| 253 | ;;; the second. |
---|
| 254 | ;;; |
---|
| 255 | (defmacro any-type-op (op thing list &key (default '(values nil nil)) |
---|
| 256 | list-first) |
---|
| 257 | (let ((n-this (gensym)) |
---|
| 258 | (n-thing (gensym)) |
---|
| 259 | (n-val (gensym)) |
---|
| 260 | (n-win (gensym)) |
---|
| 261 | (n-uncertain (gensym))) |
---|
| 262 | `(let ((,n-thing ,thing) |
---|
| 263 | (,n-uncertain nil)) |
---|
| 264 | (dolist (,n-this ,list |
---|
| 265 | (if ,n-uncertain |
---|
| 266 | (return-from PUNT ,default) |
---|
| 267 | nil)) |
---|
| 268 | (multiple-value-bind (,n-val ,n-win) |
---|
| 269 | ,(if list-first |
---|
| 270 | `(,op ,n-this ,n-thing) |
---|
| 271 | `(,op ,n-thing ,n-this)) |
---|
| 272 | (unless ,n-win (setq ,n-uncertain t)) |
---|
| 273 | (when ,n-val (return t))))))) |
---|
| 274 | ;;; |
---|
| 275 | (defmacro every-type-op (op thing list &key (default '(values nil nil)) |
---|
| 276 | list-first) |
---|
| 277 | (let ((n-this (gensym)) |
---|
| 278 | (n-thing (gensym)) |
---|
| 279 | (n-val (gensym)) |
---|
| 280 | (n-win (gensym))) |
---|
| 281 | `(let ((,n-thing ,thing)) |
---|
| 282 | (dolist (,n-this ,list t) |
---|
| 283 | (multiple-value-bind (,n-val ,n-win) |
---|
| 284 | ,(if list-first |
---|
| 285 | `(,op ,n-this ,n-thing) |
---|
| 286 | `(,op ,n-thing ,n-this)) |
---|
| 287 | (unless ,n-win (return-from PUNT ,default)) |
---|
| 288 | (unless ,n-val (return nil))))))) |
---|
| 289 | |
---|
| 290 | ) |
---|
| 291 | |
---|
| 292 | |
---|
| 293 | ;;; VANILLA-INTERSECTION -- Interface |
---|
| 294 | ;;; |
---|
| 295 | ;;; Compute the intersection for types that intersect only when one is a |
---|
| 296 | ;;; hierarchical subtype of the other. |
---|
| 297 | ;;; |
---|
| 298 | (defun vanilla-intersection (type1 type2) |
---|
| 299 | (multiple-value-bind (stp1 win1) |
---|
| 300 | (csubtypep type1 type2) |
---|
| 301 | (multiple-value-bind (stp2 win2) |
---|
| 302 | (csubtypep type2 type1) |
---|
| 303 | (cond (stp1 (values type1 t)) |
---|
| 304 | (stp2 (values type2 t)) |
---|
| 305 | ((and win1 win2) (values *empty-type* t)) |
---|
| 306 | (t |
---|
| 307 | (values type1 nil)))))) |
---|
| 308 | |
---|
| 309 | |
---|
| 310 | ;;; VANILLA-UNION -- Interface |
---|
| 311 | ;;; |
---|
| 312 | (defun vanilla-union (type1 type2) |
---|
| 313 | (cond ((csubtypep type1 type2) type2) |
---|
[279] | 314 | ((csubtypep type2 type1) type1) |
---|
| 315 | (t nil))) |
---|
[6] | 316 | |
---|
[279] | 317 | (defun hierarchical-intersection2 (type1 type2) |
---|
| 318 | (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) |
---|
| 319 | (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) |
---|
| 320 | (cond (subtypep1 type1) |
---|
| 321 | (subtypep2 type2) |
---|
| 322 | ((and win1 win2) *empty-type*) |
---|
| 323 | (t nil))))) |
---|
[6] | 324 | |
---|
[279] | 325 | (defun hierarchical-union2 (type1 type2) |
---|
| 326 | (cond ((csubtypep type1 type2) type2) |
---|
| 327 | ((csubtypep type2 type1) type1) |
---|
| 328 | (t nil))) |
---|
| 329 | |
---|
[6] | 330 | ;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface |
---|
| 331 | ;;; |
---|
| 332 | ;;; These functions are used as method for types which need a complex |
---|
| 333 | ;;; subtypep method to handle some superclasses, but cover a subtree of the |
---|
| 334 | ;;; type graph (i.e. there is no simple way for any other type class to be a |
---|
| 335 | ;;; subtype.) There are always still complex ways, namely UNION and MEMBER |
---|
| 336 | ;;; types, so we must give TYPE1's method a chance to run, instead of |
---|
| 337 | ;;; immediately returning NIL, T. |
---|
| 338 | ;;; |
---|
| 339 | (defun delegate-complex-subtypep-arg2 (type1 type2) |
---|
| 340 | (let ((subtypep-arg1 |
---|
| 341 | (type-class-complex-subtypep-arg1 |
---|
| 342 | (ctype-class-info type1)))) |
---|
| 343 | (if subtypep-arg1 |
---|
| 344 | (funcall subtypep-arg1 type1 type2) |
---|
| 345 | (values nil t)))) |
---|
| 346 | ;;; |
---|
| 347 | (defun delegate-complex-intersection (type1 type2) |
---|
| 348 | (let ((method (type-class-complex-intersection (ctype-class-info type1)))) |
---|
| 349 | (if (and method (not (eq method #'delegate-complex-intersection))) |
---|
| 350 | (funcall method type2 type1) |
---|
[279] | 351 | (hierarchical-intersection2 type1 type2)))) |
---|
[6] | 352 | |
---|
| 353 | ;;; HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1 -- Internal |
---|
| 354 | ;;; |
---|
| 355 | ;;; Used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 method. Info is |
---|
| 356 | ;;; a list of conses (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). Will |
---|
| 357 | ;;; never be called with a hairy type as type2, since the hairy type type2 |
---|
| 358 | ;;; method gets first crack. |
---|
| 359 | ;;; |
---|
| 360 | #| |
---|
| 361 | (defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) |
---|
| 362 | (values |
---|
| 363 | (and (typep type2 'class) |
---|
| 364 | (dolist (x info nil) |
---|
| 365 | (when (or (not (cdr x)) |
---|
| 366 | (csubtypep type1 (specifier-type (cdr x)))) |
---|
| 367 | (return |
---|
| 368 | (or (eq type2 (car x)) |
---|
| 369 | (let ((inherits (layout-inherits (class-layout (car x))))) |
---|
| 370 | (dotimes (i (length inherits) nil) |
---|
| 371 | (when (eq type2 (layout-class (svref inherits i))) |
---|
| 372 | (return t))))))))) |
---|
| 373 | t)) |
---|
| 374 | |# |
---|
| 375 | |
---|
| 376 | (eval-when (:compile-toplevel :execute) |
---|
| 377 | ;;; DEFINE-SUPERCLASSES -- Interface |
---|
| 378 | ;;; |
---|
| 379 | ;;; Takes a list of specs of the form (superclass &optional guard). |
---|
| 380 | ;;; Consider one spec (with no guard): any instance of type-class is also a |
---|
| 381 | ;;; subtype of SUPERCLASS and of any of its superclasses. If there are |
---|
| 382 | ;;; multiple specs, then some will have guards. We choose the first spec whose |
---|
| 383 | ;;; guard is a supertype of TYPE1 and use its superclass. In effect, a |
---|
| 384 | ;;; sequence of guards G0, G1, G2 is actually G0, (and G1 (not G0)), |
---|
| 385 | ;;; (and G2 (not (or G0 G1))). |
---|
| 386 | ;;; |
---|
| 387 | #| |
---|
| 388 | (defmacro define-superclasses (type-class &rest specs) |
---|
| 389 | (let ((info |
---|
| 390 | (mapcar #'(lambda (spec) |
---|
| 391 | (destructuring-bind (super &optional guard) |
---|
| 392 | spec |
---|
| 393 | (cons (find-class super) guard))) |
---|
| 394 | specs))) |
---|
| 395 | `(progn |
---|
| 396 | (setf (type-class-complex-subtypep-arg1 |
---|
| 397 | (type-class-or-lose ',type-class)) |
---|
| 398 | #'(lambda (type1 type2) |
---|
| 399 | (has-superclasses-complex-subtypep-arg1 type1 type2 ',info))) |
---|
| 400 | |
---|
| 401 | (setf (type-class-complex-subtypep-arg2 |
---|
| 402 | (type-class-or-lose ',type-class)) |
---|
| 403 | #'delegate-complex-subtypep-arg2) |
---|
| 404 | |
---|
| 405 | (setf (type-class-complex-intersection |
---|
| 406 | (type-class-or-lose ',type-class)) |
---|
| 407 | #'delegate-complex-intersection)))) |
---|
| 408 | |# |
---|
| 409 | |
---|
| 410 | ); eval-when (compile eval) |
---|
| 411 | |
---|
[279] | 412 | |
---|
| 413 | (defun reparse-unknown-ctype (type) |
---|
| 414 | (if (unknown-ctype-p type) |
---|
| 415 | (specifier-type (type-specifier type)) |
---|
| 416 | type)) |
---|
| 417 | |
---|
| 418 | (defun swapped-args-fun (f) |
---|
| 419 | #'(lambda (x y) |
---|
| 420 | (funcall f y x))) |
---|
| 421 | |
---|
| 422 | (defun equal-but-no-car-recursion (x y) |
---|
| 423 | (cond ((eql x y) t) |
---|
| 424 | ((consp x) |
---|
| 425 | (and (consp y) |
---|
| 426 | (eql (car x) (car y)) |
---|
| 427 | (equal-but-no-car-recursion (cdr x) (cdr y)))) |
---|
| 428 | (t nil))) |
---|
| 429 | |
---|
| 430 | (defun any/type (op thing list) |
---|
| 431 | (declare (type function op)) |
---|
| 432 | (let ((certain? t)) |
---|
| 433 | (dolist (i list (values nil certain?)) |
---|
| 434 | (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) |
---|
| 435 | (if sub-certain? |
---|
| 436 | (when sub-value (return (values t t))) |
---|
| 437 | (setf certain? nil)))))) |
---|
| 438 | |
---|
| 439 | (defun every/type (op thing list) |
---|
| 440 | (declare (type function op)) |
---|
| 441 | (let ((certain? t)) |
---|
| 442 | (dolist (i list (if certain? (values t t) (values nil nil))) |
---|
| 443 | (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) |
---|
| 444 | (if sub-certain? |
---|
| 445 | (unless sub-value (return (values nil t))) |
---|
| 446 | (setf certain? nil)))))) |
---|
| 447 | |
---|
| 448 | (defun invoke-complex-=-other-method (type1 type2) |
---|
| 449 | (let* ((type-class (ctype-class-info type1)) |
---|
| 450 | (method-fun (type-class-complex-= type-class))) |
---|
| 451 | (if method-fun |
---|
| 452 | (funcall (the function method-fun) type2 type1) |
---|
| 453 | (values nil t)))) |
---|
| 454 | |
---|
| 455 | (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) |
---|
| 456 | (let* ((type-class (ctype-class-info type1)) |
---|
| 457 | (method-fun (type-class-complex-subtypep-arg1 type-class))) |
---|
| 458 | (if method-fun |
---|
| 459 | (funcall (the function method-fun) type1 type2) |
---|
| 460 | (values subtypep win)))) |
---|
| 461 | |
---|
| 462 | (defun type-might-contain-other-types-p (type) |
---|
| 463 | (or (hairy-ctype-p type) |
---|
| 464 | (negation-ctype-p type) |
---|
| 465 | (union-ctype-p type) |
---|
| 466 | (intersection-ctype-p type))) |
---|
| 467 | |
---|
| 468 | |
---|
[6] | 469 | (eval-when (:compile-toplevel :execute) |
---|
| 470 | |
---|
| 471 | (defmacro define-type-method ((class method &rest more-methods) |
---|
| 472 | lambda-list &body body) |
---|
| 473 | `(progn |
---|
[9892] | 474 | (let* ((fn (nfunction (,class ,method ,@more-methods) |
---|
| 475 | (lambda ,lambda-list ,@body)))) |
---|
[6] | 476 | ,@(mapcar #'(lambda (method) |
---|
| 477 | `(setf (%svref |
---|
| 478 | (type-class-or-lose ',class) |
---|
| 479 | ,(class-function-slot-or-lose method)) |
---|
| 480 | fn)) |
---|
| 481 | (cons method more-methods))) |
---|
| 482 | nil)) |
---|
| 483 | |
---|
| 484 | ) |
---|
| 485 | |
---|
| 486 | |
---|
| 487 | (defun ctype-p (x) |
---|
[1668] | 488 | (and (eql (typecode x) target::subtag-istruct) |
---|
[10309] | 489 | (memq (istruct-type-name x) |
---|
[6] | 490 | '#.(cons 'ctype |
---|
| 491 | (cons 'unknown-ctype |
---|
| 492 | (append (mapcar #'class-name |
---|
| 493 | (class-direct-subclasses (find-class 'args-ctype))) |
---|
| 494 | (mapcar #'class-name |
---|
| 495 | (class-direct-subclasses (find-class 'ctype))))))))) |
---|
| 496 | |
---|
| 497 | |
---|
| 498 | (setf (type-predicate 'ctype) 'ctype-p) |
---|
| 499 | |
---|
| 500 | |
---|
| 501 | ;;;; Function and Values types. |
---|
| 502 | ;;; |
---|
| 503 | ;;; Pretty much all of the general type operations are illegal on VALUES |
---|
| 504 | ;;; types, since we can't discriminate using them, do SUBTYPEP, etc. FUNCTION |
---|
| 505 | ;;; types are acceptable to the normal type operations, but are generally |
---|
| 506 | ;;; considered to be equivalent to FUNCTION. These really aren't true types in |
---|
| 507 | ;;; any type theoretic sense, but we still parse them into CTYPE structures for |
---|
| 508 | ;;; two reasons: |
---|
| 509 | ;;; -- Parsing and unparsing work the same way, and indeed we can't tell |
---|
| 510 | ;;; whether a type is a function or values type without parsing it. |
---|
| 511 | ;;; -- Many of the places that can be annotated with real types can also be |
---|
| 512 | ;;; annotated function or values types. |
---|
| 513 | |
---|
| 514 | ;; Methods on the VALUES type class. |
---|
| 515 | |
---|
| 516 | (defun make-values-ctype (&key |
---|
| 517 | required |
---|
| 518 | optional |
---|
| 519 | rest |
---|
| 520 | keyp |
---|
| 521 | keywords |
---|
| 522 | allowp) |
---|
| 523 | (%istruct 'values-ctype |
---|
| 524 | (type-class-or-lose 'values) |
---|
| 525 | nil |
---|
| 526 | required |
---|
| 527 | optional |
---|
| 528 | rest |
---|
| 529 | keyp |
---|
| 530 | keywords |
---|
| 531 | allowp |
---|
| 532 | )) |
---|
| 533 | |
---|
| 534 | (defun values-ctype-p (x) (istruct-typep x 'values-ctype)) |
---|
| 535 | (setf (type-predicate 'values-ctype) 'values-ctype-p) |
---|
| 536 | |
---|
| 537 | |
---|
| 538 | (define-type-method (values :simple-subtypep :complex-subtypep-arg1) |
---|
| 539 | (type1 type2) |
---|
| 540 | (declare (ignore type2)) |
---|
| 541 | (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) |
---|
| 542 | |
---|
| 543 | (define-type-method (values :complex-subtypep-arg2) |
---|
| 544 | (type1 type2) |
---|
| 545 | (declare (ignore type1)) |
---|
| 546 | (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) |
---|
| 547 | |
---|
| 548 | |
---|
| 549 | (define-type-method (values :unparse) (type) |
---|
| 550 | (cons 'values (unparse-args-types type))) |
---|
| 551 | |
---|
| 552 | |
---|
| 553 | ;;; TYPE=-LIST -- Internal |
---|
| 554 | ;;; |
---|
| 555 | ;;; Return true if List1 and List2 have the same elements in the same |
---|
| 556 | ;;; positions according to TYPE=. We return NIL, NIL if there is an uncertain |
---|
| 557 | ;;; comparison. |
---|
| 558 | ;;; |
---|
| 559 | (defun type=-list (list1 list2) |
---|
| 560 | (declare (list list1 list2)) |
---|
| 561 | (do ((types1 list1 (cdr types1)) |
---|
| 562 | (types2 list2 (cdr types2))) |
---|
| 563 | ((or (null types1) (null types2)) |
---|
| 564 | (if (or types1 types2) |
---|
| 565 | (values nil t) |
---|
| 566 | (values t t))) |
---|
| 567 | (multiple-value-bind (val win) |
---|
| 568 | (type= (first types1) (first types2)) |
---|
| 569 | (unless win |
---|
| 570 | (return (values nil nil))) |
---|
| 571 | (unless val |
---|
| 572 | (return (values nil t)))))) |
---|
| 573 | |
---|
| 574 | (define-type-method (values :simple-=) (type1 type2) |
---|
| 575 | (let ((rest1 (args-ctype-rest type1)) |
---|
[279] | 576 | (rest2 (args-ctype-rest type2))) |
---|
[6] | 577 | (cond ((or (args-ctype-keyp type1) (args-ctype-keyp type2) |
---|
[279] | 578 | (args-ctype-allowp type1) (args-ctype-allowp type2)) |
---|
[6] | 579 | (values nil nil)) |
---|
| 580 | ((and rest1 rest2 (type/= rest1 rest2)) |
---|
| 581 | (type= rest1 rest2)) |
---|
| 582 | ((or rest1 rest2) |
---|
| 583 | (values nil t)) |
---|
| 584 | (t |
---|
| 585 | (multiple-value-bind (req-val req-win) |
---|
[279] | 586 | (type=-list (values-ctype-required type1) |
---|
| 587 | (values-ctype-required type2)) |
---|
[6] | 588 | (multiple-value-bind (opt-val opt-win) |
---|
[279] | 589 | (type=-list (values-ctype-optional type1) |
---|
| 590 | (values-ctype-optional type2)) |
---|
[6] | 591 | (values (and req-val opt-val) (and req-win opt-win)))))))) |
---|
| 592 | |
---|
| 593 | |
---|
| 594 | ;; Methods on the FUNCTION type class. |
---|
| 595 | |
---|
| 596 | |
---|
| 597 | (defun make-function-ctype (&key |
---|
| 598 | required |
---|
| 599 | optional |
---|
| 600 | rest |
---|
| 601 | keyp |
---|
| 602 | keywords |
---|
| 603 | allowp |
---|
| 604 | wild-args |
---|
| 605 | returns) |
---|
| 606 | (%istruct 'function-ctype |
---|
| 607 | (type-class-or-lose 'function) |
---|
| 608 | nil |
---|
| 609 | required |
---|
| 610 | optional |
---|
| 611 | rest |
---|
| 612 | keyp |
---|
| 613 | keywords |
---|
| 614 | allowp |
---|
| 615 | wild-args |
---|
| 616 | returns |
---|
| 617 | )) |
---|
| 618 | |
---|
| 619 | (defun function-ctype-p (x) (istruct-typep x 'function-ctype)) |
---|
| 620 | (setf (type-predicate 'function-ctype) 'function-ctype-p) |
---|
| 621 | |
---|
| 622 | ;;; A flag that we can bind to cause complex function types to be unparsed as |
---|
| 623 | ;;; FUNCTION. Useful when we want a type that we can pass to TYPEP. |
---|
| 624 | ;;; |
---|
| 625 | (defvar *unparse-function-type-simplify* nil) |
---|
| 626 | |
---|
| 627 | (define-type-method (function :unparse) (type) |
---|
| 628 | (if *unparse-function-type-simplify* |
---|
| 629 | 'function |
---|
| 630 | (list 'function |
---|
| 631 | (if (function-ctype-wild-args type) |
---|
| 632 | '* |
---|
| 633 | (unparse-args-types type)) |
---|
| 634 | (type-specifier |
---|
| 635 | (function-ctype-returns type))))) |
---|
| 636 | |
---|
| 637 | ;;; Since all function types are equivalent to FUNCTION, they are all subtypes |
---|
| 638 | ;;; of each other. |
---|
| 639 | ;;; |
---|
[279] | 640 | |
---|
[6] | 641 | (define-type-method (function :simple-subtypep) (type1 type2) |
---|
[279] | 642 | (flet ((fun-type-simple-p (type) |
---|
| 643 | (not (or (function-ctype-rest type) |
---|
| 644 | (function-ctype-keyp type)))) |
---|
| 645 | (every-csubtypep (types1 types2) |
---|
| 646 | (loop |
---|
| 647 | for a1 in types1 |
---|
| 648 | for a2 in types2 |
---|
| 649 | do (multiple-value-bind (res sure-p) |
---|
| 650 | (csubtypep a1 a2) |
---|
| 651 | (unless res (return (values res sure-p)))) |
---|
| 652 | finally (return (values t t))))) |
---|
| 653 | (macrolet ((3and (x y) |
---|
| 654 | `(multiple-value-bind (val1 win1) ,x |
---|
| 655 | (if (and (not val1) win1) |
---|
| 656 | (values nil t) |
---|
| 657 | (multiple-value-bind (val2 win2) ,y |
---|
| 658 | (if (and val1 val2) |
---|
| 659 | (values t t) |
---|
| 660 | (values nil (and win2 (not val2))))))))) |
---|
| 661 | (3and (values-subtypep (function-ctype-returns type1) |
---|
| 662 | (function-ctype-returns type2)) |
---|
| 663 | (cond ((function-ctype-wild-args type2) (values t t)) |
---|
| 664 | ((function-ctype-wild-args type1) |
---|
| 665 | (cond ((function-ctype-keyp type2) (values nil nil)) |
---|
| 666 | ((not (function-ctype-rest type2)) (values nil t)) |
---|
| 667 | ((not (null (function-ctype-required type2))) (values nil t)) |
---|
| 668 | (t (3and (type= *universal-type* (function-ctype-rest type2)) |
---|
| 669 | (every/type #'type= *universal-type* |
---|
| 670 | (function-ctype-optional type2)))))) |
---|
| 671 | ((not (and (fun-type-simple-p type1) |
---|
| 672 | (fun-type-simple-p type2))) |
---|
| 673 | (values nil nil)) |
---|
| 674 | (t (multiple-value-bind (min1 max1) (function-type-nargs type1) |
---|
| 675 | (multiple-value-bind (min2 max2) (function-type-nargs type2) |
---|
| 676 | (cond ((or (> max1 max2) (< min1 min2)) |
---|
| 677 | (values nil t)) |
---|
| 678 | ((and (= min1 min2) (= max1 max2)) |
---|
| 679 | (3and (every-csubtypep (function-ctype-required type1) |
---|
| 680 | (function-ctype-required type2)) |
---|
| 681 | (every-csubtypep (function-ctype-optional type1) |
---|
| 682 | (function-ctype-optional type2)))) |
---|
| 683 | (t (every-csubtypep |
---|
| 684 | (concatenate 'list |
---|
| 685 | (function-ctype-required type1) |
---|
| 686 | (function-ctype-optional type1)) |
---|
| 687 | (concatenate 'list |
---|
| 688 | (function-ctype-required type2) |
---|
| 689 | (function-ctype-optional type2))))))))))))) |
---|
[6] | 690 | |
---|
[279] | 691 | |
---|
[6] | 692 | |
---|
| 693 | ;(define-superclasses function (function)) |
---|
| 694 | |
---|
| 695 | |
---|
| 696 | ;;; The union or intersection of two FUNCTION types is FUNCTION. |
---|
[279] | 697 | ;;; (unless the types are type=) |
---|
[6] | 698 | ;;; |
---|
| 699 | (define-type-method (function :simple-union) (type1 type2) |
---|
[279] | 700 | (if (type= type1 type2) |
---|
| 701 | type1 |
---|
| 702 | (specifier-type 'function))) |
---|
| 703 | |
---|
[6] | 704 | ;;; |
---|
| 705 | (define-type-method (function :simple-intersection) (type1 type2) |
---|
[279] | 706 | (if (type= type1 type2) |
---|
| 707 | type1 |
---|
| 708 | (specifier-type 'function))) |
---|
[6] | 709 | |
---|
| 710 | |
---|
| 711 | ;;; ### Not very real, but good enough for redefining transforms according to |
---|
| 712 | ;;; type: |
---|
| 713 | ;;; |
---|
| 714 | (define-type-method (function :simple-=) (type1 type2) |
---|
| 715 | (values (equalp type1 type2) t)) |
---|
| 716 | |
---|
| 717 | ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type |
---|
| 718 | ;;; specifier", which is only meaningful in function argument type specifiers |
---|
| 719 | ;;; used within the compiler. |
---|
| 720 | ;;; |
---|
| 721 | |
---|
| 722 | (defun clone-type-class-methods (src-tc dest-tc) |
---|
| 723 | (do* ((n (uvsize src-tc)) |
---|
| 724 | (i 2 (1+ i))) |
---|
| 725 | ((= i n) dest-tc) |
---|
| 726 | (declare (fixnum i n)) |
---|
| 727 | (setf (%svref dest-tc i) |
---|
| 728 | (%svref src-tc i)))) |
---|
| 729 | |
---|
| 730 | (clone-type-class-methods (type-class-or-lose 'values) (type-class-or-lose 'constant)) |
---|
| 731 | |
---|
| 732 | (defun make-constant-ctype (&key type) |
---|
| 733 | (%istruct 'constant-ctype |
---|
| 734 | (type-class-or-lose 'constant) |
---|
| 735 | nil |
---|
| 736 | type)) |
---|
| 737 | |
---|
| 738 | (defun constant-ctype-p (x) (istruct-typep x 'constant-ctype)) |
---|
| 739 | (setf (type-predicate 'constant-ctype) 'constant-ctype-p) |
---|
| 740 | |
---|
| 741 | (define-type-method (constant :unparse) (type) |
---|
| 742 | `(constant-argument ,(type-specifier (constant-ctype-type type)))) |
---|
| 743 | |
---|
| 744 | (define-type-method (constant :simple-=) (type1 type2) |
---|
| 745 | (type= (constant-ctype-type type1) (constant-ctype-type type2))) |
---|
| 746 | |
---|
[9892] | 747 | (def-type-translator constant-argument (type &environment env) |
---|
| 748 | (make-constant-ctype :type (specifier-type type env))) |
---|
[6] | 749 | |
---|
| 750 | |
---|
| 751 | ;;; Parse-Args-Types -- Internal |
---|
| 752 | ;;; |
---|
| 753 | ;;; Given a lambda-list like values type specification and a Args-Type |
---|
| 754 | ;;; structure, fill in the slots in the structure accordingly. This is used |
---|
| 755 | ;;; for both FUNCTION and VALUES types. |
---|
| 756 | ;;; |
---|
| 757 | |
---|
[9892] | 758 | (defun parse-args-types (lambda-list result &optional env) |
---|
[6] | 759 | (multiple-value-bind (required optional restp rest keyp keys allowp aux) |
---|
| 760 | (parse-lambda-list lambda-list) |
---|
| 761 | (when aux |
---|
| 762 | (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) |
---|
[9892] | 763 | (flet ((parse (spec) (specifier-type spec env))) |
---|
| 764 | (setf (args-ctype-required result) (mapcar #'parse required)) |
---|
| 765 | (setf (args-ctype-optional result) (mapcar #'parse optional)) |
---|
| 766 | (setf (args-ctype-rest result) (if restp (parse rest) nil)) |
---|
| 767 | (setf (args-ctype-keyp result) keyp) |
---|
| 768 | (let* ((key-info ())) |
---|
| 769 | (dolist (key keys) |
---|
[6] | 770 | (when (or (atom key) (/= (length key) 2)) |
---|
[279] | 771 | (signal-program-error "Keyword type description is not a two-list: ~S." key)) |
---|
[6] | 772 | (let ((kwd (first key))) |
---|
| 773 | (when (member kwd key-info :test #'eq :key #'(lambda (x) (key-info-name x))) |
---|
[279] | 774 | (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) |
---|
[6] | 775 | (push (make-key-info :name kwd |
---|
[9892] | 776 | :type (parse (second key))) key-info))) |
---|
| 777 | (setf (args-ctype-keywords result) (nreverse key-info))) |
---|
| 778 | (setf (args-ctype-allowp result) allowp)))) |
---|
[6] | 779 | |
---|
| 780 | ;;; Unparse-Args-Types -- Internal |
---|
| 781 | ;;; |
---|
| 782 | ;;; Return the lambda-list like type specification corresponding |
---|
| 783 | ;;; to a Args-Type. |
---|
| 784 | ;;; |
---|
| 785 | (defun unparse-args-types (type) |
---|
| 786 | (let* ((result ())) |
---|
| 787 | |
---|
| 788 | (dolist (arg (args-ctype-required type)) |
---|
| 789 | (push (type-specifier arg) result)) |
---|
| 790 | |
---|
| 791 | (when (args-ctype-optional type) |
---|
| 792 | (push '&optional result) |
---|
| 793 | (dolist (arg (args-ctype-optional type)) |
---|
| 794 | (push (type-specifier arg) result))) |
---|
| 795 | |
---|
| 796 | (when (args-ctype-rest type) |
---|
| 797 | (push '&rest result) |
---|
| 798 | (push (type-specifier (args-ctype-rest type)) result)) |
---|
| 799 | |
---|
| 800 | (when (args-ctype-keyp type) |
---|
| 801 | (push '&key result) |
---|
| 802 | (dolist (key (args-ctype-keywords type)) |
---|
| 803 | (push (list (key-info-name key) |
---|
| 804 | (type-specifier (key-info-type key))) result))) |
---|
| 805 | |
---|
| 806 | (when (args-ctype-allowp type) |
---|
| 807 | (push '&allow-other-keys result)) |
---|
| 808 | |
---|
| 809 | (nreverse result))) |
---|
| 810 | |
---|
[9892] | 811 | (def-type-translator function (&optional (args '*) (result '*) &environment env) |
---|
[6] | 812 | (let ((res (make-function-ctype |
---|
[9892] | 813 | :returns (values-specifier-type result env)))) |
---|
[6] | 814 | (if (eq args '*) |
---|
| 815 | (setf (function-ctype-wild-args res) t) |
---|
[9892] | 816 | (parse-args-types args res env)) |
---|
[6] | 817 | res)) |
---|
| 818 | |
---|
[9892] | 819 | (def-type-translator values (&rest values &environment env) |
---|
[6] | 820 | (let ((res (make-values-ctype))) |
---|
[9892] | 821 | (parse-args-types values res env) |
---|
[279] | 822 | (when (or (values-ctype-keyp res) (values-ctype-allowp res)) |
---|
| 823 | (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s" |
---|
| 824 | res)) |
---|
[6] | 825 | res)) |
---|
| 826 | |
---|
| 827 | ;;; Single-Value-Type -- Interface |
---|
| 828 | ;;; |
---|
| 829 | ;;; Return the type of the first value indicated by Type. This is used by |
---|
| 830 | ;;; people who don't want to have to deal with values types. |
---|
| 831 | ;;; |
---|
| 832 | (defun single-value-type (type) |
---|
| 833 | (declare (type ctype type)) |
---|
| 834 | (cond ((values-ctype-p type) |
---|
| 835 | (or (car (args-ctype-required type)) |
---|
[279] | 836 | (if (args-ctype-optional type) |
---|
| 837 | (type-union (car (args-ctype-optional type)) |
---|
| 838 | (specifier-type 'null))) |
---|
[6] | 839 | (args-ctype-rest type) |
---|
[279] | 840 | (specifier-type 'null))) |
---|
[6] | 841 | ((eq type *wild-type*) |
---|
| 842 | *universal-type*) |
---|
| 843 | (t |
---|
| 844 | type))) |
---|
| 845 | |
---|
| 846 | |
---|
| 847 | ;;; FUNCTION-TYPE-NARGS -- Interface |
---|
| 848 | ;;; |
---|
| 849 | ;;; Return the minmum number of arguments that a function can be called |
---|
| 850 | ;;; with, and the maximum number or NIL. If not a function type, return |
---|
| 851 | ;;; NIL, NIL. |
---|
| 852 | ;;; |
---|
| 853 | (defun function-type-nargs (type) |
---|
| 854 | (declare (type ctype type)) |
---|
| 855 | (if (function-ctype-p type) |
---|
| 856 | (let ((fixed (length (args-ctype-required type)))) |
---|
| 857 | (if (or (args-ctype-rest type) |
---|
| 858 | (args-ctype-keyp type) |
---|
| 859 | (args-ctype-allowp type)) |
---|
| 860 | (values fixed nil) |
---|
| 861 | (values fixed (+ fixed (length (args-ctype-optional type)))))) |
---|
| 862 | (values nil nil))) |
---|
| 863 | |
---|
| 864 | |
---|
| 865 | ;;; Values-Types -- Interface |
---|
| 866 | ;;; |
---|
| 867 | ;;; Determine if Type corresponds to a definite number of values. The first |
---|
| 868 | ;;; value is a list of the types for each value, and the second value is the |
---|
| 869 | ;;; number of values. If the number of values is not fixed, then return NIL |
---|
| 870 | ;;; and :Unknown. |
---|
| 871 | ;;; |
---|
| 872 | (defun values-types (type) |
---|
| 873 | (declare (type ctype type)) |
---|
| 874 | (cond ((eq type *wild-type*) |
---|
| 875 | (values nil :unknown)) |
---|
| 876 | ((not (values-ctype-p type)) |
---|
| 877 | (values (list type) 1)) |
---|
| 878 | ((or (args-ctype-optional type) |
---|
| 879 | (args-ctype-rest type) |
---|
| 880 | (args-ctype-keyp type) |
---|
| 881 | (args-ctype-allowp type)) |
---|
| 882 | (values nil :unknown)) |
---|
| 883 | (t |
---|
| 884 | (let ((req (args-ctype-required type))) |
---|
| 885 | (values (mapcar #'single-value-type req) (length req)))))) |
---|
| 886 | |
---|
| 887 | |
---|
| 888 | ;;; Values-Type-Types -- Internal |
---|
| 889 | ;;; |
---|
| 890 | ;;; Return two values: |
---|
| 891 | ;;; 1] A list of all the positional (fixed and optional) types. |
---|
| 892 | ;;; 2] The rest type (if any). If keywords allowed, *universal-type*. If no |
---|
| 893 | ;;; keywords or rest, *empty-type*. |
---|
| 894 | ;;; |
---|
[279] | 895 | (defun values-type-types (type &optional (default-type *empty-type*)) |
---|
[6] | 896 | (declare (type values-type type)) |
---|
| 897 | (values (append (args-ctype-required type) |
---|
[279] | 898 | (args-ctype-optional type)) |
---|
[6] | 899 | (cond ((args-ctype-keyp type) *universal-type*) |
---|
[279] | 900 | ((args-ctype-rest type)) |
---|
| 901 | (t default-type)))) |
---|
[6] | 902 | |
---|
| 903 | |
---|
| 904 | ;;; Fixed-Values-Op -- Internal |
---|
| 905 | ;;; |
---|
| 906 | ;;; Return a list of Operation applied to the types in Types1 and Types2, |
---|
| 907 | ;;; padding with Rest2 as needed. Types1 must not be shorter than Types2. The |
---|
| 908 | ;;; second value is T if Operation always returned a true second value. |
---|
| 909 | ;;; |
---|
| 910 | (defun fixed-values-op (types1 types2 rest2 operation) |
---|
| 911 | (declare (list types1 types2) (type ctype rest2) (type function operation)) |
---|
| 912 | (let ((exact t)) |
---|
| 913 | (values (mapcar #'(lambda (t1 t2) |
---|
| 914 | (multiple-value-bind (res win) |
---|
[279] | 915 | (funcall operation t1 t2) |
---|
[6] | 916 | (unless win (setq exact nil)) |
---|
| 917 | res)) |
---|
| 918 | types1 |
---|
| 919 | (append types2 |
---|
[279] | 920 | (make-list (- (length types1) (length types2)) |
---|
| 921 | :initial-element rest2))) |
---|
[6] | 922 | exact))) |
---|
| 923 | |
---|
| 924 | ;;; Coerce-To-Values -- Internal |
---|
| 925 | ;;; |
---|
| 926 | ;;; If Type isn't a values type, then make it into one: |
---|
| 927 | ;;; <type> ==> (values type &rest t) |
---|
| 928 | ;;; |
---|
| 929 | (defun coerce-to-values (type) |
---|
| 930 | (declare (type ctype type)) |
---|
| 931 | (if (values-ctype-p type) |
---|
| 932 | type |
---|
[279] | 933 | (make-values-ctype :required (list type)))) |
---|
[6] | 934 | |
---|
| 935 | |
---|
| 936 | ;;; Args-Type-Op -- Internal |
---|
| 937 | ;;; |
---|
| 938 | ;;; Do the specified Operation on Type1 and Type2, which may be any type, |
---|
| 939 | ;;; including Values types. With values types such as: |
---|
| 940 | ;;; (values a0 a1) |
---|
| 941 | ;;; (values b0 b1) |
---|
| 942 | ;;; |
---|
| 943 | ;;; We compute the more useful result: |
---|
| 944 | ;;; (values (<operation> a0 b0) (<operation> a1 b1)) |
---|
| 945 | ;;; |
---|
| 946 | ;;; Rather than the precise result: |
---|
| 947 | ;;; (<operation> (values a0 a1) (values b0 b1)) |
---|
| 948 | ;;; |
---|
| 949 | ;;; This has the virtue of always keeping the values type specifier outermost, |
---|
| 950 | ;;; and retains all of the information that is really useful for static type |
---|
| 951 | ;;; analysis. We want to know what is always true of each value independently. |
---|
| 952 | ;;; It is worthless to know that IF the first value is B0 then the second will |
---|
| 953 | ;;; be B1. |
---|
| 954 | ;;; |
---|
| 955 | ;;; If the values count signatures differ, then we produce result with the |
---|
| 956 | ;;; required value count chosen by Nreq when applied to the number of required |
---|
| 957 | ;;; values in type1 and type2. Any &key values become &rest T (anyone who uses |
---|
| 958 | ;;; keyword values deserves to lose.) |
---|
| 959 | ;;; |
---|
| 960 | ;;; The second value is true if the result is definitely empty or if Operation |
---|
| 961 | ;;; returned true as its second value each time we called it. Since we |
---|
| 962 | ;;; approximate the intersection of values types, the second value being true |
---|
| 963 | ;;; doesn't mean the result is exact. |
---|
| 964 | ;;; |
---|
[279] | 965 | (defun args-type-op (type1 type2 operation nreq default-type) |
---|
| 966 | (declare (type ctype type1 type2 default-type) |
---|
| 967 | (type function operation nreq)) |
---|
| 968 | (if (eq type1 type2) |
---|
| 969 | (values type1 t) |
---|
| 970 | (if (or (values-ctype-p type1) (values-ctype-p type2)) |
---|
| 971 | (let ((type1 (coerce-to-values type1)) |
---|
[6] | 972 | (type2 (coerce-to-values type2))) |
---|
| 973 | (multiple-value-bind (types1 rest1) |
---|
[279] | 974 | (values-type-types type1 default-type) |
---|
[6] | 975 | (multiple-value-bind (types2 rest2) |
---|
[279] | 976 | (values-type-types type2 default-type) |
---|
[6] | 977 | (multiple-value-bind (rest rest-exact) |
---|
[279] | 978 | (funcall operation rest1 rest2) |
---|
[6] | 979 | (multiple-value-bind |
---|
| 980 | (res res-exact) |
---|
| 981 | (if (< (length types1) (length types2)) |
---|
[279] | 982 | (fixed-values-op types2 types1 rest1 operation) |
---|
| 983 | (fixed-values-op types1 types2 rest2 operation)) |
---|
| 984 | (let* ((req (funcall nreq |
---|
| 985 | (length (args-ctype-required type1)) |
---|
| 986 | (length (args-ctype-required type2)))) |
---|
| 987 | (required (subseq res 0 req)) |
---|
| 988 | (opt (subseq res req)) |
---|
| 989 | (opt-last (position rest opt :test-not #'type= |
---|
| 990 | :from-end t))) |
---|
| 991 | (if (find *empty-type* required :test #'type=) |
---|
| 992 | (values *empty-type* t) |
---|
| 993 | (values (make-values-ctype |
---|
| 994 | :required required |
---|
| 995 | :optional (if opt-last |
---|
| 996 | (subseq opt 0 (1+ opt-last)) |
---|
| 997 | ()) |
---|
| 998 | :rest (if (eq rest *empty-type*) nil rest)) |
---|
| 999 | (and rest-exact res-exact))))))))) |
---|
| 1000 | (funcall operation type1 type2)))) |
---|
[6] | 1001 | |
---|
| 1002 | ;;; Values-Type-Union, Values-Type-Intersection -- Interface |
---|
| 1003 | ;;; |
---|
| 1004 | ;;; Do a union or intersection operation on types that might be values |
---|
| 1005 | ;;; types. The result is optimized for utility rather than exactness, but it |
---|
| 1006 | ;;; is guaranteed that it will be no smaller (more restrictive) than the |
---|
| 1007 | ;;; precise result. |
---|
| 1008 | ;;; |
---|
| 1009 | |
---|
| 1010 | (defun values-type-union (type1 type2) |
---|
| 1011 | (declare (type ctype type1 type2)) |
---|
| 1012 | (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) |
---|
[279] | 1013 | ((eq type1 *empty-type*) type2) |
---|
| 1014 | ((eq type2 *empty-type*) type1) |
---|
| 1015 | (t |
---|
| 1016 | (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) |
---|
[6] | 1017 | |
---|
| 1018 | (defun values-type-intersection (type1 type2) |
---|
| 1019 | (declare (type ctype type1 type2)) |
---|
| 1020 | (cond ((eq type1 *wild-type*) (values type2 t)) |
---|
| 1021 | ((eq type2 *wild-type*) (values type1 t)) |
---|
| 1022 | (t |
---|
[279] | 1023 | (args-type-op type1 type2 #'type-intersection #'max |
---|
| 1024 | (specifier-type 'null))))) |
---|
[6] | 1025 | |
---|
| 1026 | |
---|
| 1027 | ;;; Values-Types-Intersect -- Interface |
---|
| 1028 | ;;; |
---|
| 1029 | ;;; Like Types-Intersect, except that it sort of works on values types. |
---|
| 1030 | ;;; Note that due to the semantics of Values-Type-Intersection, this might |
---|
| 1031 | ;;; return {T, T} when there isn't really any intersection (?). |
---|
| 1032 | ;;; |
---|
| 1033 | (defun values-types-intersect (type1 type2) |
---|
| 1034 | (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) |
---|
| 1035 | (values t t)) |
---|
| 1036 | ((or (values-ctype-p type1) (values-ctype-p type2)) |
---|
| 1037 | (multiple-value-bind (res win) |
---|
| 1038 | (values-type-intersection type1 type2) |
---|
| 1039 | (values (not (eq res *empty-type*)) |
---|
| 1040 | win))) |
---|
| 1041 | (t |
---|
| 1042 | (types-intersect type1 type2)))) |
---|
| 1043 | |
---|
| 1044 | ;;; Values-Subtypep -- Interface |
---|
| 1045 | ;;; |
---|
| 1046 | ;;; A subtypep-like operation that can be used on any types, including |
---|
| 1047 | ;;; values types. |
---|
| 1048 | ;;; |
---|
| 1049 | |
---|
| 1050 | (defun values-subtypep (type1 type2) |
---|
| 1051 | (declare (type ctype type1 type2)) |
---|
| 1052 | (cond ((eq type2 *wild-type*) (values t t)) |
---|
[279] | 1053 | ((eq type1 *wild-type*) |
---|
| 1054 | (values (eq type2 *universal-type*) t)) |
---|
| 1055 | ((not (values-types-intersect type1 type2)) |
---|
| 1056 | (values nil t)) |
---|
| 1057 | (t |
---|
| 1058 | (if (or (values-ctype-p type1) (values-ctype-p type2)) |
---|
| 1059 | (let ((type1 (coerce-to-values type1)) |
---|
| 1060 | (type2 (coerce-to-values type2))) |
---|
| 1061 | (multiple-value-bind (types1 rest1) |
---|
| 1062 | (values-type-types type1) |
---|
| 1063 | (multiple-value-bind (types2 rest2) |
---|
| 1064 | (values-type-types type2) |
---|
| 1065 | (cond ((< (length (values-ctype-required type1)) |
---|
| 1066 | (length (values-ctype-required type2))) |
---|
| 1067 | (values nil t)) |
---|
| 1068 | ((< (length types1) (length types2)) |
---|
| 1069 | (values nil nil)) |
---|
| 1070 | ((or (values-ctype-keyp type1) |
---|
| 1071 | (values-ctype-keyp type2)) |
---|
| 1072 | (values nil nil)) |
---|
| 1073 | (t |
---|
| 1074 | (do ((t1 types1 (rest t1)) |
---|
| 1075 | (t2 types2 (rest t2))) |
---|
| 1076 | ((null t2) |
---|
| 1077 | (csubtypep rest1 rest2)) |
---|
| 1078 | (multiple-value-bind |
---|
| 1079 | (res win-p) |
---|
| 1080 | (csubtypep (first t1) (first t2)) |
---|
| 1081 | (unless win-p |
---|
| 1082 | (return (values nil nil))) |
---|
| 1083 | (unless res |
---|
| 1084 | (return (values nil t)))))))))) |
---|
| 1085 | (csubtypep type1 type2))))) |
---|
[6] | 1086 | |
---|
| 1087 | |
---|
| 1088 | ;;;; Type method interfaces: |
---|
| 1089 | |
---|
| 1090 | ;;; Csubtypep -- Interface |
---|
| 1091 | ;;; |
---|
| 1092 | ;;; Like subtypep, only works on Type structures. |
---|
| 1093 | ;;; |
---|
| 1094 | (defun csubtypep (type1 type2) |
---|
| 1095 | (declare (type ctype type1 type2)) |
---|
| 1096 | (unless (typep type1 'ctype) |
---|
| 1097 | (report-bad-arg type1 'ctype)) |
---|
| 1098 | (unless (typep type2 'ctype) |
---|
| 1099 | (report-bad-arg type2 'ctype)) |
---|
| 1100 | (cond ((or (eq type1 type2) |
---|
[279] | 1101 | (eq type1 *empty-type*) |
---|
| 1102 | (eq type2 *wild-type*)) |
---|
| 1103 | (values t t)) |
---|
| 1104 | (t |
---|
| 1105 | (invoke-type-method :simple-subtypep :complex-subtypep-arg2 |
---|
| 1106 | type1 type2 |
---|
| 1107 | :complex-arg1 :complex-subtypep-arg1)))) |
---|
[6] | 1108 | ;;; Type= -- Interface |
---|
| 1109 | ;;; |
---|
| 1110 | ;;; If two types are definitely equivalent, return true. The second value |
---|
| 1111 | ;;; indicates whether the first value is definitely correct. This should only |
---|
| 1112 | ;;; fail in the presence of Hairy types. |
---|
| 1113 | ;;; |
---|
| 1114 | |
---|
| 1115 | (defun type= (type1 type2) |
---|
| 1116 | (declare (type ctype type1 type2)) |
---|
| 1117 | (if (eq type1 type2) |
---|
| 1118 | (values t t) |
---|
| 1119 | (invoke-type-method :simple-= :complex-= type1 type2))) |
---|
| 1120 | |
---|
| 1121 | ;;; TYPE/= -- Interface |
---|
| 1122 | ;;; |
---|
| 1123 | ;;; Not exactly the negation of TYPE=, since when the relationship is |
---|
| 1124 | ;;; uncertain, we still return NIL, NIL. This is useful in cases where the |
---|
| 1125 | ;;; conservative assumption is =. |
---|
| 1126 | ;;; |
---|
| 1127 | (defun type/= (type1 type2) |
---|
| 1128 | (declare (type ctype type1 type2)) |
---|
| 1129 | (multiple-value-bind (res win) |
---|
[279] | 1130 | (type= type1 type2) |
---|
[6] | 1131 | (if win |
---|
| 1132 | (values (not res) t) |
---|
| 1133 | (values nil nil)))) |
---|
| 1134 | |
---|
| 1135 | ;;; Type-Union -- Interface |
---|
| 1136 | ;;; |
---|
| 1137 | ;;; Find a type which includes both types. Any inexactness is represented |
---|
| 1138 | ;;; by the fuzzy element types; we return a single value that is precise to the |
---|
| 1139 | ;;; best of our knowledge. This result is simplified into the canonical form, |
---|
| 1140 | ;;; thus is not a UNION type unless there is no other way to represent the |
---|
| 1141 | ;;; result. |
---|
| 1142 | ;;; |
---|
| 1143 | |
---|
[279] | 1144 | (defun type-union (&rest input-types) |
---|
| 1145 | (%type-union input-types)) |
---|
| 1146 | |
---|
| 1147 | (defun %type-union (input-types) |
---|
| 1148 | (let* ((simplified (simplify-unions input-types))) |
---|
| 1149 | (cond ((null simplified) *empty-type*) |
---|
| 1150 | ((null (cdr simplified)) (car simplified)) |
---|
| 1151 | (t (make-union-ctype simplified))))) |
---|
| 1152 | |
---|
| 1153 | (defun simplify-unions (types) |
---|
| 1154 | (when types |
---|
| 1155 | (multiple-value-bind (first rest) |
---|
| 1156 | (if (union-ctype-p (car types)) |
---|
| 1157 | (values (car (union-ctype-types (car types))) |
---|
| 1158 | (append (cdr (union-ctype-types (car types))) |
---|
| 1159 | (cdr types))) |
---|
| 1160 | (values (car types) (cdr types))) |
---|
| 1161 | (let ((rest (simplify-unions rest)) u) |
---|
| 1162 | (dolist (r rest (cons first rest)) |
---|
| 1163 | (when (setq u (type-union2 first r)) |
---|
| 1164 | (return (simplify-unions (nsubstitute u r rest))))))))) |
---|
| 1165 | |
---|
| 1166 | (defun type-union2 (type1 type2) |
---|
[6] | 1167 | (declare (type ctype type1 type2)) |
---|
[279] | 1168 | (setq type1 (reparse-unknown-ctype type1)) |
---|
| 1169 | (setq type2 (reparse-unknown-ctype type2)) |
---|
| 1170 | (cond ((eq type1 type2) type1) |
---|
| 1171 | ((csubtypep type1 type2) type2) |
---|
| 1172 | ((csubtypep type2 type1) type1) |
---|
| 1173 | (t |
---|
| 1174 | (flet ((1way (x y) |
---|
| 1175 | (invoke-type-method :simple-union :complex-union |
---|
| 1176 | x y |
---|
| 1177 | :default nil))) |
---|
| 1178 | (or (1way type1 type2) |
---|
| 1179 | (1way type2 type1)))))) |
---|
[6] | 1180 | |
---|
[279] | 1181 | ;;; Return as restrictive and simple a type as we can discover that is |
---|
| 1182 | ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At |
---|
| 1183 | ;;; worst, we arbitrarily return one of the arguments as the first |
---|
| 1184 | ;;; value (trying not to return a hairy type). |
---|
| 1185 | (defun type-approx-intersection2 (type1 type2) |
---|
| 1186 | (cond ((type-intersection2 type1 type2)) |
---|
| 1187 | ((hairy-ctype-p type1) type2) |
---|
| 1188 | (t type1))) |
---|
| 1189 | |
---|
| 1190 | |
---|
[6] | 1191 | ;;; Type-Intersection -- Interface |
---|
| 1192 | ;;; |
---|
| 1193 | ;;; Return as restrictive a type as we can discover that is no more |
---|
| 1194 | ;;; restrictive than the intersection of Type1 and Type2. The second value is |
---|
| 1195 | ;;; true if the result is exact. At worst, we randomly return one of the |
---|
| 1196 | ;;; arguments as the first value (trying not to return a hairy type). |
---|
| 1197 | ;;; |
---|
| 1198 | |
---|
[279] | 1199 | (defun type-intersection (&rest input-types) |
---|
| 1200 | (%type-intersection input-types)) |
---|
| 1201 | |
---|
| 1202 | (defun %type-intersection (input-types) |
---|
| 1203 | (let ((simplified (simplify-intersections input-types))) |
---|
[5602] | 1204 | ;;(declare (type (vector ctype) simplified)) |
---|
[279] | 1205 | ;; We want to have a canonical representation of types (or failing |
---|
| 1206 | ;; that, punt to HAIRY-TYPE). Canonical representation would have |
---|
| 1207 | ;; intersections inside unions but not vice versa, since you can |
---|
| 1208 | ;; always achieve that by the distributive rule. But we don't want |
---|
| 1209 | ;; to just apply the distributive rule, since it would be too easy |
---|
| 1210 | ;; to end up with unreasonably huge type expressions. So instead |
---|
| 1211 | ;; we try to generate a simple type by distributing the union; if |
---|
| 1212 | ;; the type can't be made simple, we punt to HAIRY-TYPE. |
---|
| 1213 | (if (and (cdr simplified) (some #'union-ctype-p simplified)) |
---|
[5602] | 1214 | (let* ((first-union (find-if #'union-ctype-p simplified)) |
---|
| 1215 | (other-types (remove first-union simplified)) |
---|
| 1216 | (distributed (maybe-distribute-one-union first-union other-types))) |
---|
| 1217 | (if distributed |
---|
| 1218 | (apply #'type-union distributed) |
---|
| 1219 | (make-hairy-ctype |
---|
| 1220 | :specifier `(and ,@(mapcar #'type-specifier simplified))))) |
---|
| 1221 | (cond |
---|
| 1222 | ((null simplified) *universal-type*) |
---|
| 1223 | ((null (cdr simplified)) (car simplified)) |
---|
| 1224 | (t (make-intersection-ctype |
---|
| 1225 | (some #'(lambda (c) (ctype-enumerable c)) simplified) |
---|
| 1226 | simplified)))))) |
---|
[279] | 1227 | |
---|
| 1228 | (defun simplify-intersections (types) |
---|
| 1229 | (when types |
---|
| 1230 | (multiple-value-bind (first rest) |
---|
| 1231 | (if (intersection-ctype-p (car types)) |
---|
| 1232 | (values (car (intersection-ctype-types (car types))) |
---|
| 1233 | (append (cdr (intersection-ctype-types (car types))) |
---|
| 1234 | (cdr types))) |
---|
| 1235 | (values (car types) (cdr types))) |
---|
| 1236 | (let ((rest (simplify-intersections rest)) u) |
---|
| 1237 | (dolist (r rest (cons first rest)) |
---|
| 1238 | (when (setq u (type-intersection2 first r)) |
---|
| 1239 | (return (simplify-intersections (nsubstitute u r rest))))))))) |
---|
| 1240 | |
---|
| 1241 | (defun type-intersection2 (type1 type2) |
---|
[6] | 1242 | (declare (type ctype type1 type2)) |
---|
[279] | 1243 | (setq type1 (reparse-unknown-ctype type1)) |
---|
| 1244 | (setq type2 (reparse-unknown-ctype type2)) |
---|
| 1245 | (cond ((eq type1 type2) |
---|
| 1246 | type1) |
---|
| 1247 | ((or (intersection-ctype-p type1) |
---|
| 1248 | (intersection-ctype-p type2)) |
---|
| 1249 | ;; Intersections of INTERSECTION-TYPE should have the |
---|
| 1250 | ;; INTERSECTION-CTYPE-TYPES values broken out and intersected |
---|
| 1251 | ;; separately. The full TYPE-INTERSECTION function knows how |
---|
| 1252 | ;; to do that, so let it handle it. |
---|
| 1253 | (type-intersection type1 type2)) |
---|
| 1254 | ;; |
---|
| 1255 | ;; (AND (FUNCTION (T) T) GENERIC-FUNCTION) for instance, but |
---|
| 1256 | ;; not (AND (FUNCTION (T) T) (FUNCTION (T) T)). |
---|
| 1257 | ((let ((function (specifier-type 'function))) |
---|
| 1258 | (or (and (function-ctype-p type1) |
---|
| 1259 | (not (or (function-ctype-p type2) (eq function type2))) |
---|
| 1260 | (csubtypep type2 function) |
---|
| 1261 | (not (csubtypep function type2))) |
---|
| 1262 | (and (function-ctype-p type2) |
---|
| 1263 | (not (or (function-ctype-p type1) (eq function type1))) |
---|
| 1264 | (csubtypep type1 function) |
---|
| 1265 | (not (csubtypep function type1))))) |
---|
| 1266 | nil) |
---|
| 1267 | (t |
---|
| 1268 | (flet ((1way (x y) |
---|
| 1269 | (invoke-type-method :simple-intersection |
---|
| 1270 | :complex-intersection |
---|
| 1271 | x y |
---|
| 1272 | :default :no-type-method-found))) |
---|
| 1273 | (let ((xy (1way type1 type2))) |
---|
| 1274 | (or (and (not (eql xy :no-type-method-found)) xy) |
---|
| 1275 | (let ((yx (1way type2 type1))) |
---|
| 1276 | (or (and (not (eql yx :no-type-method-found)) yx) |
---|
| 1277 | (cond ((and (eql xy :no-type-method-found) |
---|
| 1278 | (eql yx :no-type-method-found)) |
---|
| 1279 | *empty-type*) |
---|
| 1280 | (t |
---|
| 1281 | nil)))))))))) |
---|
[6] | 1282 | |
---|
[279] | 1283 | |
---|
| 1284 | |
---|
| 1285 | (defun maybe-distribute-one-union (union-type types) |
---|
| 1286 | (let* ((intersection (apply #'type-intersection types)) |
---|
| 1287 | (union (mapcar (lambda (x) (type-intersection x intersection)) |
---|
| 1288 | (union-ctype-types union-type)))) |
---|
| 1289 | (if (notany (lambda (x) |
---|
| 1290 | (or (hairy-ctype-p x) |
---|
| 1291 | (intersection-ctype-p x))) |
---|
| 1292 | union) |
---|
| 1293 | union |
---|
| 1294 | nil))) |
---|
| 1295 | |
---|
[6] | 1296 | ;;; Types-Intersect -- Interface |
---|
| 1297 | ;;; |
---|
| 1298 | ;;; The first value is true unless the types don't intersect. The second |
---|
| 1299 | ;;; value is true if the first value is definitely correct. NIL is considered |
---|
| 1300 | ;;; to intersect with any type. If T is a subtype of either type, then we also |
---|
| 1301 | ;;; return T, T. This way we consider hairy types to intersect with T. |
---|
| 1302 | ;;; |
---|
| 1303 | (defun types-intersect (type1 type2) |
---|
| 1304 | (declare (type ctype type1 type2)) |
---|
| 1305 | (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) |
---|
| 1306 | (values t t) |
---|
[279] | 1307 | (let ((intersection2 (type-intersection2 type1 type2))) |
---|
| 1308 | (cond ((not intersection2) |
---|
[6] | 1309 | (if (or (csubtypep *universal-type* type1) |
---|
| 1310 | (csubtypep *universal-type* type2)) |
---|
| 1311 | (values t t) |
---|
| 1312 | (values t nil))) |
---|
[279] | 1313 | ((eq intersection2 *empty-type*) (values nil t)) |
---|
[6] | 1314 | (t (values t t)))))) |
---|
| 1315 | |
---|
| 1316 | ;;; Type-Specifier -- Interface |
---|
| 1317 | ;;; |
---|
| 1318 | ;;; Return a Common Lisp type specifier corresponding to this type. |
---|
| 1319 | ;;; |
---|
| 1320 | (defun type-specifier (type) |
---|
[117] | 1321 | (unless (ctype-p type) |
---|
| 1322 | (setq type (require-type type 'ctype))) |
---|
| 1323 | (locally |
---|
| 1324 | (declare (type ctype type)) |
---|
| 1325 | (funcall (type-class-unparse (ctype-class-info type)) type))) |
---|
[6] | 1326 | |
---|
| 1327 | ;;; VALUES-SPECIFIER-TYPE -- Interface |
---|
| 1328 | ;;; |
---|
| 1329 | ;;; Return the type structure corresponding to a type specifier. We pick |
---|
| 1330 | ;;; off Structure types as a special case. |
---|
| 1331 | ;;; |
---|
| 1332 | |
---|
[9892] | 1333 | (defun values-specifier-type-internal (orig env) |
---|
[6] | 1334 | (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes |
---|
| 1335 | |
---|
[9892] | 1336 | ;; Now that we have our hands on the environment, we could pass it into type-expand, |
---|
| 1337 | ;; but we'd have no way of knowing whether the expansion depended on the env, so |
---|
| 1338 | ;; we wouldn't know if the result is safe to cache. So for now don't let type |
---|
| 1339 | ;; expanders see the env, which just means they won't see compile-time types. |
---|
| 1340 | (let ((spec (type-expand orig #+not-yet env))) |
---|
[6] | 1341 | (cond |
---|
| 1342 | ((and (not (eq spec orig)) |
---|
| 1343 | (info-type-builtin spec))) |
---|
[9892] | 1344 | ((or (eq (info-type-kind spec) :instance) |
---|
| 1345 | (and (symbolp spec) |
---|
| 1346 | (typep (find-class spec nil env) 'compile-time-class))) |
---|
| 1347 | (let* ((class-ctype (%class.ctype (find-class spec t env)))) |
---|
[6] | 1348 | (or (class-ctype-translation class-ctype) |
---|
| 1349 | class-ctype))) |
---|
| 1350 | ((typep spec 'class) |
---|
| 1351 | (let* ((class-ctype (%class.ctype spec))) |
---|
| 1352 | (or (class-ctype-translation class-ctype) |
---|
| 1353 | class-ctype))) |
---|
| 1354 | ((let ((cell (find-builtin-cell spec nil))) |
---|
| 1355 | (and cell (cdr cell)))) |
---|
| 1356 | (t |
---|
| 1357 | (let* ((lspec (if (atom spec) (list spec) spec)) |
---|
| 1358 | (fun (info-type-translator (car lspec)))) |
---|
[9892] | 1359 | (cond (fun (funcall fun lspec env)) |
---|
[6] | 1360 | ((or (and (consp spec) (symbolp (car spec))) |
---|
| 1361 | (symbolp spec)) |
---|
| 1362 | (when *type-system-initialized* |
---|
| 1363 | (signal 'parse-unknown-type :specifier spec)) |
---|
| 1364 | ;; |
---|
| 1365 | ;; Inhibit caching... |
---|
| 1366 | nil) |
---|
| 1367 | (t |
---|
| 1368 | (error "Bad thing to be a type specifier: ~S." spec))))))))) |
---|
| 1369 | |
---|
| 1370 | (eval-when (:compile-toplevel :execute) |
---|
[297] | 1371 | (defconstant type-cache-size (ash 1 12)) |
---|
[6] | 1372 | (defconstant type-cache-mask (1- type-cache-size))) |
---|
| 1373 | |
---|
[9892] | 1374 | (defun compile-time-ctype-p (ctype) |
---|
| 1375 | (and (typep ctype 'class-ctype) |
---|
| 1376 | (typep (class-ctype-class ctype) 'compile-time-class))) |
---|
| 1377 | |
---|
| 1378 | |
---|
[586] | 1379 | ;;; We can get in trouble if we try to cache certain kinds of ctypes, |
---|
| 1380 | ;;; notably MEMBER types which refer to objects which might |
---|
| 1381 | ;;; be stack-allocated or might be EQUAL without being EQL. |
---|
| 1382 | (defun cacheable-ctype-p (ctype) |
---|
[10309] | 1383 | (case (istruct-cell-name (%svref ctype 0)) |
---|
[586] | 1384 | (member-ctype |
---|
| 1385 | (dolist (m (member-ctype-members ctype) t) |
---|
| 1386 | (when (or (typep m 'cons) |
---|
| 1387 | (typep m 'array)) |
---|
[589] | 1388 | (return nil)))) |
---|
[586] | 1389 | (union-ctype |
---|
| 1390 | (every #'cacheable-ctype-p (union-ctype-types ctype))) |
---|
| 1391 | (intersection-ctype |
---|
| 1392 | (every #'cacheable-ctype-p (intersection-ctype-types ctype))) |
---|
| 1393 | (array-ctype |
---|
| 1394 | (cacheable-ctype-p (array-ctype-element-type ctype))) |
---|
| 1395 | ((values-ctype function-ctype) |
---|
| 1396 | (and (every #'cacheable-ctype-p (values-ctype-required ctype)) |
---|
| 1397 | (every #'cacheable-ctype-p (values-ctype-optional ctype)) |
---|
| 1398 | (let* ((rest (values-ctype-rest ctype))) |
---|
| 1399 | (or (null rest) (cacheable-ctype-p rest))) |
---|
| 1400 | (every #'(lambda (info) |
---|
| 1401 | (cacheable-ctype-p (key-info-type info))) |
---|
| 1402 | (values-ctype-keywords ctype)) |
---|
[10309] | 1403 | (or (not (eq (istruct-cell-name (%svref ctype 0)) 'function-ctype)) |
---|
[586] | 1404 | (let* ((result (function-ctype-returns ctype))) |
---|
| 1405 | (or (null result) |
---|
| 1406 | (cacheable-ctype-p result)))))) |
---|
[589] | 1407 | (negation-ctype |
---|
| 1408 | (cacheable-ctype-p (negation-ctype-type ctype))) |
---|
| 1409 | (cons-ctype |
---|
| 1410 | (and (cacheable-ctype-p (cons-ctype-car-ctype ctype)) |
---|
| 1411 | (cacheable-ctype-p (cons-ctype-cdr-ctype ctype)))) |
---|
[9250] | 1412 | (unknown-ctype nil) |
---|
[9892] | 1413 | (class-ctype |
---|
| 1414 | (not (typep (class-ctype-class ctype) 'compile-time-class))) |
---|
[1668] | 1415 | ;; Anything else ? Simple things (numbers, classes) can't lose. |
---|
[586] | 1416 | (t t))) |
---|
| 1417 | |
---|
| 1418 | |
---|
| 1419 | |
---|
| 1420 | |
---|
[6] | 1421 | (defun hash-type-specifier (spec) |
---|
| 1422 | (logand (sxhash spec) type-cache-mask)) |
---|
| 1423 | |
---|
| 1424 | (let* ((type-cache-specs (make-array type-cache-size)) |
---|
| 1425 | (type-cache-ctypes (make-array type-cache-size)) |
---|
| 1426 | (probes 0) |
---|
| 1427 | (hits 0) |
---|
| 1428 | (ncleared 0) |
---|
| 1429 | (locked nil)) |
---|
| 1430 | |
---|
| 1431 | (defun clear-type-cache () |
---|
| 1432 | (%init-misc 0 type-cache-specs) |
---|
| 1433 | (%init-misc 0 type-cache-ctypes) |
---|
| 1434 | (incf ncleared) |
---|
| 1435 | nil) |
---|
| 1436 | |
---|
[9892] | 1437 | (defun values-specifier-type (spec &optional env) |
---|
[6] | 1438 | (if (typep spec 'class) |
---|
| 1439 | (let* ((class-ctype (%class.ctype spec))) |
---|
| 1440 | (or (class-ctype-translation class-ctype) class-ctype)) |
---|
| 1441 | (if locked |
---|
[9892] | 1442 | (or (values-specifier-type-internal spec env) |
---|
[6] | 1443 | (make-unknown-ctype :specifier spec)) |
---|
| 1444 | (unwind-protect |
---|
| 1445 | (progn |
---|
| 1446 | (setq locked t) |
---|
| 1447 | (if (or (symbolp spec) |
---|
| 1448 | (and (consp spec) (symbolp (car spec)))) |
---|
| 1449 | (let* ((idx (hash-type-specifier spec))) |
---|
| 1450 | (incf probes) |
---|
| 1451 | (if (equal (svref type-cache-specs idx) spec) |
---|
| 1452 | (progn |
---|
| 1453 | (incf hits) |
---|
| 1454 | (svref type-cache-ctypes idx)) |
---|
[9892] | 1455 | (let* ((ctype (values-specifier-type-internal spec env))) |
---|
[6] | 1456 | (if ctype |
---|
[586] | 1457 | (progn |
---|
| 1458 | (when (cacheable-ctype-p ctype) |
---|
| 1459 | (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed |
---|
| 1460 | (svref type-cache-ctypes idx) ctype)) |
---|
| 1461 | ctype) |
---|
[6] | 1462 | (make-unknown-ctype :specifier spec))))) |
---|
[9892] | 1463 | (values-specifier-type-internal spec env))) |
---|
[6] | 1464 | (setq locked nil))))) |
---|
| 1465 | |
---|
| 1466 | (defun type-cache-hit-rate () |
---|
| 1467 | (values hits probes)) |
---|
| 1468 | |
---|
| 1469 | (defun type-cache-locked-p () |
---|
| 1470 | locked) |
---|
| 1471 | |
---|
| 1472 | (defun lock-type-cache () |
---|
| 1473 | (setq locked t))) |
---|
| 1474 | |
---|
| 1475 | |
---|
| 1476 | |
---|
| 1477 | |
---|
| 1478 | |
---|
| 1479 | ;;; SPECIFIER-TYPE -- Interface |
---|
| 1480 | ;;; |
---|
| 1481 | ;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never return a |
---|
| 1482 | ;;; VALUES type. |
---|
| 1483 | ;;; |
---|
[9887] | 1484 | (defun specifier-type (x &optional env) |
---|
[9892] | 1485 | (let ((res (values-specifier-type x env))) |
---|
[6] | 1486 | (when (values-ctype-p res) |
---|
[279] | 1487 | (signal-program-error "VALUES type illegal in this context:~% ~S" x)) |
---|
[6] | 1488 | res)) |
---|
| 1489 | |
---|
[9892] | 1490 | (defun single-value-specifier-type (x &optional env) |
---|
| 1491 | (let ((res (specifier-type x env))) |
---|
[279] | 1492 | (if (eq res *wild-type*) |
---|
| 1493 | *universal-type* |
---|
| 1494 | res))) |
---|
[6] | 1495 | |
---|
[9892] | 1496 | (defun standardized-type-specifier (spec &optional env) |
---|
| 1497 | (handler-case |
---|
| 1498 | (type-specifier (specifier-type spec env)) |
---|
| 1499 | (parse-unknown-type () spec))) |
---|
[9240] | 1500 | |
---|
[279] | 1501 | (defun modified-numeric-type (base |
---|
| 1502 | &key |
---|
| 1503 | (class (numeric-ctype-class base)) |
---|
| 1504 | (format (numeric-ctype-format base)) |
---|
| 1505 | (complexp (numeric-ctype-complexp base)) |
---|
| 1506 | (low (numeric-ctype-low base)) |
---|
| 1507 | (high (numeric-ctype-high base)) |
---|
| 1508 | (enumerable (ctype-enumerable base))) |
---|
| 1509 | (make-numeric-ctype :class class |
---|
| 1510 | :format format |
---|
| 1511 | :complexp complexp |
---|
| 1512 | :low low |
---|
| 1513 | :high high |
---|
| 1514 | :enumerable enumerable)) |
---|
| 1515 | |
---|
[6] | 1516 | ;;; Precompute-Types -- Interface |
---|
| 1517 | ;;; |
---|
| 1518 | ;;; Take a list of type specifiers, compute the translation and define it as |
---|
| 1519 | ;;; a builtin type. |
---|
| 1520 | ;;; |
---|
| 1521 | |
---|
| 1522 | (defun precompute-types (specs) |
---|
| 1523 | (dolist (spec specs) |
---|
| 1524 | (let ((res (specifier-type spec))) |
---|
| 1525 | (when (numeric-ctype-p res) |
---|
| 1526 | (let ((pred (make-numeric-ctype-predicate res))) |
---|
| 1527 | (when pred (setf (numeric-ctype-predicate res) pred)))) |
---|
| 1528 | (unless (unknown-ctype-p res) |
---|
| 1529 | (setf (info-type-builtin spec) res) |
---|
| 1530 | (setf (info-type-kind spec) :primitive))))) |
---|
| 1531 | |
---|
| 1532 | ;;;; Builtin types. |
---|
| 1533 | |
---|
| 1534 | ;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be |
---|
| 1535 | ;;; super or sub types of all types, not just classes and * & NIL aren't |
---|
| 1536 | ;;; classes anyway, so it wouldn't make much sense to make them built-in |
---|
| 1537 | ;;; classes. |
---|
| 1538 | ;;; |
---|
| 1539 | |
---|
| 1540 | (defun define-named-ctype (name) |
---|
| 1541 | (let* ((ctype (%istruct 'named-ctype |
---|
| 1542 | (type-class-or-lose 'named) |
---|
| 1543 | nil |
---|
| 1544 | name))) |
---|
| 1545 | (setf (info-type-kind name) :builtin |
---|
| 1546 | (info-type-builtin name) ctype))) |
---|
| 1547 | |
---|
| 1548 | |
---|
| 1549 | (defvar *wild-type* (define-named-ctype '*)) |
---|
| 1550 | (defvar *empty-type* (define-named-ctype nil)) |
---|
| 1551 | (defvar *universal-type* (define-named-ctype t)) |
---|
| 1552 | |
---|
[7917] | 1553 | (defun named-ctype-p (x) |
---|
| 1554 | (istruct-typep x 'named-ctype)) |
---|
| 1555 | |
---|
| 1556 | (setf (type-predicate 'named-ctype) 'named-ctype-p) |
---|
| 1557 | |
---|
[6] | 1558 | (define-type-method (named :simple-=) (type1 type2) |
---|
| 1559 | (values (eq type1 type2) t)) |
---|
| 1560 | |
---|
[279] | 1561 | (define-type-method (named :complex-=) (type1 type2) |
---|
| 1562 | (cond |
---|
| 1563 | ((and (eq type2 *empty-type*) |
---|
| 1564 | (intersection-ctype-p type1) |
---|
| 1565 | ;; not allowed to be unsure on these... FIXME: keep the list |
---|
| 1566 | ;; of CL types that are intersection types once and only |
---|
| 1567 | ;; once. |
---|
| 1568 | (not (or (type= type1 (specifier-type 'ratio)) |
---|
| 1569 | (type= type1 (specifier-type 'keyword))))) |
---|
| 1570 | ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION |
---|
| 1571 | ;; STREAM) can get here. In general, we can't really tell |
---|
| 1572 | ;; whether these are equal to NIL or not, so |
---|
| 1573 | (values nil nil)) |
---|
| 1574 | ((type-might-contain-other-types-p type1) |
---|
| 1575 | (invoke-complex-=-other-method type1 type2)) |
---|
| 1576 | (t (values nil t)))) |
---|
| 1577 | |
---|
| 1578 | |
---|
[6] | 1579 | (define-type-method (named :simple-subtypep) (type1 type2) |
---|
| 1580 | (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) |
---|
| 1581 | |
---|
| 1582 | (define-type-method (named :complex-subtypep-arg1) (type1 type2) |
---|
[279] | 1583 | (cond ((eq type1 *empty-type*) |
---|
| 1584 | t) |
---|
| 1585 | (;; When TYPE2 might be the universal type in disguise |
---|
| 1586 | (type-might-contain-other-types-p type2) |
---|
| 1587 | ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods |
---|
| 1588 | ;; can delegate to us (more or less as CALL-NEXT-METHOD) when |
---|
| 1589 | ;; they're uncertain, we can't just barf on COMPOUND-TYPE and |
---|
| 1590 | ;; HAIRY-TYPEs as we used to. Instead we deal with the |
---|
| 1591 | ;; problem (where at least part of the problem is cases like |
---|
| 1592 | ;; (SUBTYPEP T '(SATISFIES FOO)) |
---|
| 1593 | ;; or |
---|
| 1594 | ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) |
---|
| 1595 | ;; where the second type is a hairy type like SATISFIES, or |
---|
| 1596 | ;; is a compound type which might contain a hairy type) by |
---|
| 1597 | ;; returning uncertainty. |
---|
| 1598 | (values nil nil)) |
---|
| 1599 | (t |
---|
| 1600 | ;; By elimination, TYPE1 is the universal type. |
---|
| 1601 | (assert (or (eq type1 *wild-type*) (eq type1 *universal-type*))) |
---|
| 1602 | ;; This case would have been picked off by the SIMPLE-SUBTYPEP |
---|
| 1603 | ;; method, and so shouldn't appear here. |
---|
| 1604 | (assert (not (eq type2 *universal-type*))) |
---|
| 1605 | ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the |
---|
| 1606 | ;; universal type in disguise, TYPE2 is not a superset of TYPE1. |
---|
| 1607 | (values nil t)))) |
---|
[6] | 1608 | |
---|
[279] | 1609 | |
---|
[6] | 1610 | (define-type-method (named :complex-subtypep-arg2) (type1 type2) |
---|
[279] | 1611 | (assert (not (eq type2 *wild-type*))) ; * isn't really a type. |
---|
| 1612 | (cond ((eq type2 *universal-type*) |
---|
| 1613 | (values t t)) |
---|
| 1614 | ((type-might-contain-other-types-p type1) |
---|
| 1615 | ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in |
---|
| 1616 | ;; disguise. So we'd better delegate. |
---|
| 1617 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
| 1618 | (t |
---|
| 1619 | ;; FIXME: This seems to rely on there only being 2 or 3 |
---|
| 1620 | ;; NAMED-TYPE values, and the exclusion of various |
---|
| 1621 | ;; possibilities above. It would be good to explain it and/or |
---|
| 1622 | ;; rewrite it so that it's clearer. |
---|
| 1623 | (values (not (eq type2 *empty-type*)) t)))) |
---|
[6] | 1624 | |
---|
[279] | 1625 | |
---|
[6] | 1626 | (define-type-method (named :complex-intersection) (type1 type2) |
---|
[279] | 1627 | (hierarchical-intersection2 type1 type2)) |
---|
[6] | 1628 | |
---|
| 1629 | (define-type-method (named :unparse) (x) |
---|
| 1630 | (named-ctype-name x)) |
---|
| 1631 | |
---|
| 1632 | |
---|
| 1633 | ;;;; Hairy and unknown types: |
---|
| 1634 | |
---|
[279] | 1635 | ;;; The Hairy-Type represents anything too wierd to be described |
---|
| 1636 | ;;; reasonably or to be useful, such as SATISFIES. We just remember |
---|
| 1637 | ;;; the original type spec. |
---|
[6] | 1638 | ;;; |
---|
| 1639 | |
---|
| 1640 | (defun make-hairy-ctype (&key specifier (enumerable t)) |
---|
| 1641 | (%istruct 'hairy-ctype |
---|
| 1642 | (type-class-or-lose 'hairy) |
---|
| 1643 | enumerable |
---|
| 1644 | specifier)) |
---|
| 1645 | |
---|
| 1646 | (defun hairy-ctype-p (x) |
---|
| 1647 | (istruct-typep x 'hairy-ctype)) |
---|
| 1648 | |
---|
| 1649 | (setf (type-predicate 'hairy-ctype) 'hairy-ctype-p) |
---|
| 1650 | |
---|
| 1651 | (define-type-method (hairy :unparse) (x) (hairy-ctype-specifier x)) |
---|
| 1652 | |
---|
| 1653 | (define-type-method (hairy :simple-subtypep) (type1 type2) |
---|
| 1654 | (let ((hairy-spec1 (hairy-ctype-specifier type1)) |
---|
| 1655 | (hairy-spec2 (hairy-ctype-specifier type2))) |
---|
[279] | 1656 | (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) |
---|
[6] | 1657 | (values t t)) |
---|
| 1658 | (t |
---|
| 1659 | (values nil nil))))) |
---|
| 1660 | |
---|
| 1661 | (define-type-method (hairy :complex-subtypep-arg2) (type1 type2) |
---|
[279] | 1662 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
[6] | 1663 | |
---|
| 1664 | (define-type-method (hairy :complex-subtypep-arg1) (type1 type2) |
---|
| 1665 | (declare (ignore type1 type2)) |
---|
| 1666 | (values nil nil)) |
---|
| 1667 | |
---|
[279] | 1668 | (define-type-method (hairy :complex-=) (type1 type2) |
---|
| 1669 | (if (and (unknown-ctype-p type2) |
---|
| 1670 | (let* ((specifier2 (unknown-ctype-specifier type2)) |
---|
| 1671 | (name2 (if (consp specifier2) |
---|
| 1672 | (car specifier2) |
---|
| 1673 | specifier2))) |
---|
| 1674 | (info-type-kind name2))) |
---|
| 1675 | (let ((type2 (specifier-type (unknown-ctype-specifier type2)))) |
---|
| 1676 | (if (unknown-ctype-p type2) |
---|
| 1677 | (values nil nil) |
---|
| 1678 | (type= type1 type2))) |
---|
| 1679 | (values nil nil))) |
---|
| 1680 | |
---|
[6] | 1681 | (define-type-method (hairy :simple-intersection :complex-intersection) |
---|
| 1682 | (type1 type2) |
---|
[279] | 1683 | (if (type= type1 type2) |
---|
| 1684 | type1 |
---|
| 1685 | nil)) |
---|
[6] | 1686 | |
---|
| 1687 | |
---|
[279] | 1688 | (define-type-method (hairy :simple-union) |
---|
| 1689 | (type1 type2) |
---|
| 1690 | (if (type= type1 type2) |
---|
| 1691 | type1 |
---|
| 1692 | nil)) |
---|
| 1693 | |
---|
[6] | 1694 | (define-type-method (hairy :simple-=) (type1 type2) |
---|
[279] | 1695 | (if (equal-but-no-car-recursion (hairy-ctype-specifier type1) |
---|
| 1696 | (hairy-ctype-specifier type2)) |
---|
| 1697 | (values t t) |
---|
| 1698 | (values nil nil))) |
---|
[6] | 1699 | |
---|
| 1700 | |
---|
[279] | 1701 | |
---|
[6] | 1702 | (def-type-translator satisfies (&whole x fun) |
---|
[279] | 1703 | (unless (symbolp fun) |
---|
| 1704 | (report-bad-arg fun 'symbol)) |
---|
[6] | 1705 | (make-hairy-ctype :specifier x)) |
---|
| 1706 | |
---|
[279] | 1707 | |
---|
| 1708 | ;;; Negation Ctypes |
---|
| 1709 | (defun make-negation-ctype (&key type (enumerable t)) |
---|
| 1710 | (%istruct 'negation-ctype |
---|
| 1711 | (type-class-or-lose 'negation) |
---|
| 1712 | enumerable |
---|
| 1713 | type)) |
---|
[6] | 1714 | |
---|
[279] | 1715 | (defun negation-ctype-p (x) |
---|
| 1716 | (istruct-typep x 'negation-ctype)) |
---|
[6] | 1717 | |
---|
[279] | 1718 | (setf (type-predicate 'negation-ctype) 'negation-ctype-p) |
---|
[6] | 1719 | |
---|
| 1720 | |
---|
[279] | 1721 | (define-type-method (negation :unparse) (x) |
---|
| 1722 | `(not ,(type-specifier (negation-ctype-type x)))) |
---|
| 1723 | |
---|
| 1724 | (define-type-method (negation :simple-subtypep) (type1 type2) |
---|
| 1725 | (csubtypep (negation-ctype-type type2) (negation-ctype-type type1))) |
---|
| 1726 | |
---|
| 1727 | (define-type-method (negation :complex-subtypep-arg2) (type1 type2) |
---|
| 1728 | (let* ((complement-type2 (negation-ctype-type type2)) |
---|
| 1729 | (intersection2 (type-intersection type1 complement-type2))) |
---|
| 1730 | (if intersection2 |
---|
| 1731 | ;; FIXME: if uncertain, maybe try arg1? |
---|
| 1732 | (type= intersection2 *empty-type*) |
---|
| 1733 | (invoke-complex-subtypep-arg1-method type1 type2)))) |
---|
| 1734 | |
---|
| 1735 | (define-type-method (negation :complex-subtypep-arg1) (type1 type2) |
---|
| 1736 | (block nil |
---|
| 1737 | ;; (Several logical truths in this block are true as long as |
---|
| 1738 | ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a |
---|
| 1739 | ;; case with b=T where we actually reach this type method, but |
---|
| 1740 | ;; we'll test for and exclude this case anyway, since future |
---|
| 1741 | ;; maintenance might make it possible for it to end up in this |
---|
| 1742 | ;; code.) |
---|
| 1743 | (multiple-value-bind (equal certain) |
---|
| 1744 | (type= type2 *universal-type*) |
---|
| 1745 | (unless certain |
---|
| 1746 | (return (values nil nil))) |
---|
| 1747 | (when equal |
---|
| 1748 | (return (values t t)))) |
---|
| 1749 | (let ((complement-type1 (negation-ctype-type type1))) |
---|
| 1750 | ;; Do the special cases first, in order to give us a chance if |
---|
| 1751 | ;; subtype/supertype relationships are hairy. |
---|
| 1752 | (multiple-value-bind (equal certain) |
---|
| 1753 | (type= complement-type1 type2) |
---|
| 1754 | ;; If a = b, ~a is not a subtype of b (unless b=T, which was |
---|
| 1755 | ;; excluded above). |
---|
| 1756 | (unless certain |
---|
| 1757 | (return (values nil nil))) |
---|
| 1758 | (when equal |
---|
| 1759 | (return (values nil t)))) |
---|
| 1760 | ;; KLUDGE: ANSI requires that the SUBTYPEP result between any |
---|
| 1761 | ;; two built-in atomic type specifiers never be uncertain. This |
---|
| 1762 | ;; is hard to do cleanly for the built-in types whose |
---|
| 1763 | ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, |
---|
| 1764 | ;; we can do it with this hack, which uses our global knowledge |
---|
| 1765 | ;; that our implementation of the type system uses disjoint |
---|
| 1766 | ;; implementation types to represent disjoint sets (except when |
---|
| 1767 | ;; types are contained in other types). (This is a KLUDGE |
---|
| 1768 | ;; because it's fragile. Various changes in internal |
---|
| 1769 | ;; representation in the type system could make it start |
---|
| 1770 | ;; confidently returning incorrect results.) -- WHN 2002-03-08 |
---|
| 1771 | (unless (or (type-might-contain-other-types-p complement-type1) |
---|
| 1772 | (type-might-contain-other-types-p type2)) |
---|
| 1773 | ;; Because of the way our types which don't contain other |
---|
| 1774 | ;; types are disjoint subsets of the space of possible values, |
---|
| 1775 | ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B |
---|
| 1776 | ;; is not T, as checked above). |
---|
| 1777 | (return (values nil t))) |
---|
| 1778 | ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as |
---|
| 1779 | ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, |
---|
| 1780 | ;; and then the :SIMPLE-SUBTYPEP method would be used instead. |
---|
| 1781 | ;; But a CSUBTYPEP relationship might still hold: |
---|
| 1782 | (multiple-value-bind (equal certain) |
---|
| 1783 | (csubtypep complement-type1 type2) |
---|
| 1784 | ;; If a is a subtype of b, ~a is not a subtype of b (unless |
---|
| 1785 | ;; b=T, which was excluded above). |
---|
| 1786 | (unless certain |
---|
| 1787 | (return (values nil nil))) |
---|
| 1788 | (when equal |
---|
| 1789 | (return (values nil t)))) |
---|
| 1790 | (multiple-value-bind (equal certain) |
---|
| 1791 | (csubtypep type2 complement-type1) |
---|
| 1792 | ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: |
---|
| 1793 | ;; That's not true if a=T. Do we know at this point that a is |
---|
| 1794 | ;; not T?) |
---|
| 1795 | (unless certain |
---|
| 1796 | (return (values nil nil))) |
---|
| 1797 | (when equal |
---|
| 1798 | (return (values nil t)))) |
---|
| 1799 | ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? |
---|
| 1800 | ;; KLUDGE case above: Other cases here would rely on being able |
---|
| 1801 | ;; to catch all possible cases, which the fragility of this type |
---|
| 1802 | ;; system doesn't inspire me; for instance, if a is type= to ~b, |
---|
| 1803 | ;; then we want T, T; if this is not the case and the types are |
---|
| 1804 | ;; disjoint (have an intersection of *empty-type*) then we want |
---|
| 1805 | ;; NIL, T; else if the union of a and b is the *universal-type* |
---|
| 1806 | ;; then we want T, T. So currently we still claim to be unsure |
---|
| 1807 | ;; about e.g. (subtypep '(not fixnum) 'single-float). |
---|
| 1808 | ;; |
---|
| 1809 | ;; OTOH we might still get here: |
---|
| 1810 | (values nil nil)))) |
---|
| 1811 | |
---|
| 1812 | (define-type-method (negation :complex-=) (type1 type2) |
---|
| 1813 | ;; (NOT FOO) isn't equivalent to anything that's not a negation |
---|
| 1814 | ;; type, except possibly a type that might contain it in disguise. |
---|
| 1815 | (declare (ignore type2)) |
---|
| 1816 | (if (type-might-contain-other-types-p type1) |
---|
| 1817 | (values nil nil) |
---|
| 1818 | (values nil t))) |
---|
| 1819 | |
---|
| 1820 | (define-type-method (negation :simple-intersection) (type1 type2) |
---|
| 1821 | (let ((not1 (negation-ctype-type type1)) |
---|
| 1822 | (not2 (negation-ctype-type type2))) |
---|
| 1823 | (cond |
---|
| 1824 | ((csubtypep not1 not2) type2) |
---|
| 1825 | ((csubtypep not2 not1) type1) |
---|
| 1826 | ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 |
---|
| 1827 | ;; method, below? The clause would read |
---|
| 1828 | ;; |
---|
| 1829 | ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) |
---|
| 1830 | ;; |
---|
| 1831 | ;; but with proper canonicalization of negation types, there's |
---|
| 1832 | ;; no way of constructing two negation types with union of their |
---|
| 1833 | ;; negations being the universal type. |
---|
| 1834 | (t |
---|
| 1835 | nil)))) |
---|
| 1836 | |
---|
| 1837 | (define-type-method (negation :complex-intersection) (type1 type2) |
---|
| 1838 | (cond |
---|
| 1839 | ((csubtypep type1 (negation-ctype-type type2)) *empty-type*) |
---|
| 1840 | ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) |
---|
| 1841 | type1) |
---|
| 1842 | (t nil))) |
---|
| 1843 | |
---|
| 1844 | (define-type-method (negation :simple-union) (type1 type2) |
---|
| 1845 | (let ((not1 (negation-ctype-type type1)) |
---|
| 1846 | (not2 (negation-ctype-type type2))) |
---|
| 1847 | (cond |
---|
| 1848 | ((csubtypep not1 not2) type1) |
---|
| 1849 | ((csubtypep not2 not1) type2) |
---|
| 1850 | ((eq (type-intersection not1 not2) *empty-type*) |
---|
| 1851 | *universal-type*) |
---|
| 1852 | (t nil)))) |
---|
| 1853 | |
---|
| 1854 | (define-type-method (negation :complex-union) (type1 type2) |
---|
| 1855 | (cond |
---|
| 1856 | ((csubtypep (negation-ctype-type type2) type1) *universal-type*) |
---|
| 1857 | ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) |
---|
| 1858 | type2) |
---|
| 1859 | (t nil))) |
---|
| 1860 | |
---|
| 1861 | (define-type-method (negation :simple-=) (type1 type2) |
---|
| 1862 | (type= (negation-ctype-type type1) (negation-ctype-type type2))) |
---|
| 1863 | |
---|
[9892] | 1864 | (def-type-translator not (typespec &environment env) |
---|
| 1865 | (let* ((not-type (specifier-type typespec env)) |
---|
[279] | 1866 | (spec (type-specifier not-type))) |
---|
| 1867 | (cond |
---|
| 1868 | ;; canonicalize (NOT (NOT FOO)) |
---|
| 1869 | ((and (listp spec) (eq (car spec) 'not)) |
---|
[9892] | 1870 | (specifier-type (cadr spec) env)) |
---|
[279] | 1871 | ;; canonicalize (NOT NIL) and (NOT T) |
---|
| 1872 | ((eq not-type *empty-type*) *universal-type*) |
---|
| 1873 | ((eq not-type *universal-type*) *empty-type*) |
---|
| 1874 | ((and (numeric-ctype-p not-type) |
---|
| 1875 | (null (numeric-ctype-low not-type)) |
---|
| 1876 | (null (numeric-ctype-high not-type))) |
---|
| 1877 | (make-negation-ctype :type not-type)) |
---|
| 1878 | ((numeric-ctype-p not-type) |
---|
| 1879 | (type-union |
---|
| 1880 | (make-negation-ctype |
---|
| 1881 | :type (modified-numeric-type not-type :low nil :high nil)) |
---|
| 1882 | (cond |
---|
| 1883 | ((null (numeric-ctype-low not-type)) |
---|
| 1884 | (modified-numeric-type |
---|
| 1885 | not-type |
---|
| 1886 | :low (let ((h (numeric-ctype-high not-type))) |
---|
| 1887 | (if (consp h) (car h) (list h))) |
---|
| 1888 | :high nil)) |
---|
| 1889 | ((null (numeric-ctype-high not-type)) |
---|
| 1890 | (modified-numeric-type |
---|
| 1891 | not-type |
---|
| 1892 | :low nil |
---|
| 1893 | :high (let ((l (numeric-ctype-low not-type))) |
---|
| 1894 | (if (consp l) (car l) (list l))))) |
---|
| 1895 | (t (type-union |
---|
| 1896 | (modified-numeric-type |
---|
| 1897 | not-type |
---|
| 1898 | :low nil |
---|
| 1899 | :high (let ((l (numeric-ctype-low not-type))) |
---|
| 1900 | (if (consp l) (car l) (list l)))) |
---|
| 1901 | (modified-numeric-type |
---|
| 1902 | not-type |
---|
| 1903 | :low (let ((h (numeric-ctype-high not-type))) |
---|
| 1904 | (if (consp h) (car h) (list h))) |
---|
| 1905 | :high nil)))))) |
---|
| 1906 | ((intersection-ctype-p not-type) |
---|
| 1907 | (apply #'type-union |
---|
| 1908 | (mapcar #'(lambda (x) |
---|
[9892] | 1909 | (specifier-type `(not ,(type-specifier x)) env)) |
---|
[279] | 1910 | (intersection-ctype-types not-type)))) |
---|
| 1911 | ((union-ctype-p not-type) |
---|
| 1912 | (apply #'type-intersection |
---|
| 1913 | (mapcar #'(lambda (x) |
---|
[9892] | 1914 | (specifier-type `(not ,(type-specifier x)) env)) |
---|
[279] | 1915 | (union-ctype-types not-type)))) |
---|
| 1916 | ((member-ctype-p not-type) |
---|
| 1917 | (let ((members (member-ctype-members not-type))) |
---|
| 1918 | (if (some #'floatp members) |
---|
| 1919 | (let (floats) |
---|
| 1920 | (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0))) |
---|
| 1921 | (when (member (car pair) members) |
---|
| 1922 | (assert (not (member (cdr pair) members))) |
---|
| 1923 | (push (cdr pair) floats) |
---|
| 1924 | (setf members (remove (car pair) members))) |
---|
| 1925 | (when (member (cdr pair) members) |
---|
| 1926 | (assert (not (member (car pair) members))) |
---|
| 1927 | (push (car pair) floats) |
---|
| 1928 | (setf members (remove (cdr pair) members)))) |
---|
| 1929 | (apply #'type-intersection |
---|
| 1930 | (if (null members) |
---|
| 1931 | *universal-type* |
---|
| 1932 | (make-negation-ctype |
---|
| 1933 | :type (make-member-ctype :members members))) |
---|
| 1934 | (mapcar |
---|
| 1935 | (lambda (x) |
---|
| 1936 | (let ((type (ctype-of x))) |
---|
| 1937 | (type-union |
---|
| 1938 | (make-negation-ctype |
---|
| 1939 | :type (modified-numeric-type type |
---|
| 1940 | :low nil :high nil)) |
---|
| 1941 | (modified-numeric-type type |
---|
| 1942 | :low nil :high (list x)) |
---|
| 1943 | (make-member-ctype :members (list x)) |
---|
| 1944 | (modified-numeric-type type |
---|
| 1945 | :low (list x) :high nil)))) |
---|
| 1946 | floats))) |
---|
| 1947 | (make-negation-ctype :type not-type)))) |
---|
| 1948 | ((and (cons-ctype-p not-type) |
---|
| 1949 | (eq (cons-ctype-car-ctype not-type) *universal-type*) |
---|
| 1950 | (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) |
---|
| 1951 | (make-negation-ctype :type not-type)) |
---|
| 1952 | ((cons-ctype-p not-type) |
---|
| 1953 | (type-union |
---|
[9892] | 1954 | (make-negation-ctype :type (specifier-type 'cons env)) |
---|
[279] | 1955 | (cond |
---|
| 1956 | ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*)) |
---|
| 1957 | (not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))) |
---|
| 1958 | (type-union |
---|
| 1959 | (make-cons-ctype |
---|
| 1960 | (specifier-type `(not ,(type-specifier |
---|
[9892] | 1961 | (cons-ctype-car-ctype not-type))) env) |
---|
[279] | 1962 | *universal-type*) |
---|
| 1963 | (make-cons-ctype |
---|
| 1964 | *universal-type* |
---|
| 1965 | (specifier-type `(not ,(type-specifier |
---|
[9892] | 1966 | (cons-ctype-cdr-ctype not-type))) env)))) |
---|
[279] | 1967 | ((not (eq (cons-ctype-car-ctype not-type) *universal-type*)) |
---|
| 1968 | (make-cons-ctype |
---|
| 1969 | (specifier-type `(not ,(type-specifier |
---|
[9892] | 1970 | (cons-ctype-car-ctype not-type))) env) |
---|
[279] | 1971 | *universal-type*)) |
---|
| 1972 | ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) |
---|
| 1973 | (make-cons-ctype |
---|
| 1974 | *universal-type* |
---|
| 1975 | (specifier-type `(not ,(type-specifier |
---|
[9892] | 1976 | (cons-ctype-cdr-ctype not-type))) env))) |
---|
[279] | 1977 | (t (error "Weird CONS type ~S" not-type))))) |
---|
| 1978 | (t (make-negation-ctype :type not-type))))) |
---|
| 1979 | |
---|
| 1980 | |
---|
[6] | 1981 | ;;;; Numeric types. |
---|
| 1982 | |
---|
| 1983 | ;;; A list of all the float formats, in order of decreasing precision. |
---|
| 1984 | ;;; |
---|
| 1985 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
| 1986 | (defconstant float-formats |
---|
| 1987 | '(long-float double-float single-float short-float))) |
---|
| 1988 | |
---|
| 1989 | ;;; The type of a float format. |
---|
| 1990 | ;;; |
---|
| 1991 | (deftype float-format () `(member ,@float-formats)) |
---|
| 1992 | |
---|
[318] | 1993 | (defun type-bound-number (x) |
---|
| 1994 | (if (consp x) |
---|
| 1995 | (destructuring-bind (result) x result) |
---|
| 1996 | x)) |
---|
| 1997 | |
---|
[6] | 1998 | (defun make-numeric-ctype (&key class |
---|
| 1999 | format |
---|
| 2000 | (complexp :real) |
---|
| 2001 | low |
---|
| 2002 | high |
---|
| 2003 | enumerable |
---|
| 2004 | predicate) |
---|
[318] | 2005 | ;; if interval is empty |
---|
| 2006 | (if (and low |
---|
| 2007 | high |
---|
| 2008 | (if (or (consp low) (consp high)) ; if either bound is exclusive |
---|
| 2009 | (>= (type-bound-number low) (type-bound-number high)) |
---|
| 2010 | (> low high))) |
---|
| 2011 | *empty-type* |
---|
| 2012 | (multiple-value-bind (canonical-low canonical-high) |
---|
| 2013 | (case class |
---|
| 2014 | (integer |
---|
| 2015 | ;; INTEGER types always have their LOW and HIGH bounds |
---|
| 2016 | ;; represented as inclusive, not exclusive values. |
---|
| 2017 | (values (if (consp low) |
---|
| 2018 | (1+ (type-bound-number low)) |
---|
| 2019 | low) |
---|
| 2020 | (if (consp high) |
---|
| 2021 | (1- (type-bound-number high)) |
---|
| 2022 | high))) |
---|
| 2023 | (t |
---|
| 2024 | ;; no canonicalization necessary |
---|
| 2025 | (values low high))) |
---|
| 2026 | (when (and (eq class 'rational) |
---|
| 2027 | (integerp canonical-low) |
---|
| 2028 | (integerp canonical-high) |
---|
| 2029 | (= canonical-low canonical-high)) |
---|
| 2030 | (setf class 'integer)) |
---|
| 2031 | (%istruct 'numeric-ctype |
---|
| 2032 | (type-class-or-lose 'number) |
---|
| 2033 | enumerable |
---|
| 2034 | class |
---|
| 2035 | format |
---|
| 2036 | complexp |
---|
| 2037 | canonical-low |
---|
| 2038 | canonical-high |
---|
| 2039 | predicate)))) |
---|
[6] | 2040 | |
---|
| 2041 | |
---|
| 2042 | (defun make-numeric-ctype-predicate (ctype) |
---|
| 2043 | (let ((class (numeric-ctype-class ctype)) |
---|
| 2044 | (lo (numeric-ctype-low ctype)) |
---|
| 2045 | (hi (numeric-ctype-high ctype))) |
---|
| 2046 | (if (eq class 'integer) |
---|
[1701] | 2047 | (if (and hi |
---|
| 2048 | lo |
---|
| 2049 | (<= hi target::target-most-positive-fixnum) |
---|
| 2050 | (>= lo target::target-most-negative-fixnum)) |
---|
[6] | 2051 | #'(lambda (n) |
---|
| 2052 | (and (fixnump n) |
---|
| 2053 | (locally (declare (fixnum n hi lo)) |
---|
| 2054 | (and (%i>= n lo) |
---|
| 2055 | (%i<= n hi))))))))) |
---|
| 2056 | |
---|
| 2057 | (defun numeric-ctype-p (x) |
---|
| 2058 | (istruct-typep x 'numeric-ctype)) |
---|
| 2059 | |
---|
| 2060 | (setf (type-predicate 'numeric-ctype) 'numeric-ctype-p) |
---|
| 2061 | |
---|
| 2062 | (define-type-method (number :simple-=) (type1 type2) |
---|
| 2063 | (values |
---|
| 2064 | (and (eq (numeric-ctype-class type1) (numeric-ctype-class type2)) |
---|
| 2065 | (eq (numeric-ctype-format type1) (numeric-ctype-format type2)) |
---|
| 2066 | (eq (numeric-ctype-complexp type1) (numeric-ctype-complexp type2)) |
---|
[279] | 2067 | (equalp (numeric-ctype-low type1) (numeric-ctype-low type2)) |
---|
| 2068 | (equalp (numeric-ctype-high type1) (numeric-ctype-high type2))) |
---|
[6] | 2069 | t)) |
---|
| 2070 | |
---|
| 2071 | (define-type-method (number :unparse) (type) |
---|
[318] | 2072 | (let* ((complexp (numeric-ctype-complexp type)) |
---|
| 2073 | (low (numeric-ctype-low type)) |
---|
| 2074 | (high (numeric-ctype-high type)) |
---|
| 2075 | (base (case (numeric-ctype-class type) |
---|
| 2076 | (integer 'integer) |
---|
| 2077 | (rational 'rational) |
---|
| 2078 | (float (or (numeric-ctype-format type) 'float)) |
---|
| 2079 | (t 'real)))) |
---|
[6] | 2080 | (let ((base+bounds |
---|
[318] | 2081 | (cond ((and (eq base 'integer) high low) |
---|
| 2082 | (let ((high-count (logcount high)) |
---|
| 2083 | (high-length (integer-length high))) |
---|
| 2084 | (cond ((= low 0) |
---|
| 2085 | (cond ((= high 0) '(integer 0 0)) |
---|
| 2086 | ((= high 1) 'bit) |
---|
| 2087 | ((and (= high-count high-length) |
---|
| 2088 | (plusp high-length)) |
---|
| 2089 | `(unsigned-byte ,high-length)) |
---|
| 2090 | (t |
---|
| 2091 | `(mod ,(1+ high))))) |
---|
[1701] | 2092 | ((and (= low target::target-most-negative-fixnum) |
---|
| 2093 | (= high target::target-most-positive-fixnum)) |
---|
[318] | 2094 | 'fixnum) |
---|
| 2095 | ((and (= low (lognot high)) |
---|
| 2096 | (= high-count high-length) |
---|
| 2097 | (> high-count 0)) |
---|
| 2098 | `(signed-byte ,(1+ high-length))) |
---|
| 2099 | (t |
---|
| 2100 | `(integer ,low ,high))))) |
---|
| 2101 | (high `(,base ,(or low '*) ,high)) |
---|
| 2102 | (low |
---|
| 2103 | (if (and (eq base 'integer) (= low 0)) |
---|
| 2104 | 'unsigned-byte |
---|
| 2105 | `(,base ,low))) |
---|
| 2106 | (t base)))) |
---|
[6] | 2107 | (ecase complexp |
---|
[318] | 2108 | (:real |
---|
| 2109 | base+bounds) |
---|
| 2110 | (:complex |
---|
| 2111 | (if (eq base+bounds 'real) |
---|
[6] | 2112 | 'complex |
---|
| 2113 | `(complex ,base+bounds))) |
---|
[318] | 2114 | ((nil) |
---|
| 2115 | (assert (eq base+bounds 'real)) |
---|
| 2116 | 'number))))) |
---|
[6] | 2117 | |
---|
| 2118 | ;;; Numeric-Bound-Test -- Internal |
---|
| 2119 | ;;; |
---|
| 2120 | ;;; Return true if X is "less than or equal" to Y, taking open bounds into |
---|
| 2121 | ;;; consideration. Closed is the predicate used to test the bound on a closed |
---|
| 2122 | ;;; interval (e.g. <=), and Open is the predicate used on open bounds (e.g. <). |
---|
| 2123 | ;;; Y is considered to be the outside bound, in the sense that if it is |
---|
| 2124 | ;;; infinite (NIL), then the test suceeds, whereas if X is infinite, then the |
---|
| 2125 | ;;; test fails (unless Y is also infinite). |
---|
| 2126 | ;;; |
---|
| 2127 | ;;; This is for comparing bounds of the same kind, e.g. upper and upper. |
---|
| 2128 | ;;; Use Numeric-Bound-Test* for different kinds of bounds. |
---|
| 2129 | ;;; |
---|
| 2130 | (defmacro numeric-bound-test (x y closed open) |
---|
| 2131 | `(cond ((not ,y) t) |
---|
| 2132 | ((not ,x) nil) |
---|
| 2133 | ((consp ,x) |
---|
| 2134 | (if (consp ,y) |
---|
| 2135 | (,closed (car ,x) (car ,y)) |
---|
| 2136 | (,closed (car ,x) ,y))) |
---|
| 2137 | (t |
---|
| 2138 | (if (consp ,y) |
---|
| 2139 | (,open ,x (car ,y)) |
---|
| 2140 | (,closed ,x ,y))))) |
---|
| 2141 | |
---|
| 2142 | ;;; Numeric-Bound-Test* -- Internal |
---|
| 2143 | ;;; |
---|
| 2144 | ;;; Used to compare upper and lower bounds. This is different from the |
---|
| 2145 | ;;; same-bound case: |
---|
| 2146 | ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we return true |
---|
| 2147 | ;;; if *either* arg is NIL. |
---|
| 2148 | ;;; -- an open inner bound is "greater" and also squeezes the interval, causing |
---|
| 2149 | ;;; us to use the Open test for those cases as well. |
---|
| 2150 | ;;; |
---|
| 2151 | (defmacro numeric-bound-test* (x y closed open) |
---|
| 2152 | `(cond ((not ,y) t) |
---|
[2519] | 2153 | ((not ,x) t) |
---|
| 2154 | ((consp ,x) |
---|
| 2155 | (if (consp ,y) |
---|
[6] | 2156 | (,open (car ,x) (car ,y)) |
---|
| 2157 | (,open (car ,x) ,y))) |
---|
[2519] | 2158 | (t |
---|
| 2159 | (if (consp ,y) |
---|
[6] | 2160 | (,open ,x (car ,y)) |
---|
| 2161 | (,closed ,x ,y))))) |
---|
| 2162 | |
---|
| 2163 | ;;; Numeric-Bound-Max -- Internal |
---|
| 2164 | ;;; |
---|
| 2165 | ;;; Return whichever of the numeric bounds X and Y is "maximal" according to |
---|
| 2166 | ;;; the predicates Closed (e.g. >=) and Open (e.g. >). This is only meaningful |
---|
| 2167 | ;;; for maximizing like bounds, i.e. upper and upper. If Max-P is true, then |
---|
| 2168 | ;;; we return NIL if X or Y is NIL, otherwise we return the other arg. |
---|
| 2169 | ;;; |
---|
| 2170 | (defmacro numeric-bound-max (x y closed open max-p) |
---|
| 2171 | (once-only ((n-x x) |
---|
[318] | 2172 | (n-y y)) |
---|
| 2173 | `(cond |
---|
| 2174 | ((not ,n-x) ,(if max-p nil n-y)) |
---|
| 2175 | ((not ,n-y) ,(if max-p nil n-x)) |
---|
| 2176 | ((consp ,n-x) |
---|
| 2177 | (if (consp ,n-y) |
---|
| 2178 | (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) |
---|
| 2179 | (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) |
---|
| 2180 | (t |
---|
| 2181 | (if (consp ,n-y) |
---|
| 2182 | (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) |
---|
| 2183 | (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) |
---|
[6] | 2184 | |
---|
| 2185 | |
---|
| 2186 | (define-type-method (number :simple-subtypep) (type1 type2) |
---|
| 2187 | (let ((class1 (numeric-ctype-class type1)) |
---|
| 2188 | (class2 (numeric-ctype-class type2)) |
---|
| 2189 | (complexp2 (numeric-ctype-complexp type2)) |
---|
| 2190 | (format2 (numeric-ctype-format type2)) |
---|
| 2191 | (low1 (numeric-ctype-low type1)) |
---|
| 2192 | (high1 (numeric-ctype-high type1)) |
---|
| 2193 | (low2 (numeric-ctype-low type2)) |
---|
| 2194 | (high2 (numeric-ctype-high type2))) |
---|
| 2195 | ;; |
---|
| 2196 | ;; If one is complex and the other isn't, they are disjoint. |
---|
| 2197 | (cond ((not (or (eq (numeric-ctype-complexp type1) complexp2) |
---|
| 2198 | (null complexp2))) |
---|
| 2199 | (values nil t)) |
---|
| 2200 | ;; |
---|
| 2201 | ;; If the classes are specified and different, the types are |
---|
| 2202 | ;; disjoint unless type2 is rational and type1 is integer. |
---|
| 2203 | ((not (or (eq class1 class2) (null class2) |
---|
| 2204 | (and (eq class1 'integer) (eq class2 'rational)))) |
---|
| 2205 | (values nil t)) |
---|
| 2206 | ;; |
---|
| 2207 | ;; If the float formats are specified and different, the types |
---|
| 2208 | ;; are disjoint. |
---|
| 2209 | ((not (or (eq (numeric-ctype-format type1) format2) |
---|
| 2210 | (null format2))) |
---|
| 2211 | (values nil t)) |
---|
| 2212 | ;; |
---|
| 2213 | ;; Check the bounds. |
---|
| 2214 | ((and (numeric-bound-test low1 low2 >= >) |
---|
| 2215 | (numeric-bound-test high1 high2 <= <)) |
---|
| 2216 | (values t t)) |
---|
| 2217 | (t |
---|
| 2218 | (values nil t))))) |
---|
| 2219 | |
---|
| 2220 | ;(define-superclasses number (generic-number)) |
---|
| 2221 | |
---|
| 2222 | ;;; NUMERIC-TYPES-ADJACENT -- Internal |
---|
| 2223 | ;;; |
---|
| 2224 | ;;; If the high bound of Low is adjacent to the low bound of High, then |
---|
| 2225 | ;;; return T, otherwise NIL. |
---|
| 2226 | ;;; |
---|
| 2227 | (defun numeric-types-adjacent (low high) |
---|
| 2228 | (let ((low-bound (numeric-ctype-high low)) |
---|
[318] | 2229 | (high-bound (numeric-ctype-low high))) |
---|
[6] | 2230 | (cond ((not (and low-bound high-bound)) nil) |
---|
| 2231 | ((consp low-bound) |
---|
| 2232 | (eql (car low-bound) high-bound)) |
---|
| 2233 | ((consp high-bound) |
---|
| 2234 | (eql (car high-bound) low-bound)) |
---|
| 2235 | ((and (eq (numeric-ctype-class low) 'integer) |
---|
| 2236 | (eq (numeric-ctype-class high) 'integer)) |
---|
| 2237 | (eql (1+ low-bound) high-bound)) |
---|
| 2238 | (t |
---|
| 2239 | nil)))) |
---|
| 2240 | |
---|
| 2241 | ;;; |
---|
[318] | 2242 | ;;; Return a numeric type that is a supertype for both type1 and type2. |
---|
[6] | 2243 | ;;; |
---|
| 2244 | (define-type-method (number :simple-union) (type1 type2) |
---|
| 2245 | (declare (type numeric-ctype type1 type2)) |
---|
| 2246 | (cond ((csubtypep type1 type2) type2) |
---|
[318] | 2247 | ((csubtypep type2 type1) type1) |
---|
| 2248 | (t |
---|
| 2249 | (let ((class1 (numeric-ctype-class type1)) |
---|
| 2250 | (format1 (numeric-ctype-format type1)) |
---|
| 2251 | (complexp1 (numeric-ctype-complexp type1)) |
---|
| 2252 | (class2 (numeric-ctype-class type2)) |
---|
| 2253 | (format2 (numeric-ctype-format type2)) |
---|
| 2254 | (complexp2 (numeric-ctype-complexp type2))) |
---|
[2526] | 2255 | (cond |
---|
| 2256 | ((and (eq class1 class2) |
---|
| 2257 | (eq format1 format2) |
---|
| 2258 | (eq complexp1 complexp2) |
---|
| 2259 | (or (numeric-types-intersect type1 type2) |
---|
| 2260 | (numeric-types-adjacent type1 type2) |
---|
| 2261 | (numeric-types-adjacent type2 type1))) |
---|
| 2262 | (make-numeric-ctype |
---|
| 2263 | :class class1 |
---|
| 2264 | :format format1 |
---|
| 2265 | :complexp complexp1 |
---|
| 2266 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
| 2267 | (numeric-ctype-low type2) |
---|
| 2268 | <= < t) |
---|
| 2269 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
| 2270 | (numeric-ctype-high type2) |
---|
| 2271 | >= > t))) |
---|
| 2272 | ;; FIXME: These two clauses are almost identical, and the |
---|
| 2273 | ;; consequents are in fact identical in every respect. |
---|
| 2274 | ((and (eq class1 'rational) |
---|
| 2275 | (eq class2 'integer) |
---|
| 2276 | (eq format1 format2) |
---|
| 2277 | (eq complexp1 complexp2) |
---|
| 2278 | (integerp (numeric-ctype-low type2)) |
---|
| 2279 | (integerp (numeric-ctype-high type2)) |
---|
| 2280 | (= (numeric-ctype-low type2) (numeric-ctype-high type2)) |
---|
| 2281 | (or (numeric-types-adjacent type1 type2) |
---|
| 2282 | (numeric-types-adjacent type2 type1))) |
---|
| 2283 | (make-numeric-ctype |
---|
| 2284 | :class 'rational |
---|
| 2285 | :format format1 |
---|
| 2286 | :complexp complexp1 |
---|
| 2287 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
| 2288 | (numeric-ctype-low type2) |
---|
| 2289 | <= < t) |
---|
| 2290 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
| 2291 | (numeric-ctype-high type2) |
---|
| 2292 | >= > t))) |
---|
| 2293 | ((and (eq class1 'integer) |
---|
| 2294 | (eq class2 'rational) |
---|
| 2295 | (eq format1 format2) |
---|
| 2296 | (eq complexp1 complexp2) |
---|
| 2297 | (integerp (numeric-ctype-low type1)) |
---|
| 2298 | (integerp (numeric-ctype-high type1)) |
---|
| 2299 | (= (numeric-ctype-low type1) (numeric-ctype-high type1)) |
---|
| 2300 | (or (numeric-types-adjacent type1 type2) |
---|
| 2301 | (numeric-types-adjacent type2 type1))) |
---|
| 2302 | (make-numeric-ctype |
---|
| 2303 | :class 'rational |
---|
| 2304 | :format format1 |
---|
| 2305 | :complexp complexp1 |
---|
| 2306 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
| 2307 | (numeric-ctype-low type2) |
---|
| 2308 | <= < t) |
---|
| 2309 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
| 2310 | (numeric-ctype-high type2) |
---|
| 2311 | >= > t))) |
---|
| 2312 | (t nil)))))) |
---|
[6] | 2313 | |
---|
| 2314 | (setf (info-type-kind 'number) :primitive |
---|
| 2315 | (info-type-builtin 'number) (make-numeric-ctype :complexp nil)) |
---|
| 2316 | |
---|
[9892] | 2317 | (def-type-translator complex (&optional spec &environment env) |
---|
[6] | 2318 | (if (eq spec '*) |
---|
[2472] | 2319 | (make-numeric-ctype :complexp :complex) |
---|
| 2320 | (labels ((not-numeric () |
---|
| 2321 | (error "Component type for Complex is not numeric: ~S." spec)) |
---|
| 2322 | (not-real () |
---|
| 2323 | (error "Component type for Complex is not a subtype of real: ~S." spec)) |
---|
| 2324 | (complex1 (component-type) |
---|
| 2325 | (unless (numeric-ctype-p component-type) |
---|
| 2326 | (not-numeric)) |
---|
| 2327 | (when (eq (numeric-ctype-complexp component-type) :complex) |
---|
| 2328 | (not-real)) |
---|
| 2329 | (let ((res (copy-uvector component-type))) |
---|
| 2330 | (setf (numeric-ctype-complexp res) :complex) |
---|
| 2331 | (setf (numeric-ctype-predicate res) nil) ; << |
---|
| 2332 | res)) |
---|
| 2333 | (do-complex (ctype) |
---|
| 2334 | (cond |
---|
| 2335 | ((eq ctype *empty-type*) *empty-type*) |
---|
| 2336 | ((eq ctype *universal-type*) (not-real)) |
---|
| 2337 | ((numeric-ctype-p ctype) (complex1 ctype)) |
---|
| 2338 | ((union-ctype-p ctype) |
---|
| 2339 | (apply #'type-union |
---|
| 2340 | (mapcar #'do-complex (union-ctype-types ctype)))) |
---|
| 2341 | ((member-ctype-p ctype) |
---|
| 2342 | (apply #'type-union |
---|
| 2343 | (mapcar (lambda (x) (do-complex (ctype-of x))) |
---|
| 2344 | (member-ctype-members ctype)))) |
---|
| 2345 | ((and (intersection-ctype-p ctype) |
---|
| 2346 | ;; just enough to handle simple types like RATIO. |
---|
| 2347 | (let ((numbers (remove-if-not |
---|
| 2348 | #'numeric-ctype-p |
---|
| 2349 | (intersection-ctype-types ctype)))) |
---|
| 2350 | (and (car numbers) |
---|
| 2351 | (null (cdr numbers)) |
---|
| 2352 | (eq (numeric-ctype-complexp (car numbers)) :real) |
---|
| 2353 | (complex1 (car numbers)))))) |
---|
| 2354 | (t ; punt on harder stuff for now |
---|
| 2355 | (not-real))))) |
---|
[9892] | 2356 | (let ((ctype (specifier-type spec env))) |
---|
[2472] | 2357 | (do-complex ctype))))) |
---|
[6] | 2358 | |
---|
| 2359 | ;;; Check-Bound -- Internal |
---|
| 2360 | ;;; |
---|
| 2361 | ;;; Check that X is a well-formed numeric bound of the specified Type. |
---|
| 2362 | ;;; If X is *, return NIL, otherwise return the bound. |
---|
| 2363 | ;;; |
---|
| 2364 | (defmacro check-bound (x type) |
---|
| 2365 | `(cond ((eq ,x '*) nil) |
---|
| 2366 | ((or (typep ,x ',type) |
---|
| 2367 | (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x)))) |
---|
| 2368 | ,x) |
---|
| 2369 | (t |
---|
| 2370 | (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x)))) |
---|
| 2371 | |
---|
| 2372 | (def-type-translator integer (&optional low high) |
---|
| 2373 | (let* ((l (check-bound low integer)) |
---|
[1701] | 2374 | (lb (if (consp l) (1+ (car l)) l)) |
---|
| 2375 | (h (check-bound high integer)) |
---|
| 2376 | (hb (if (consp h) (1- (car h)) h))) |
---|
[6] | 2377 | (if (and hb lb (< hb lb)) |
---|
| 2378 | *empty-type* |
---|
| 2379 | (make-numeric-ctype :class 'integer :complexp :real |
---|
| 2380 | :enumerable (not (null (and l h))) |
---|
| 2381 | :low lb |
---|
| 2382 | :high hb)))) |
---|
| 2383 | |
---|
| 2384 | (deftype mod (n) |
---|
| 2385 | (unless (and (integerp n) (> n 0)) |
---|
| 2386 | (error "Bad N specified for MOD type specifier: ~S." n)) |
---|
| 2387 | `(integer 0 ,(1- n))) |
---|
| 2388 | |
---|
| 2389 | |
---|
| 2390 | (defmacro def-bounded-type (type class format) |
---|
| 2391 | `(def-type-translator ,type (&optional low high) |
---|
| 2392 | (let ((lb (check-bound low ,type)) |
---|
| 2393 | (hb (check-bound high ,type))) |
---|
| 2394 | (unless (numeric-bound-test* lb hb <= <) |
---|
| 2395 | (error "Lower bound ~S is not less than upper bound ~S." low high)) |
---|
| 2396 | (make-numeric-ctype :class ',class :format ',format :low lb :high hb)))) |
---|
| 2397 | |
---|
| 2398 | (def-bounded-type rational rational nil) |
---|
[279] | 2399 | |
---|
| 2400 | (defun coerce-bound (bound type inner-coerce-bound-fun) |
---|
| 2401 | (declare (type function inner-coerce-bound-fun)) |
---|
| 2402 | (cond ((eql bound '*) |
---|
| 2403 | bound) |
---|
| 2404 | ((consp bound) |
---|
| 2405 | (destructuring-bind (inner-bound) bound |
---|
| 2406 | (list (funcall inner-coerce-bound-fun inner-bound type)))) |
---|
| 2407 | (t |
---|
| 2408 | (funcall inner-coerce-bound-fun bound type)))) |
---|
| 2409 | |
---|
| 2410 | (defun inner-coerce-real-bound (bound type) |
---|
| 2411 | (ecase type |
---|
| 2412 | (rational (rationalize bound)) |
---|
| 2413 | (float (if (floatp bound) |
---|
| 2414 | bound |
---|
| 2415 | ;; Coerce to the widest float format available, to |
---|
| 2416 | ;; avoid unnecessary loss of precision: |
---|
| 2417 | (coerce bound 'long-float))))) |
---|
| 2418 | |
---|
| 2419 | (defun coerced-real-bound (bound type) |
---|
| 2420 | (coerce-bound bound type #'inner-coerce-real-bound)) |
---|
| 2421 | |
---|
| 2422 | (defun coerced-float-bound (bound type) |
---|
| 2423 | (coerce-bound bound type #'coerce)) |
---|
| 2424 | |
---|
| 2425 | (def-type-translator real (&optional (low '*) (high '*)) |
---|
| 2426 | (specifier-type `(or (float ,(coerced-real-bound low 'float) |
---|
| 2427 | ,(coerced-real-bound high 'float)) |
---|
| 2428 | (rational ,(coerced-real-bound low 'rational) |
---|
| 2429 | ,(coerced-real-bound high 'rational))))) |
---|
| 2430 | |
---|
| 2431 | (def-type-translator float (&optional (low '*) (high '*)) |
---|
| 2432 | (specifier-type |
---|
| 2433 | `(or (single-float ,(coerced-float-bound low 'single-float) |
---|
| 2434 | ,(coerced-float-bound high 'single-float)) |
---|
| 2435 | (double-float ,(coerced-float-bound low 'double-float) |
---|
| 2436 | ,(coerced-float-bound high 'double-float))))) |
---|
| 2437 | |
---|
[6] | 2438 | (def-bounded-type float float nil) |
---|
| 2439 | (def-bounded-type real nil nil) |
---|
| 2440 | |
---|
| 2441 | (defmacro define-float-format (f) |
---|
| 2442 | `(def-bounded-type ,f float ,f)) |
---|
| 2443 | |
---|
| 2444 | (define-float-format short-float) |
---|
| 2445 | (define-float-format single-float) |
---|
| 2446 | (define-float-format double-float) |
---|
| 2447 | (define-float-format long-float) |
---|
| 2448 | |
---|
| 2449 | (defun numeric-types-intersect (type1 type2) |
---|
| 2450 | (declare (type numeric-ctype type1 type2)) |
---|
| 2451 | (let* ((class1 (numeric-ctype-class type1)) |
---|
[279] | 2452 | (class2 (numeric-ctype-class type2)) |
---|
| 2453 | (complexp1 (numeric-ctype-complexp type1)) |
---|
| 2454 | (complexp2 (numeric-ctype-complexp type2)) |
---|
| 2455 | (format1 (numeric-ctype-format type1)) |
---|
| 2456 | (format2 (numeric-ctype-format type2)) |
---|
| 2457 | (low1 (numeric-ctype-low type1)) |
---|
| 2458 | (high1 (numeric-ctype-high type1)) |
---|
| 2459 | (low2 (numeric-ctype-low type2)) |
---|
| 2460 | (high2 (numeric-ctype-high type2))) |
---|
[6] | 2461 | ;; |
---|
| 2462 | ;; If one is complex and the other isn't, then they are disjoint. |
---|
| 2463 | (cond ((not (or (eq complexp1 complexp2) |
---|
[279] | 2464 | (null complexp1) (null complexp2))) |
---|
| 2465 | nil) |
---|
| 2466 | ;; |
---|
| 2467 | ;; If either type is a float, then the other must either be specified |
---|
| 2468 | ;; to be a float or unspecified. Otherwise, they are disjoint. |
---|
| 2469 | ((and (eq class1 'float) (not (member class2 '(float nil)))) nil) |
---|
| 2470 | ((and (eq class2 'float) (not (member class1 '(float nil)))) nil) |
---|
| 2471 | ;; |
---|
| 2472 | ;; If the float formats are specified and different, the types |
---|
| 2473 | ;; are disjoint. |
---|
| 2474 | ((not (or (eq format1 format2) (null format1) (null format2))) |
---|
| 2475 | nil) |
---|
| 2476 | (t |
---|
| 2477 | ;; |
---|
| 2478 | ;; Check the bounds. This is a bit odd because we must always have |
---|
| 2479 | ;; the outer bound of the interval as the second arg. |
---|
| 2480 | (if (numeric-bound-test high1 high2 <= <) |
---|
| 2481 | (or (and (numeric-bound-test low1 low2 >= >) |
---|
| 2482 | (numeric-bound-test* low1 high2 <= <)) |
---|
| 2483 | (and (numeric-bound-test low2 low1 >= >) |
---|
| 2484 | (numeric-bound-test* low2 high1 <= <))) |
---|
| 2485 | (or (and (numeric-bound-test* low2 high1 <= <) |
---|
| 2486 | (numeric-bound-test low2 low1 >= >)) |
---|
| 2487 | (and (numeric-bound-test high2 high1 <= <) |
---|
| 2488 | (numeric-bound-test* high2 low1 >= >)))))))) |
---|
[6] | 2489 | |
---|
| 2490 | ;;; Round-Numeric-Bound -- Internal |
---|
| 2491 | ;;; |
---|
| 2492 | ;;; Take the numeric bound X and convert it into something that can be used |
---|
| 2493 | ;;; as a bound in a numeric type with the specified Class and Format. If up-p |
---|
| 2494 | ;;; is true, then we round up as needed, otherwise we round down. Up-p true |
---|
| 2495 | ;;; implies that X is a lower bound, i.e. (N) > N. |
---|
| 2496 | ;;; |
---|
| 2497 | ;;; This is used by Numeric-Type-Intersection to mash the bound into the |
---|
| 2498 | ;;; appropriate type number. X may only be a float when Class is Float. |
---|
| 2499 | ;;; |
---|
| 2500 | ;;; ### Note: it is possible for the coercion to a float to overflow or |
---|
| 2501 | ;;; underflow. This happens when the bound doesn't fit in the specified |
---|
| 2502 | ;;; format. In this case, we should really return the appropriate |
---|
| 2503 | ;;; {Most | Least}-{Positive | Negative}-XXX-Float float of desired format. |
---|
| 2504 | ;;; But these conditions aren't currently signalled in any useful way. |
---|
| 2505 | ;;; |
---|
| 2506 | ;;; Also, when converting an open rational bound into a float we should |
---|
| 2507 | ;;; probably convert it to a closed bound of the closest float in the specified |
---|
| 2508 | ;;; format. In general, open float bounds are fucked. |
---|
| 2509 | ;;; |
---|
| 2510 | (defun round-numeric-bound (x class format up-p) |
---|
| 2511 | (if x |
---|
| 2512 | (let ((cx (if (consp x) (car x) x))) |
---|
| 2513 | (ecase class |
---|
| 2514 | ((nil rational) x) |
---|
| 2515 | (integer |
---|
| 2516 | (if (and (consp x) (integerp cx)) |
---|
[279] | 2517 | (if up-p (1+ cx) (1- cx)) |
---|
| 2518 | (if up-p (ceiling cx) (floor cx)))) |
---|
[6] | 2519 | (float |
---|
| 2520 | (let ((res (if format (coerce cx format) (float cx)))) |
---|
| 2521 | (if (consp x) (list res) res))))) |
---|
| 2522 | nil)) |
---|
| 2523 | |
---|
| 2524 | ;;; Number :Simple-Intersection type method -- Internal |
---|
| 2525 | ;;; |
---|
| 2526 | ;;; Handle the case of Type-Intersection on two numeric types. We use |
---|
| 2527 | ;;; Types-Intersect to throw out the case of types with no intersection. If an |
---|
| 2528 | ;;; attribute in Type1 is unspecified, then we use Type2's attribute, which |
---|
| 2529 | ;;; must be at least as restrictive. If the types intersect, then the only |
---|
| 2530 | ;;; attributes that can be specified and different are the class and the |
---|
| 2531 | ;;; bounds. |
---|
| 2532 | ;;; |
---|
| 2533 | ;;; When the class differs, we use the more restrictive class. The only |
---|
| 2534 | ;;; interesting case is rational/integer, since rational includes integer. |
---|
| 2535 | ;;; |
---|
| 2536 | ;;; We make the result lower (upper) bound the maximum (minimum) of the |
---|
| 2537 | ;;; argument lower (upper) bounds. We convert the bounds into the |
---|
| 2538 | ;;; appropriate numeric type before maximizing. This avoids possible confusion |
---|
| 2539 | ;;; due to mixed-type comparisons (but I think the result is the same). |
---|
| 2540 | ;;; |
---|
| 2541 | (define-type-method (number :simple-intersection) (type1 type2) |
---|
| 2542 | (declare (type numeric-type type1 type2)) |
---|
| 2543 | (if (numeric-types-intersect type1 type2) |
---|
| 2544 | (let* ((class1 (numeric-ctype-class type1)) |
---|
[279] | 2545 | (class2 (numeric-ctype-class type2)) |
---|
| 2546 | (class (ecase class1 |
---|
| 2547 | ((nil) class2) |
---|
| 2548 | ((integer float) class1) |
---|
| 2549 | (rational (if (eq class2 'integer) 'integer 'rational)))) |
---|
| 2550 | (format (or (numeric-ctype-format type1) |
---|
| 2551 | (numeric-ctype-format type2)))) |
---|
| 2552 | (make-numeric-ctype |
---|
| 2553 | :class class |
---|
| 2554 | :format format |
---|
| 2555 | :complexp (or (numeric-ctype-complexp type1) |
---|
| 2556 | (numeric-ctype-complexp type2)) |
---|
| 2557 | :low (numeric-bound-max |
---|
| 2558 | (round-numeric-bound (numeric-ctype-low type1) |
---|
| 2559 | class format t) |
---|
| 2560 | (round-numeric-bound (numeric-ctype-low type2) |
---|
| 2561 | class format t) |
---|
[2519] | 2562 | > >= nil) |
---|
[279] | 2563 | :high (numeric-bound-max |
---|
| 2564 | (round-numeric-bound (numeric-ctype-high type1) |
---|
| 2565 | class format nil) |
---|
| 2566 | (round-numeric-bound (numeric-ctype-high type2) |
---|
| 2567 | class format nil) |
---|
[2519] | 2568 | < <= nil))) |
---|
[279] | 2569 | *empty-type*)) |
---|
[6] | 2570 | |
---|
| 2571 | ;;; Float-Format-Max -- Interface |
---|
| 2572 | ;;; |
---|
| 2573 | ;;; Given two float formats, return the one with more precision. If either |
---|
| 2574 | ;;; one is null, return NIL. |
---|
| 2575 | ;;; |
---|
| 2576 | (defun float-format-max (f1 f2) |
---|
| 2577 | (when (and f1 f2) |
---|
| 2578 | (dolist (f float-formats (error "Bad float format: ~S." f1)) |
---|
| 2579 | (when (or (eq f f1) (eq f f2)) |
---|
| 2580 | (return f))))) |
---|
| 2581 | |
---|
| 2582 | |
---|
| 2583 | ;;; Numeric-Contagion -- Interface |
---|
| 2584 | ;;; |
---|
| 2585 | ;;; Return the result of an operation on Type1 and Type2 according to the |
---|
| 2586 | ;;; rules of numeric contagion. This is always NUMBER, some float format |
---|
| 2587 | ;;; (possibly complex) or RATIONAL. Due to rational canonicalization, there |
---|
| 2588 | ;;; isn't much we can do here with integers or rational complex numbers. |
---|
| 2589 | ;;; |
---|
| 2590 | ;;; If either argument is not a Numeric-Type, then return NUMBER. This is |
---|
| 2591 | ;;; useful mainly for allowing types that are technically numbers, but not a |
---|
| 2592 | ;;; Numeric-Type. |
---|
| 2593 | ;;; |
---|
| 2594 | (defun numeric-contagion (type1 type2) |
---|
| 2595 | (if (and (numeric-ctype-p type1) (numeric-ctype-p type2)) |
---|
| 2596 | (let ((class1 (numeric-ctype-class type1)) |
---|
| 2597 | (class2 (numeric-ctype-class type2)) |
---|
| 2598 | (format1 (numeric-ctype-format type1)) |
---|
| 2599 | (format2 (numeric-ctype-format type2)) |
---|
| 2600 | (complexp1 (numeric-ctype-complexp type1)) |
---|
| 2601 | (complexp2 (numeric-ctype-complexp type2))) |
---|
| 2602 | (cond ((or (null complexp1) |
---|
[279] | 2603 | (null complexp2)) |
---|
[6] | 2604 | (specifier-type 'number)) |
---|
| 2605 | ((eq class1 'float) |
---|
| 2606 | (make-numeric-ctype |
---|
| 2607 | :class 'float |
---|
| 2608 | :format (ecase class2 |
---|
| 2609 | (float (float-format-max format1 format2)) |
---|
| 2610 | ((integer rational) format1) |
---|
[279] | 2611 | ((nil) |
---|
| 2612 | ;; A double-float with any real number is a |
---|
| 2613 | ;; double-float. |
---|
| 2614 | (if (eq format1 'double-float) |
---|
| 2615 | 'double-float |
---|
| 2616 | nil))) |
---|
[6] | 2617 | :complexp (if (or (eq complexp1 :complex) |
---|
[279] | 2618 | (eq complexp2 :complex)) |
---|
| 2619 | :complex |
---|
| 2620 | :real))) |
---|
[6] | 2621 | ((eq class2 'float) (numeric-contagion type2 type1)) |
---|
| 2622 | ((and (eq complexp1 :real) (eq complexp2 :real)) |
---|
| 2623 | (make-numeric-ctype |
---|
| 2624 | :class (and class1 class2 'rational) |
---|
| 2625 | :complexp :real)) |
---|
| 2626 | (t |
---|
| 2627 | (specifier-type 'number)))) |
---|
| 2628 | (specifier-type 'number))) |
---|
| 2629 | |
---|
[279] | 2630 | |
---|
| 2631 | |
---|
[6] | 2632 | |
---|
| 2633 | ;;;; Array types: |
---|
| 2634 | |
---|
| 2635 | ;;; The Array-Type is used to represent all array types, including things such |
---|
| 2636 | ;;; as SIMPLE-STRING. |
---|
| 2637 | ;;; |
---|
| 2638 | |
---|
| 2639 | (defun make-array-ctype (&key |
---|
| 2640 | (dimensions '*) |
---|
| 2641 | (complexp '*) |
---|
| 2642 | element-type |
---|
| 2643 | (specialized-element-type *wild-type*)) |
---|
| 2644 | (%istruct 'array-ctype |
---|
| 2645 | (type-class-or-lose 'array) |
---|
| 2646 | nil |
---|
| 2647 | dimensions |
---|
| 2648 | complexp |
---|
| 2649 | element-type |
---|
[7950] | 2650 | specialized-element-type |
---|
| 2651 | (unless (eq specialized-element-type *wild-type*) |
---|
| 2652 | (ctype-subtype specialized-element-type)))) |
---|
[6] | 2653 | |
---|
| 2654 | (defun array-ctype-p (x) (istruct-typep x 'array-ctype)) |
---|
| 2655 | (setf (type-predicate 'array-ctype) 'array-ctype-p) |
---|
| 2656 | |
---|
| 2657 | ;;; Specialized-Element-Type-Maybe -- Internal |
---|
| 2658 | ;;; |
---|
| 2659 | ;;; What this does depends on the setting of the |
---|
| 2660 | ;;; *use-implementation-types* switch. If true, return the specialized element |
---|
| 2661 | ;;; type, otherwise return the original element type. |
---|
| 2662 | ;;; |
---|
| 2663 | (defun specialized-element-type-maybe (type) |
---|
| 2664 | (declare (type array-ctype type)) |
---|
| 2665 | (if *use-implementation-types* |
---|
[1789] | 2666 | (array-ctype-specialized-element-type type) |
---|
| 2667 | (array-ctype-element-type type))) |
---|
[6] | 2668 | |
---|
| 2669 | (define-type-method (array :simple-=) (type1 type2) |
---|
[279] | 2670 | (if (or (unknown-ctype-p (array-ctype-element-type type1)) |
---|
| 2671 | (unknown-ctype-p (array-ctype-element-type type2))) |
---|
| 2672 | (multiple-value-bind (equalp certainp) |
---|
| 2673 | (type= (array-ctype-element-type type1) |
---|
| 2674 | (array-ctype-element-type type2)) |
---|
| 2675 | (assert (not (and (not equalp) certainp))) |
---|
| 2676 | (values equalp certainp)) |
---|
| 2677 | (values (and (equal (array-ctype-dimensions type1) |
---|
| 2678 | (array-ctype-dimensions type2)) |
---|
| 2679 | (eq (array-ctype-complexp type1) |
---|
| 2680 | (array-ctype-complexp type2)) |
---|
| 2681 | (type= (specialized-element-type-maybe type1) |
---|
| 2682 | (specialized-element-type-maybe type2))) |
---|
| 2683 | t))) |
---|
[6] | 2684 | |
---|
| 2685 | (define-type-method (array :unparse) (type) |
---|
| 2686 | (let ((dims (array-ctype-dimensions type)) |
---|
| 2687 | (eltype (type-specifier (array-ctype-element-type type))) |
---|
| 2688 | (complexp (array-ctype-complexp type))) |
---|
| 2689 | (cond ((eq dims '*) |
---|
| 2690 | (if (eq eltype '*) |
---|
| 2691 | (if complexp 'array 'simple-array) |
---|
| 2692 | (if complexp `(array ,eltype) `(simple-array ,eltype)))) |
---|
| 2693 | ((= (length dims) 1) |
---|
| 2694 | (if complexp |
---|
| 2695 | (if (eq (car dims) '*) |
---|
| 2696 | (case eltype |
---|
| 2697 | (bit 'bit-vector) |
---|
[7917] | 2698 | ((character base-char) 'base-string) |
---|
[6] | 2699 | (* 'vector) |
---|
| 2700 | (t `(vector ,eltype))) |
---|
| 2701 | (case eltype |
---|
| 2702 | (bit `(bit-vector ,(car dims))) |
---|
[7917] | 2703 | ((character base-char) `(base-string ,(car dims))) |
---|
[6] | 2704 | (t `(vector ,eltype ,(car dims))))) |
---|
| 2705 | (if (eq (car dims) '*) |
---|
| 2706 | (case eltype |
---|
| 2707 | (bit 'simple-bit-vector) |
---|
[7917] | 2708 | ((base-char character) 'simple-base-string) |
---|
[6] | 2709 | ((t) 'simple-vector) |
---|
| 2710 | (t `(simple-array ,eltype (*)))) |
---|
| 2711 | (case eltype |
---|
| 2712 | (bit `(simple-bit-vector ,(car dims))) |
---|
[7917] | 2713 | ((base-char character) `(simple-base-string ,(car dims))) |
---|
[6] | 2714 | ((t) `(simple-vector ,(car dims))) |
---|
| 2715 | (t `(simple-array ,eltype ,dims)))))) |
---|
| 2716 | (t |
---|
| 2717 | (if complexp |
---|
| 2718 | `(array ,eltype ,dims) |
---|
| 2719 | `(simple-array ,eltype ,dims)))))) |
---|
| 2720 | |
---|
| 2721 | (define-type-method (array :simple-subtypep) (type1 type2) |
---|
| 2722 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
[279] | 2723 | (dims2 (array-ctype-dimensions type2)) |
---|
| 2724 | (complexp2 (array-ctype-complexp type2))) |
---|
| 2725 | (cond (;; not subtypep unless dimensions are compatible |
---|
| 2726 | (not (or (eq dims2 '*) |
---|
| 2727 | (and (not (eq dims1 '*)) |
---|
| 2728 | (= (length (the list dims1)) |
---|
| 2729 | (length (the list dims2))) |
---|
| 2730 | (every (lambda (x y) |
---|
| 2731 | (or (eq y '*) (eql x y))) |
---|
| 2732 | (the list dims1) |
---|
| 2733 | (the list dims2))))) |
---|
| 2734 | (values nil t)) |
---|
| 2735 | ;; not subtypep unless complexness is compatible |
---|
| 2736 | ((not (or (eq complexp2 :maybe) |
---|
| 2737 | (eq (array-ctype-complexp type1) complexp2))) |
---|
| 2738 | (values nil t)) |
---|
| 2739 | ;; Since we didn't fail any of the tests above, we win |
---|
| 2740 | ;; if the TYPE2 element type is wild. |
---|
| 2741 | ((eq (array-ctype-element-type type2) *wild-type*) |
---|
| 2742 | (values t t)) |
---|
| 2743 | (;; Since we didn't match any of the special cases above, we |
---|
| 2744 | ;; can't give a good answer unless both the element types |
---|
| 2745 | ;; have been defined. |
---|
| 2746 | (or (unknown-ctype-p (array-ctype-element-type type1)) |
---|
| 2747 | (unknown-ctype-p (array-ctype-element-type type2))) |
---|
| 2748 | (values nil nil)) |
---|
| 2749 | (;; Otherwise, the subtype relationship holds iff the |
---|
| 2750 | ;; types are equal, and they're equal iff the specialized |
---|
| 2751 | ;; element types are identical. |
---|
| 2752 | t |
---|
| 2753 | (values (type= (specialized-element-type-maybe type1) |
---|
| 2754 | (specialized-element-type-maybe type2)) |
---|
| 2755 | t))))) |
---|
[6] | 2756 | |
---|
| 2757 | ; (define-superclasses array (string string) (vector vector) (array)) |
---|
| 2758 | |
---|
| 2759 | |
---|
| 2760 | (defun array-types-intersect (type1 type2) |
---|
| 2761 | (declare (type array-ctype type1 type2)) |
---|
| 2762 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
[279] | 2763 | (dims2 (array-ctype-dimensions type2)) |
---|
| 2764 | (complexp1 (array-ctype-complexp type1)) |
---|
| 2765 | (complexp2 (array-ctype-complexp type2))) |
---|
| 2766 | ;; See whether dimensions are compatible. |
---|
[6] | 2767 | (cond ((not (or (eq dims1 '*) (eq dims2 '*) |
---|
[279] | 2768 | (and (= (length dims1) (length dims2)) |
---|
| 2769 | (every (lambda (x y) |
---|
| 2770 | (or (eq x '*) (eq y '*) (= x y))) |
---|
| 2771 | dims1 dims2)))) |
---|
| 2772 | (values nil t)) |
---|
| 2773 | ;; See whether complexpness is compatible. |
---|
| 2774 | ((not (or (eq complexp1 :maybe) |
---|
| 2775 | (eq complexp2 :maybe) |
---|
| 2776 | (eq complexp1 complexp2))) |
---|
| 2777 | (values nil t)) |
---|
| 2778 | ((or (eq (array-ctype-specialized-element-type type1) *wild-type*) |
---|
| 2779 | (eq (array-ctype-specialized-element-type type2) *wild-type*) |
---|
| 2780 | (type= (specialized-element-type-maybe type1) |
---|
| 2781 | (specialized-element-type-maybe type2))) |
---|
| 2782 | (values t t)) |
---|
| 2783 | (t |
---|
| 2784 | (values nil t))))) |
---|
[6] | 2785 | |
---|
| 2786 | (define-type-method (array :simple-intersection) (type1 type2) |
---|
| 2787 | (declare (type array-ctype type1 type2)) |
---|
| 2788 | (if (array-types-intersect type1 type2) |
---|
| 2789 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
[2528] | 2790 | (dims2 (array-ctype-dimensions type2)) |
---|
| 2791 | (complexp1 (array-ctype-complexp type1)) |
---|
| 2792 | (complexp2 (array-ctype-complexp type2)) |
---|
| 2793 | (eltype1 (array-ctype-element-type type1)) |
---|
| 2794 | (eltype2 (array-ctype-element-type type2))) |
---|
| 2795 | (specialize-array-type |
---|
| 2796 | (make-array-ctype |
---|
| 2797 | :dimensions (cond ((eq dims1 '*) dims2) |
---|
| 2798 | ((eq dims2 '*) dims1) |
---|
| 2799 | (t |
---|
| 2800 | (mapcar #'(lambda (x y) (if (eq x '*) y x)) |
---|
| 2801 | dims1 dims2))) |
---|
| 2802 | :complexp (if (eq complexp1 :maybe) complexp2 complexp1) |
---|
| 2803 | :element-type (cond |
---|
| 2804 | ((eq eltype1 *wild-type*) eltype2) |
---|
| 2805 | ((eq eltype2 *wild-type*) eltype1) |
---|
| 2806 | (t (type-intersection eltype1 eltype2)))))) |
---|
| 2807 | *empty-type*)) |
---|
[6] | 2808 | |
---|
| 2809 | ;;; Check-Array-Dimensions -- Internal |
---|
| 2810 | ;;; |
---|
| 2811 | ;;; Check a supplied dimension list to determine if it is legal. |
---|
| 2812 | ;;; |
---|
| 2813 | (defun check-array-dimensions (dims) |
---|
| 2814 | (typecase dims |
---|
| 2815 | ((member *) dims) |
---|
| 2816 | (integer |
---|
| 2817 | (when (minusp dims) |
---|
[279] | 2818 | (signal-program-error "Arrays can't have a negative number of dimensions: ~D." dims)) |
---|
[6] | 2819 | (when (>= dims array-rank-limit) |
---|
[279] | 2820 | (signal-program-error "Array type has too many dimensions: ~S." dims)) |
---|
[6] | 2821 | (make-list dims :initial-element '*)) |
---|
| 2822 | (list |
---|
| 2823 | (when (>= (length dims) array-rank-limit) |
---|
[279] | 2824 | (signal-program-error "Array type has too many dimensions: ~S." dims)) |
---|
[6] | 2825 | (dolist (dim dims) |
---|
| 2826 | (unless (eq dim '*) |
---|
| 2827 | (unless (and (integerp dim) |
---|
| 2828 | (>= dim 0) (< dim array-dimension-limit)) |
---|
[279] | 2829 | (signal-program-error "Bad dimension in array type: ~S." dim)))) |
---|
[6] | 2830 | dims) |
---|
| 2831 | (t |
---|
[279] | 2832 | (signal-program-error "Array dimensions is not a list, integer or *:~% ~S" |
---|
| 2833 | dims)))) |
---|
[6] | 2834 | |
---|
[9892] | 2835 | (def-type-translator array (&optional element-type dimensions &environment env) |
---|
[6] | 2836 | (specialize-array-type |
---|
| 2837 | (make-array-ctype :dimensions (check-array-dimensions dimensions) |
---|
[279] | 2838 | :complexp :maybe |
---|
[9892] | 2839 | :element-type (specifier-type element-type env)))) |
---|
[6] | 2840 | |
---|
[9892] | 2841 | (def-type-translator simple-array (&optional element-type dimensions &environment env) |
---|
[6] | 2842 | (specialize-array-type |
---|
| 2843 | (make-array-ctype :dimensions (check-array-dimensions dimensions) |
---|
[9892] | 2844 | :element-type (specifier-type element-type env) |
---|
[6] | 2845 | :complexp nil))) |
---|
| 2846 | |
---|
[1789] | 2847 | ;;; Order matters here. |
---|
[6] | 2848 | (defparameter specialized-array-element-types |
---|
[2528] | 2849 | '(nil bit (unsigned-byte 8) (signed-byte 8) (unsigned-byte 16) |
---|
[4876] | 2850 | (signed-byte 16) (unsigned-byte 32) #+32-bit-target fixnum (signed-byte 32) |
---|
[3963] | 2851 | #+64-bit-target (unsigned-byte 64) |
---|
[4876] | 2852 | #+64-bit-target fixnum |
---|
[3963] | 2853 | #+64-bit-target (signed-byte 64) |
---|
[1789] | 2854 | character short-float double-float)) |
---|
[6] | 2855 | |
---|
| 2856 | (defun specialize-array-type (type) |
---|
[7950] | 2857 | (let* ((eltype (array-ctype-element-type type)) |
---|
| 2858 | (specialized-type (if (eq eltype *wild-type*) |
---|
| 2859 | *wild-type* |
---|
| 2860 | (dolist (stype-name specialized-array-element-types |
---|
| 2861 | *universal-type*) |
---|
| 2862 | (let ((stype (specifier-type stype-name))) |
---|
| 2863 | (when (csubtypep eltype stype) |
---|
| 2864 | (return stype))))))) |
---|
[6] | 2865 | |
---|
[7950] | 2866 | (setf (array-ctype-specialized-element-type type) specialized-type |
---|
| 2867 | (array-ctype-typecode type) (unless (eq specialized-type *wild-type*) |
---|
| 2868 | (ctype-subtype specialized-type))) |
---|
[6] | 2869 | type)) |
---|
| 2870 | |
---|
| 2871 | |
---|
| 2872 | ;;;; Member types. |
---|
| 2873 | |
---|
| 2874 | ;;; The Member-Type represents uses of the MEMBER type specifier. We bother |
---|
| 2875 | ;;; with this at this level because MEMBER types are fairly important and union |
---|
| 2876 | ;;; and intersection are well defined. |
---|
| 2877 | |
---|
[318] | 2878 | (defun %make-member-ctype (members) |
---|
[6] | 2879 | (%istruct 'member-ctype |
---|
| 2880 | (type-class-or-lose 'member) |
---|
| 2881 | t |
---|
| 2882 | members)) |
---|
| 2883 | |
---|
[318] | 2884 | (defun make-member-ctype (&key members) |
---|
| 2885 | (let* ((singlep (subsetp '(-0.0f0 0.0f0) members)) |
---|
| 2886 | (doublep (subsetp '(-0.0d0 0.0d0) members)) |
---|
| 2887 | (union-types |
---|
| 2888 | (if singlep |
---|
| 2889 | (if doublep |
---|
| 2890 | (list *ctype-of-single-float-0* *ctype-of-double-float-0*) |
---|
| 2891 | (list *ctype-of-single-float-0*)) |
---|
| 2892 | (if doublep |
---|
[2530] | 2893 | (list *ctype-of-double-float-0*))))) |
---|
[318] | 2894 | (if union-types |
---|
| 2895 | (progn |
---|
| 2896 | (if singlep |
---|
| 2897 | (setq members (set-difference '(-0.0f0 0.0f0) members))) |
---|
| 2898 | (if doublep |
---|
| 2899 | (setq members (set-difference '(-0.d00 0.0d0) members))) |
---|
| 2900 | (make-union-ctype (if (null members) |
---|
| 2901 | union-types |
---|
| 2902 | (cons (%make-member-ctype members) union-types)))) |
---|
| 2903 | (%make-member-ctype members)))) |
---|
| 2904 | |
---|
| 2905 | |
---|
[6] | 2906 | (defun member-ctype-p (x) (istruct-typep x 'member-ctype)) |
---|
| 2907 | (setf (type-predicate 'member-ctype) 'member-ctype-p) |
---|
| 2908 | |
---|
| 2909 | (define-type-method (member :unparse) (type) |
---|
[279] | 2910 | (if (type= type (specifier-type 'standard-char)) |
---|
| 2911 | 'standard-char |
---|
| 2912 | (let ((members (member-ctype-members type))) |
---|
| 2913 | (if (equal members '(nil)) |
---|
[6] | 2914 | 'null |
---|
[279] | 2915 | `(member ,@members))))) |
---|
[6] | 2916 | |
---|
| 2917 | (define-type-method (member :simple-subtypep) (type1 type2) |
---|
| 2918 | (values (subsetp (member-ctype-members type1) (member-ctype-members type2)) |
---|
| 2919 | t)) |
---|
| 2920 | |
---|
| 2921 | |
---|
| 2922 | (define-type-method (member :complex-subtypep-arg1) (type1 type2) |
---|
[279] | 2923 | (every/type (swapped-args-fun #'ctypep) |
---|
| 2924 | type2 |
---|
| 2925 | (member-ctype-members type1))) |
---|
[6] | 2926 | |
---|
| 2927 | ;;; We punt if the odd type is enumerable and intersects with the member type. |
---|
| 2928 | ;;; If not enumerable, then it is definitely not a subtype of the member type. |
---|
| 2929 | ;;; |
---|
| 2930 | (define-type-method (member :complex-subtypep-arg2) (type1 type2) |
---|
| 2931 | (cond ((not (ctype-enumerable type1)) (values nil t)) |
---|
[279] | 2932 | ((types-intersect type1 type2) |
---|
| 2933 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
[6] | 2934 | (t |
---|
| 2935 | (values nil t)))) |
---|
| 2936 | |
---|
| 2937 | (define-type-method (member :simple-intersection) (type1 type2) |
---|
| 2938 | (let ((mem1 (member-ctype-members type1)) |
---|
[279] | 2939 | (mem2 (member-ctype-members type2))) |
---|
[6] | 2940 | (values (cond ((subsetp mem1 mem2) type1) |
---|
[279] | 2941 | ((subsetp mem2 mem1) type2) |
---|
| 2942 | (t |
---|
| 2943 | (let ((res (intersection mem1 mem2))) |
---|
| 2944 | (if res |
---|
| 2945 | (make-member-ctype :members res) |
---|
| 2946 | *empty-type*)))) |
---|
| 2947 | t))) |
---|
[6] | 2948 | |
---|
| 2949 | (define-type-method (member :complex-intersection) (type1 type2) |
---|
| 2950 | (block PUNT |
---|
[279] | 2951 | (collect ((members)) |
---|
[6] | 2952 | (let ((mem2 (member-ctype-members type2))) |
---|
[279] | 2953 | (dolist (member mem2) |
---|
| 2954 | (multiple-value-bind (val win) (ctypep member type1) |
---|
| 2955 | (unless win |
---|
| 2956 | (return-from punt nil)) |
---|
| 2957 | (when val (members member)))) |
---|
| 2958 | (cond ((subsetp mem2 (members)) type2) |
---|
| 2959 | ((null (members)) *empty-type*) |
---|
| 2960 | (t |
---|
| 2961 | (make-member-ctype :members (members)))))))) |
---|
[6] | 2962 | |
---|
| 2963 | ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union |
---|
| 2964 | ;;; type, and the member/union interaction is handled by the union type |
---|
| 2965 | ;;; method. |
---|
| 2966 | (define-type-method (member :simple-union) (type1 type2) |
---|
| 2967 | (let ((mem1 (member-ctype-members type1)) |
---|
[279] | 2968 | (mem2 (member-ctype-members type2))) |
---|
[6] | 2969 | (cond ((subsetp mem1 mem2) type2) |
---|
[279] | 2970 | ((subsetp mem2 mem1) type1) |
---|
| 2971 | (t |
---|
| 2972 | (make-member-ctype :members (union mem1 mem2)))))) |
---|
[6] | 2973 | |
---|
| 2974 | |
---|
| 2975 | (define-type-method (member :simple-=) (type1 type2) |
---|
| 2976 | (let ((mem1 (member-ctype-members type1)) |
---|
[279] | 2977 | (mem2 (member-ctype-members type2))) |
---|
[6] | 2978 | (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) |
---|
[279] | 2979 | t))) |
---|
[6] | 2980 | |
---|
| 2981 | (define-type-method (member :complex-=) (type1 type2) |
---|
| 2982 | (if (ctype-enumerable type1) |
---|
| 2983 | (multiple-value-bind (val win) |
---|
| 2984 | (csubtypep type2 type1) |
---|
| 2985 | (if (or val (not win)) |
---|
| 2986 | (values nil nil) |
---|
| 2987 | (values nil t))) |
---|
| 2988 | (values nil t))) |
---|
| 2989 | |
---|
| 2990 | (def-type-translator member (&rest members) |
---|
[279] | 2991 | (if members |
---|
| 2992 | (collect ((non-numbers) (numbers)) |
---|
| 2993 | (dolist (m (remove-duplicates members)) |
---|
| 2994 | (if (and (numberp m) |
---|
| 2995 | (not (and (floatp m) (zerop m)))) |
---|
| 2996 | (numbers (ctype-of m)) |
---|
| 2997 | (non-numbers m))) |
---|
| 2998 | (apply #'type-union |
---|
| 2999 | (if (non-numbers) |
---|
| 3000 | (make-member-ctype :members (non-numbers)) |
---|
| 3001 | *empty-type*) |
---|
| 3002 | (numbers))) |
---|
| 3003 | *empty-type*)) |
---|
[6] | 3004 | |
---|
[279] | 3005 | |
---|
[6] | 3006 | |
---|
| 3007 | ;;;; Union types: |
---|
| 3008 | |
---|
| 3009 | ;;; The Union-Type represents uses of the OR type specifier which can't be |
---|
| 3010 | ;;; canonicalized to something simpler. Canonical form: |
---|
| 3011 | ;;; |
---|
| 3012 | ;;; 1] There is never more than one Member-Type component. |
---|
| 3013 | ;;; 2] There are never any Union-Type components. |
---|
| 3014 | ;;; |
---|
| 3015 | |
---|
| 3016 | (defun make-union-ctype (types) |
---|
| 3017 | (declare (list types)) |
---|
| 3018 | (%istruct 'union-ctype |
---|
| 3019 | (type-class-or-lose 'union) |
---|
| 3020 | (every #'(lambda (x) (ctype-enumerable x)) types) |
---|
| 3021 | types)) |
---|
| 3022 | |
---|
| 3023 | (defun union-ctype-p (x) (istruct-typep x 'union-ctype)) |
---|
| 3024 | (setf (type-predicate 'union-ctype) 'union-ctype-p) |
---|
| 3025 | |
---|
| 3026 | |
---|
| 3027 | ;;; If List, then return that, otherwise the OR of the component types. |
---|
| 3028 | ;;; |
---|
| 3029 | (define-type-method (union :unparse) (type) |
---|
| 3030 | (declare (type ctype type)) |
---|
[279] | 3031 | (cond |
---|
| 3032 | ((type= type (specifier-type 'list)) 'list) |
---|
| 3033 | ((type= type (specifier-type 'float)) 'float) |
---|
| 3034 | ((type= type (specifier-type 'real)) 'real) |
---|
| 3035 | ((type= type (specifier-type 'sequence)) 'sequence) |
---|
| 3036 | ((type= type (specifier-type 'bignum)) 'bignum) |
---|
| 3037 | (t `(or ,@(mapcar #'type-specifier (union-ctype-types type)))))) |
---|
[6] | 3038 | |
---|
| 3039 | |
---|
| 3040 | |
---|
| 3041 | (define-type-method (union :simple-=) (type1 type2) |
---|
[279] | 3042 | (multiple-value-bind (subtype certain?) |
---|
| 3043 | (csubtypep type1 type2) |
---|
| 3044 | (if subtype |
---|
| 3045 | (csubtypep type2 type1) |
---|
| 3046 | (if certain? |
---|
| 3047 | (values nil t) |
---|
| 3048 | (multiple-value-bind (subtype certain?) |
---|
| 3049 | (csubtypep type2 type1) |
---|
| 3050 | (declare (ignore subtype)) |
---|
| 3051 | (values nil certain?)))))) |
---|
[6] | 3052 | |
---|
| 3053 | |
---|
[279] | 3054 | (define-type-method (union :complex-=) (type1 type2) |
---|
| 3055 | (declare (ignore type1)) |
---|
| 3056 | (if (some #'type-might-contain-other-types-p |
---|
| 3057 | (union-ctype-types type2)) |
---|
| 3058 | (values nil nil) |
---|
| 3059 | (values nil t))) |
---|
| 3060 | |
---|
| 3061 | |
---|
| 3062 | (defun union-simple-subtypep (type1 type2) |
---|
| 3063 | (every/type (swapped-args-fun #'union-complex-subtypep-arg2) |
---|
| 3064 | type2 |
---|
| 3065 | (union-ctype-types type1))) |
---|
| 3066 | |
---|
[6] | 3067 | (define-type-method (union :simple-subtypep) (type1 type2) |
---|
[279] | 3068 | (union-simple-subtypep type1 type2)) |
---|
[6] | 3069 | |
---|
[279] | 3070 | (defun union-complex-subtypep-arg1 (type1 type2) |
---|
| 3071 | (every/type (swapped-args-fun #'csubtypep) |
---|
| 3072 | type2 |
---|
| 3073 | (union-ctype-types type1))) |
---|
[6] | 3074 | |
---|
| 3075 | (define-type-method (union :complex-subtypep-arg1) (type1 type2) |
---|
[279] | 3076 | (union-complex-subtypep-arg1 type1 type2)) |
---|
[6] | 3077 | |
---|
[279] | 3078 | (defun union-complex-subtypep-arg2 (type1 type2) |
---|
| 3079 | (multiple-value-bind (sub-value sub-certain?) |
---|
| 3080 | (progn |
---|
| 3081 | (assert (union-ctype-p type2)) |
---|
| 3082 | (assert (not (union-ctype-p type1))) |
---|
| 3083 | (type= type1 |
---|
| 3084 | (apply #'type-union |
---|
| 3085 | (mapcar (lambda (x) (type-intersection type1 x)) |
---|
| 3086 | (union-ctype-types type2))))) |
---|
| 3087 | (if sub-certain? |
---|
| 3088 | (values sub-value sub-certain?) |
---|
| 3089 | (invoke-complex-subtypep-arg1-method type1 type2)))) |
---|
| 3090 | |
---|
[6] | 3091 | (define-type-method (union :complex-subtypep-arg2) (type1 type2) |
---|
[279] | 3092 | (union-complex-subtypep-arg2 type1 type2)) |
---|
[6] | 3093 | |
---|
[279] | 3094 | (define-type-method (union :simple-intersection :complex-intersection) |
---|
| 3095 | (type1 type2) |
---|
| 3096 | (assert (union-ctype-p type2)) |
---|
| 3097 | (cond ((and (union-ctype-p type1) |
---|
| 3098 | (union-simple-subtypep type1 type2)) type1) |
---|
| 3099 | ((and (union-ctype-p type1) |
---|
| 3100 | (union-simple-subtypep type2 type1)) type2) |
---|
| 3101 | ((and (not (union-ctype-p type1)) |
---|
| 3102 | (union-complex-subtypep-arg2 type1 type2)) |
---|
| 3103 | type1) |
---|
| 3104 | ((and (not (union-ctype-p type1)) |
---|
| 3105 | (union-complex-subtypep-arg1 type2 type1)) |
---|
| 3106 | type2) |
---|
| 3107 | (t |
---|
| 3108 | (let ((accumulator *empty-type*)) |
---|
| 3109 | (dolist (t2 (union-ctype-types type2) accumulator) |
---|
| 3110 | (setf accumulator |
---|
| 3111 | (type-union accumulator |
---|
| 3112 | (type-intersection type1 t2)))))))) |
---|
[6] | 3113 | |
---|
| 3114 | |
---|
[279] | 3115 | |
---|
[9892] | 3116 | (def-type-translator or (&rest type-specifiers &environment env) |
---|
[279] | 3117 | (apply #'type-union |
---|
[9892] | 3118 | (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers))) |
---|
[279] | 3119 | |
---|
| 3120 | |
---|
| 3121 | ;;; Intersection types |
---|
| 3122 | (defun make-intersection-ctype (enumerable types) |
---|
| 3123 | (%istruct 'intersection-ctype |
---|
| 3124 | (type-class-or-lose 'intersection) |
---|
| 3125 | enumerable |
---|
| 3126 | types)) |
---|
| 3127 | |
---|
| 3128 | (defun intersection-ctype-p (x) |
---|
| 3129 | (istruct-typep x 'intersection-ctype)) |
---|
| 3130 | (setf (type-predicate 'intersection-ctype) 'intersection-ctype-p) |
---|
| 3131 | |
---|
| 3132 | (define-type-method (intersection :unparse) (type) |
---|
| 3133 | (declare (type ctype type)) |
---|
| 3134 | (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) |
---|
| 3135 | `(and ,@(mapcar #'type-specifier (intersection-ctype-types type))))) |
---|
| 3136 | |
---|
| 3137 | ;;; shared machinery for type equality: true if every type in the set |
---|
| 3138 | ;;; TYPES1 matches a type in the set TYPES2 and vice versa |
---|
| 3139 | (defun type=-set (types1 types2) |
---|
| 3140 | (flet (;; true if every type in the set X matches a type in the set Y |
---|
| 3141 | (type<=-set (x y) |
---|
| 3142 | (declare (type list x y)) |
---|
| 3143 | (every (lambda (xelement) |
---|
| 3144 | (position xelement y :test #'type=)) |
---|
| 3145 | x))) |
---|
| 3146 | (values (and (type<=-set types1 types2) |
---|
| 3147 | (type<=-set types2 types1)) |
---|
| 3148 | t))) |
---|
| 3149 | |
---|
| 3150 | (define-type-method (intersection :simple-=) (type1 type2) |
---|
| 3151 | (type=-set (intersection-ctype-types type1) |
---|
| 3152 | (intersection-ctype-types type2))) |
---|
| 3153 | |
---|
| 3154 | (defun %intersection-complex-subtypep-arg1 (type1 type2) |
---|
| 3155 | (type= type1 (type-intersection type1 type2))) |
---|
| 3156 | |
---|
| 3157 | (defun %intersection-simple-subtypep (type1 type2) |
---|
| 3158 | (every/type #'%intersection-complex-subtypep-arg1 |
---|
| 3159 | type1 |
---|
| 3160 | (intersection-ctype-types type2))) |
---|
| 3161 | |
---|
| 3162 | (define-type-method (intersection :simple-subtypep) (type1 type2) |
---|
| 3163 | (%intersection-simple-subtypep type1 type2)) |
---|
| 3164 | |
---|
| 3165 | (define-type-method (intersection :complex-subtypep-arg1) (type1 type2) |
---|
| 3166 | (%intersection-complex-subtypep-arg1 type1 type2)) |
---|
| 3167 | |
---|
| 3168 | (defun %intersection-complex-subtypep-arg2 (type1 type2) |
---|
| 3169 | (every/type #'csubtypep type1 (intersection-ctype-types type2))) |
---|
| 3170 | |
---|
| 3171 | (define-type-method (intersection :complex-subtypep-arg2) (type1 type2) |
---|
| 3172 | (%intersection-complex-subtypep-arg2 type1 type2)) |
---|
| 3173 | |
---|
| 3174 | (define-type-method (intersection :simple-union :complex-union) |
---|
| 3175 | (type1 type2) |
---|
| 3176 | (assert (intersection-ctype-p type2)) |
---|
| 3177 | (cond ((and (intersection-ctype-p type1) |
---|
| 3178 | (%intersection-simple-subtypep type1 type2)) type2) |
---|
| 3179 | ((and (intersection-ctype-p type1) |
---|
| 3180 | (%intersection-simple-subtypep type2 type1)) type1) |
---|
| 3181 | ((and (not (intersection-ctype-p type1)) |
---|
| 3182 | (%intersection-complex-subtypep-arg2 type1 type2)) |
---|
| 3183 | type2) |
---|
| 3184 | ((and (not (intersection-ctype-p type1)) |
---|
| 3185 | (%intersection-complex-subtypep-arg1 type2 type1)) |
---|
| 3186 | type1) |
---|
| 3187 | ((and (csubtypep type2 (specifier-type 'ratio)) |
---|
| 3188 | (numeric-ctype-p type1) |
---|
| 3189 | (csubtypep type1 (specifier-type 'integer)) |
---|
| 3190 | (csubtypep type2 |
---|
| 3191 | (make-numeric-ctype |
---|
| 3192 | :class 'rational |
---|
| 3193 | :complexp nil |
---|
| 3194 | :low (if (null (numeric-ctype-low type1)) |
---|
| 3195 | nil |
---|
| 3196 | (list (1- (numeric-ctype-low type1)))) |
---|
| 3197 | :high (if (null (numeric-ctype-high type1)) |
---|
| 3198 | nil |
---|
| 3199 | (list (1+ (numeric-ctype-high type1))))))) |
---|
| 3200 | (type-union type1 |
---|
| 3201 | (apply #'type-intersection |
---|
| 3202 | (remove (specifier-type '(not integer)) |
---|
| 3203 | (intersection-ctype-types type2) |
---|
| 3204 | :test #'type=)))) |
---|
| 3205 | (t |
---|
| 3206 | (let ((accumulator *universal-type*)) |
---|
| 3207 | (do ((t2s (intersection-ctype-types type2) (cdr t2s))) |
---|
| 3208 | ((null t2s) accumulator) |
---|
| 3209 | (let ((union (type-union type1 (car t2s)))) |
---|
| 3210 | (when (union-ctype-p union) |
---|
| 3211 | (if (and (eq accumulator *universal-type*) |
---|
| 3212 | (null (cdr t2s))) |
---|
| 3213 | (return union) |
---|
| 3214 | (return nil))) |
---|
| 3215 | (setf accumulator |
---|
| 3216 | (type-intersection accumulator union)))))))) |
---|
| 3217 | |
---|
[9892] | 3218 | (def-type-translator and (&rest type-specifiers &environment env) |
---|
[279] | 3219 | (apply #'type-intersection |
---|
[9892] | 3220 | (mapcar #'(lambda (spec) (specifier-type spec env)) |
---|
[279] | 3221 | type-specifiers))) |
---|
| 3222 | |
---|
| 3223 | ;;; cons-ctype |
---|
| 3224 | (defun wild-ctype-to-universal-ctype (c) |
---|
| 3225 | (if (t |
---|