1;;;; TYPEP und Verwandtes 2;;;; Michael Stoll, 21. 10. 1988 3;;;; Bruno Haible, 10.6.1989 4;;;; Sam Steingold 2000-2005 5 6;;; Datenstrukturen für TYPEP: 7;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem 8;;; Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die 9;;; testet, ob ein Objekt vom richtigen Typ ist. 10;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner 11;;; Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von 12;;; einem Argument für das zu testende Objekt und zusätzlichen Argumenten 13;;; für die Listenelemente. 14;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property- 15;;; liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen 16;;; Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine 17;;; mindestens einelementige Liste) als Argument bekommt. 18 19(in-package "EXT") 20(export '(type-expand)) 21(in-package "SYSTEM") 22 23; vorläufig, solange bis clos.lisp geladen wird: 24(eval-when (eval) 25 (predefun clos::built-in-class-p (object) (declare (ignore object)) nil)) 26(unless (fboundp 'clos::class-name) 27 (defun clos::class-name (c) (declare (ignore c)) nil) 28) 29 30(defun typespec-error (fun type) 31 (error-of-type 'error 32 (TEXT "~S: invalid type specification ~S") 33 fun type 34) ) 35 36;; ============================================================================ 37 38;; return the CLOS class named by TYPESPEC or NIL 39(defun clos-class (typespec) 40 (let ((cc (get typespec 'CLOS::CLOSCLASS))) 41 (when (and cc (clos::defined-class-p cc) (eq (clos:class-name cc) typespec)) 42 cc))) 43 44;;; TYPEP, CLTL S. 72, S. 42-51 45(defun typep (x y &optional env &aux f) ; x = Objekt, y = Typ 46 (declare (ignore env)) 47 (setq y (expand-deftype y)) 48 (cond 49 ((symbolp y) 50 (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x)) 51 ((setq f (get y 'TYPE-LIST)) (funcall f x)) 52 ((setq f (get y 'DEFSTRUCT-DESCRIPTION)) (ds-typep x y f)) 53 ((setq f (clos-class y)) 54 ; It's not worth handling structure classes specially here. 55 (clos::typep-class x f)) 56 (t (typespec-error 'typep y)) 57 ) ) 58 ((and (consp y) (symbolp (first y))) 59 (cond 60 ((and (eq (first y) 'SATISFIES) (eql (length y) 2)) 61 (unless (symbolp (second y)) 62 (error-of-type 'error 63 (TEXT "~S: argument to SATISFIES must be a symbol: ~S") 64 'typep (second y) 65 ) ) 66 (if (funcall (symbol-function (second y)) x) t nil) 67 ) 68 ((eq (first y) 'MEMBER) 69 (if (member x (rest y)) t nil) 70 ) 71 ((and (eq (first y) 'EQL) (eql (length y) 2)) 72 (eql x (second y)) 73 ) 74 ((and (eq (first y) 'NOT) (eql (length y) 2)) 75 (not (typep x (second y))) 76 ) 77 ((eq (first y) 'AND) 78 (dolist (type (rest y) t) 79 (unless (typep x type) (return nil)) 80 ) ) 81 ((eq (first y) 'OR) 82 (dolist (type (rest y) nil) 83 (when (typep x type) (return t)) 84 ) ) 85 ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y))) 86 (t (typespec-error 'typep y)) 87 ) ) 88 ((clos::defined-class-p y) (clos::typep-class x y)) 89 ((clos::eql-specializer-p y) (eql x (clos::eql-specializer-singleton y))) 90 ((encodingp y) (charset-typep x y)) 91 (t (typespec-error 'typep y)) 92) ) 93 94;; ---------------------------------------------------------------------------- 95 96;; UPGRADED-ARRAY-ELEMENT-TYPE is a lattice homomorphism, see 97;; ANSI CL 15.1.2.1. 98(defun upgraded-array-element-type (type &optional environment) 99 (declare (ignore environment)) 100 ;; see array.d 101 (case type 102 ((BIT) 'BIT) 103 ((CHARACTER) 'CHARACTER) 104 ((T) 'T) 105 ((NIL) 'NIL) 106 (t (if (subtypep type 'NIL) 107 'NIL 108 (multiple-value-bind (low high) (sys::subtype-integer type) 109 ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))) 110 (if (and (integerp low) (not (minusp low)) (integerp high)) 111 (let ((l (integer-length high))) 112 ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l)) 113 (cond ((<= l 1) 'BIT) 114 ((<= l 2) '(UNSIGNED-BYTE 2)) 115 ((<= l 4) '(UNSIGNED-BYTE 4)) 116 ((<= l 8) '(UNSIGNED-BYTE 8)) 117 ((<= l 16) '(UNSIGNED-BYTE 16)) 118 ((<= l 32) '(UNSIGNED-BYTE 32)) 119 (t 'T))) 120 (if (subtypep type 'CHARACTER) 121 'CHARACTER 122 'T))))))) 123 124;; ---------------------------------------------------------------------------- 125 126;; UPGRADED-COMPLEX-PART-TYPE is a lattice homomorphism, see 127;; HyperSpec/Body/fun_complex.html and HyperSpec/Body/syscla_complex.html, 128;; and an idempotent. Therefore 129;; (subtypep (upgraded-complex-part-type T1) (upgraded-complex-part-type T2)) 130;; is equivalent to 131;; (subtypep T1 (upgraded-complex-part-type T2)) 132;; (Proof: Let U T be an abbreviation for (upgraded-complex-part-type T). 133;; If U T1 <= U T2, then T1 <= U T1 <= U T2. 134;; If T1 <= U T2, then by homomorphism U T1 <= U U T2 = U T2.) 135;; 136;; For _any_ CL implementation, you could define 137;; (defun upgraded-complex-part-type (type) 'REAL) 138;; Likewise for _any_ CL implementation, you could define 139;; (defun upgraded-complex-part-type (type) type) 140;; or - again for _any_ CL implementation: 141;; (defun upgraded-complex-part-type (type) 142;; (cond ((subtypep type 'NIL) 'NIL) 143;; ((subtypep type 'SHORT-FLOAT) 'SHORT-FLOAT) 144;; ((subtypep type 'SINGLE-FLOAT) 'SINGLE-FLOAT) 145;; ((subtypep type 'DOUBLE-FLOAT) 'DOUBLE-FLOAT) 146;; ((subtypep type 'LONG-FLOAT) 'LONG-FLOAT) 147;; ((subtypep type 'RATIONAL) 'RATIONAL) 148;; ((subtypep type 'REAL) 'REAL) 149;; (t (error ...)))) 150;; The reason is that a complex number is immutable: no setters for the 151;; realpart and imagpart exist. 152;; 153;; We choose the second implementation because it allows the most precise 154;; type inference. 155(defun upgraded-complex-part-type (type &optional environment) 156 (declare (ignore environment)) 157 (if (subtypep type 'REAL) 158 type 159 (error-of-type 'error 160 (TEXT "~S: type ~S is not a subtype of ~S") 161 'upgraded-complex-part-type type 'real))) 162 163;; ---------------------------------------------------------------------------- 164 165;; Macros for defining the various built-in "atomic type specifier"s and 166;; "compound type specifier"s. The following macros add information for both 167;; the TYPEP function above and the c-TYPEP in the compiler. 168 169; Alist symbol -> funname, used by the compiler. 170(defparameter c-typep-alist1 '()) 171; Alist symbol -> lambdabody, used by the compiler. 172(defparameter c-typep-alist2 '()) 173; Alist symbol -> expander function, used by the compiler. 174(defparameter c-typep-alist3 '()) 175 176; (def-atomic-type symbol function-name) 177; defines an atomic type. The function-name designates a function taking one 178; argument and returning a generalized boolean value. It can be either a 179; symbol or a lambda expression. 180(defmacro def-atomic-type (symbol funname) 181 (let ((lambdap (and (consp funname) (eq (car funname) 'LAMBDA)))) 182 `(PROGN 183 (SETF (GET ',symbol 'TYPE-SYMBOL) 184 ,(if lambdap 185 `(FUNCTION ,(concat-pnames "TYPE-SYMBOL-" symbol) ,funname) 186 `(FUNCTION ,funname) 187 ) 188 ) 189 ,(if lambdap 190 `(SETQ C-TYPEP-ALIST2 191 (NCONC C-TYPEP-ALIST2 (LIST (CONS ',symbol ',(cdr funname)))) 192 ) 193 `(SETQ C-TYPEP-ALIST1 194 (NCONC C-TYPEP-ALIST1 (LIST (CONS ',symbol ',funname))) 195 ) 196 ) 197 ',symbol 198 ) 199) ) 200 201; (def-compound-type symbol lambda-list (x) check-form typep-form c-typep-form) 202; defines a compound type. The lambda-list is of the form (&optional ...) 203; where the arguments come from the CDR of the type specifier. 204; For typep-form, x is an object. 205; For c-typep-form, x is a multiply evaluatable form (actually a gensym). 206; check-form is a form performing error checking, may call `error'. 207; typep-form should return a generalized boolean value. 208; c-typep-form should produce a form returning a generalized boolean value. 209(defmacro def-compound-type (symbol lambdalist (var) check-form typep-form c-typep-form) 210 `(PROGN 211 (SETF (GET ',symbol 'TYPE-LIST) 212 (FUNCTION ,(concat-pnames "TYPE-LIST-" symbol) 213 (LAMBDA (,var ,@lambdalist) 214 ,@(if check-form 215 `((MACROLET ((ERROR (&REST ERROR-ARGS) 216 (LIST* 'ERROR-OF-TYPE ''ERROR ERROR-ARGS) 217 )) 218 ,check-form 219 )) 220 ) 221 ,typep-form 222 ) ) ) 223 (SETQ C-TYPEP-ALIST3 224 (NCONC C-TYPEP-ALIST3 225 (LIST (CONS ',symbol 226 #'(LAMBDA (,var ,@lambdalist &REST ILLEGAL-ARGS) 227 (DECLARE (IGNORE ILLEGAL-ARGS)) 228 ,@(if check-form 229 `((MACROLET ((ERROR (&REST ERROR-ARGS) 230 (LIST 'PROGN 231 (LIST* 'C-WARN ERROR-ARGS) 232 '(THROW 'C-TYPEP NIL) 233 )) ) 234 ,check-form 235 )) 236 ) 237 ,c-typep-form 238 ) 239 ) ) ) ) 240 ',symbol 241 ) 242) 243 244; CLtL1 p. 43 245(def-atomic-type ARRAY arrayp) 246(def-atomic-type ATOM atom) 247(def-atomic-type BASE-CHAR 248 #+BASE-CHAR=CHARACTER 249 characterp 250 #-BASE-CHAR=CHARACTER 251 (lambda (x) (and (characterp x) (base-char-p x))) 252) 253(def-atomic-type BASE-STRING 254 (lambda (x) 255 (and (stringp x) 256 (eq (array-element-type x) 257 #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR 258) ) ) ) 259(def-atomic-type BIGNUM 260 (lambda (x) (and (integerp x) (not (fixnump x)))) 261) 262(def-atomic-type BIT 263 (lambda (x) (or (eql x 0) (eql x 1))) 264) 265(def-atomic-type BIT-VECTOR bit-vector-p) 266(def-atomic-type BOOLEAN 267 (lambda (x) (or (eq x 'nil) (eq x 't))) 268) 269(def-atomic-type CHARACTER characterp) 270(def-atomic-type COMPILED-FUNCTION compiled-function-p) 271(def-atomic-type COMPLEX complexp) 272(def-atomic-type CONS consp) 273(def-atomic-type DOUBLE-FLOAT double-float-p) 274(def-atomic-type ENCODING encodingp) 275(def-atomic-type EXTENDED-CHAR 276 #+BASE-CHAR=CHARACTER 277 (lambda (x) (declare (ignore x)) nil) 278 #-BASE-CHAR=CHARACTER 279 (lambda (x) (and (characterp x) (not (base-char-p x)))) 280) 281(def-atomic-type FIXNUM fixnump) 282(def-atomic-type FLOAT floatp) 283(def-atomic-type FUNCTION functionp) 284(def-atomic-type HASH-TABLE hash-table-p) 285(def-atomic-type INTEGER integerp) 286(def-atomic-type KEYWORD keywordp) 287(def-atomic-type LIST listp) 288#+LOGICAL-PATHNAMES 289(def-atomic-type LOGICAL-PATHNAME logical-pathname-p) 290(def-atomic-type LONG-FLOAT long-float-p) 291(def-atomic-type NIL 292 (lambda (x) (declare (ignore x)) nil) 293) 294(def-atomic-type NULL null) 295(def-atomic-type NUMBER numberp) 296(def-atomic-type PACKAGE packagep) 297(def-atomic-type PATHNAME pathnamep) 298(def-atomic-type RANDOM-STATE random-state-p) 299(def-atomic-type RATIO 300 (lambda (x) (and (rationalp x) (not (integerp x)))) 301) 302(def-atomic-type RATIONAL rationalp) 303(def-atomic-type READTABLE readtablep) 304(def-atomic-type REAL realp) 305(def-atomic-type SEQUENCE sequencep) 306(def-atomic-type SHORT-FLOAT short-float-p) 307(def-atomic-type SIMPLE-ARRAY simple-array-p) 308(def-atomic-type SIMPLE-BASE-STRING 309 (lambda (x) 310 (and (simple-string-p x) 311 (eq (array-element-type x) 312 #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR 313) ) ) ) 314(def-atomic-type SIMPLE-BIT-VECTOR simple-bit-vector-p) 315(def-atomic-type SIMPLE-STRING simple-string-p) 316(def-atomic-type SIMPLE-VECTOR simple-vector-p) 317(def-atomic-type SINGLE-FLOAT single-float-p) 318(defun %standard-char-p (x) (and (characterp x) (standard-char-p x))) ; ABI 319(def-atomic-type STANDARD-CHAR %standard-char-p) 320(def-atomic-type CLOS:STANDARD-OBJECT clos::std-instance-p) 321(def-atomic-type STREAM streamp) 322(def-atomic-type FILE-STREAM file-stream-p) 323(def-atomic-type SYNONYM-STREAM synonym-stream-p) 324(def-atomic-type BROADCAST-STREAM broadcast-stream-p) 325(def-atomic-type CONCATENATED-STREAM concatenated-stream-p) 326(def-atomic-type TWO-WAY-STREAM two-way-stream-p) 327(def-atomic-type ECHO-STREAM echo-stream-p) 328(def-atomic-type STRING-STREAM string-stream-p) 329(def-atomic-type STRING stringp) 330(def-atomic-type STRING-CHAR characterp) 331(def-atomic-type CLOS:STRUCTURE-OBJECT clos::structure-object-p) 332(def-atomic-type SYMBOL symbolp) 333(def-atomic-type T (lambda (x) (declare (ignore x)) t)) 334;; foreign1.lisp is loaded after this file, 335;; so these symbols are not external yet 336#+ffi 337(def-atomic-type ffi::foreign-function 338 (lambda (x) (eq 'ffi::foreign-function (type-of x)))) 339#+ffi 340(def-atomic-type ffi::foreign-variable 341 (lambda (x) (eq 'ffi::foreign-variable (type-of x)))) 342#+ffi 343(def-atomic-type ffi::foreign-address 344 (lambda (x) (eq 'ffi::foreign-address (type-of x)))) 345;; see lispbibl.d (#define FOREIGN) and predtype.d (TYPE-OF): 346#+(or unix ffi affi win32) 347(def-atomic-type foreign-pointer 348 (lambda (x) (eq 'foreign-pointer (type-of x)))) 349(def-atomic-type VECTOR vectorp) 350(def-atomic-type PLIST 351 (lambda (x) (multiple-value-bind (length tail) (list-length-dotted x) 352 (and (null tail) (evenp length))))) 353 354(defmacro ensure-dim (type dim) 355 ;; make sure DIM is a valid dimension 356 `(unless (or (eq ,dim '*) (typep ,dim `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT)))) 357 (error (TEXT "~S: dimension ~S is invalid") ',type ,dim))) 358 359(defmacro ensure-rank (type rank) 360 ;; make sure RANK is a valid rank 361 `(unless (typep ,rank `(INTEGER 0 (,ARRAY-RANK-LIMIT))) 362 (error (TEXT "~S: rank ~S is invalid") ',type ,rank))) 363 364; CLtL1 p. 46-50 365(defun c-typep-array (tester el-type dims x) 366 `(AND (,tester ,x) 367 ,@(if (eq el-type '*) 368 '() 369 `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type))) 370 ) 371 ,@(if (eq dims '*) 372 '() 373 (if (numberp dims) 374 `((EQL ,dims (ARRAY-RANK ,x))) 375 `((EQL ,(length dims) (ARRAY-RANK ,x)) 376 ,@(let ((i 0)) 377 (mapcap #'(lambda (dim) 378 (prog1 379 (if (eq dim '*) 380 '() 381 `((EQL ',dim (ARRAY-DIMENSION ,x ,i))) 382 ) 383 (incf i) 384 ) ) 385 dims 386 ) ) 387 ) 388 ) ) 389 ) 390) 391(defun c-typep-vector (tester size x) 392 `(AND (,tester ,x) 393 ,@(if (eq size '*) 394 '() 395 `((EQL ',size (ARRAY-DIMENSION ,x 0))) 396 ) 397 ) 398) 399(defun typep-number-test (x low high test type) 400 (and (funcall test x) 401 (cond ((eq low '*)) 402 ((funcall test low) (<= low x)) 403 ((and (consp low) (null (rest low)) (funcall test (first low))) 404 (< (first low) x) 405 ) 406 (t (error-of-type 'error 407 #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S") 408 'typep type type type low 409 ) ) ) 410 (cond ((eq high '*)) 411 ((funcall test high) (>= high x)) 412 ((and (consp high) (null (rest high)) (funcall test (first high))) 413 (> (first high) x) 414 ) 415 (t (error-of-type 'error 416 #1# 'typep type type type high 417) ) ) ) ) 418(defun c-typep-number (caller tester low high x) 419 `(AND (,tester ,x) 420 ,@(cond ((eq low '*) '()) 421 ((funcall tester low) `((<= ,low ,x))) 422 ((and (consp low) (null (rest low)) (funcall tester (first low))) 423 `((< ,(first low) ,x)) 424 ) 425 (t (c-warn #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S") 426 'typep caller caller caller low 427 ) 428 (throw 'c-TYPEP nil) 429 ) ) 430 ,@(cond ((eq high '*) '()) 431 ((funcall tester high) `((>= ,high ,x))) 432 ((and (consp high) (null (rest high)) (funcall tester (first high))) 433 `((> ,(first high) ,x)) 434 ) 435 (t (c-warn #1# 'typep caller caller caller high) 436 (throw 'c-TYPEP nil) 437 ) ) 438 ) 439) 440(def-compound-type ARRAY (&optional (el-type '*) (dims '*)) (x) 441 (unless (eq dims '*) 442 (if (numberp dims) 443 (ensure-rank ARRAY dims) 444 (dolist (dim dims) (ensure-dim ARRAY dim)))) 445 (and (arrayp x) 446 (or (eq el-type '*) 447 (equal (array-element-type x) (upgraded-array-element-type el-type)) 448 ) 449 (or (eq dims '*) 450 (if (numberp dims) 451 (eql dims (array-rank x)) 452 (and (eql (length dims) (array-rank x)) 453 (every #'(lambda (a b) (or (eq a '*) (eql a b))) 454 dims (array-dimensions x) 455 ) ) ) ) ) 456 (c-typep-array 'ARRAYP el-type dims x) 457) 458(def-compound-type SIMPLE-ARRAY (&optional (el-type '*) (dims '*)) (x) 459 (unless (eq dims '*) 460 (if (numberp dims) 461 (ensure-rank SIMPLE-ARRAY dims) 462 (dolist (dim dims) (ensure-dim SIMPLE-ARRAY dim)))) 463 (and (simple-array-p x) 464 (or (eq el-type '*) 465 (equal (array-element-type x) (upgraded-array-element-type el-type)) 466 ) 467 (or (eq dims '*) 468 (if (numberp dims) 469 (eql dims (array-rank x)) 470 (and (eql (length dims) (array-rank x)) 471 (every #'(lambda (a b) (or (eq a '*) (eql a b))) 472 dims (array-dimensions x) 473 ) ) ) ) ) 474 (c-typep-array 'SIMPLE-ARRAY-P el-type dims x) 475) 476(def-compound-type VECTOR (&optional (el-type '*) (size '*)) (x) 477 (ensure-dim VECTOR size) 478 (and (vectorp x) 479 (or (eq el-type '*) 480 (equal (array-element-type x) (upgraded-array-element-type el-type)) 481 ) 482 (or (eq size '*) (eql (array-dimension x 0) size)) 483 ) 484 `(AND (VECTORP ,x) 485 ,@(if (eq el-type '*) 486 '() 487 `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type))) 488 ) 489 ,@(if (eq size '*) 490 '() 491 `((EQL (ARRAY-DIMENSION ,x 0) ',size)) 492 ) 493 ) 494) 495(def-compound-type SIMPLE-VECTOR (&optional (size '*)) (x) 496 (ensure-dim SIMLPE-VECTOR size) 497 (and (simple-vector-p x) 498 (or (eq size '*) (eql size (array-dimension x 0))) 499 ) 500 (c-typep-vector 'SIMPLE-VECTOR-P size x) 501) 502(def-compound-type COMPLEX (&optional (rtype '*) (itype rtype)) (x) 503 nil 504 (and (complexp x) 505 (or (eq rtype '*) 506 (typep (realpart x) (upgraded-complex-part-type rtype))) 507 (or (eq itype '*) 508 (typep (imagpart x) (upgraded-complex-part-type itype)))) 509 `(AND (COMPLEXP ,x) 510 ,@(if (eq rtype '*) 511 '() 512 `((TYPEP (REALPART ,x) ',(upgraded-complex-part-type rtype)))) 513 ,@(if (eq itype '*) 514 '() 515 `((TYPEP (IMAGPART ,x) ',(upgraded-complex-part-type itype)))))) 516(def-compound-type INTEGER (&optional (low '*) (high '*)) (x) 517 nil 518 (typep-number-test x low high #'integerp 'INTEGER) 519 (c-typep-number 'INTEGER 'INTEGERP low high x) 520) 521(def-compound-type MOD (n) (x) 522 (unless (integerp n) 523 (error (TEXT "~S: argument to MOD must be an integer: ~S") 524 'typep n 525 ) ) 526 (and (integerp x) (<= 0 x) (< x n)) 527 `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n)) 528) 529(def-compound-type SIGNED-BYTE (&optional (n '*)) (x) 530 (unless (or (eq n '*) (integerp n)) 531 (error (TEXT "~S: argument to SIGNED-BYTE must be an integer or * : ~S") 532 'typep n 533 ) ) 534 (and (integerp x) (or (eq n '*) (< (integer-length x) n))) 535 `(AND (INTEGERP ,x) 536 ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n))) 537 ) 538) 539(def-compound-type UNSIGNED-BYTE (&optional (n '*)) (x) 540 (unless (or (eq n '*) (integerp n)) 541 (error (TEXT "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S") 542 'typep n 543 ) ) 544 (and (integerp x) 545 (not (minusp x)) 546 (or (eq n '*) (<= (integer-length x) n)) 547 ) 548 `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) 549 ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n))) 550 ) 551) 552(def-compound-type REAL (&optional (low '*) (high '*)) (x) 553 nil 554 (typep-number-test x low high #'realp 'REAL) 555 (c-typep-number 'REAL 'REALP low high x) 556) 557(def-compound-type RATIONAL (&optional (low '*) (high '*)) (x) 558 nil 559 (typep-number-test x low high #'rationalp 'RATIONAL) 560 (c-typep-number 'RATIONAL 'RATIONALP low high x) 561) 562(def-compound-type FLOAT (&optional (low '*) (high '*)) (x) 563 nil 564 (typep-number-test x low high #'floatp 'FLOAT) 565 (c-typep-number 'FLOAT 'FLOATP low high x) 566) 567(def-compound-type SHORT-FLOAT (&optional (low '*) (high '*)) (x) 568 nil 569 (typep-number-test x low high #'short-float-p 'SHORT-FLOAT) 570 (c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P low high x) 571) 572(def-compound-type SINGLE-FLOAT (&optional (low '*) (high '*)) (x) 573 nil 574 (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT) 575 (c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P low high x) 576) 577(def-compound-type DOUBLE-FLOAT (&optional (low '*) (high '*)) (x) 578 nil 579 (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT) 580 (c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P low high x) 581) 582(def-compound-type LONG-FLOAT (&optional (low '*) (high '*)) (x) 583 nil 584 (typep-number-test x low high #'long-float-p 'LONG-FLOAT) 585 (c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P low high x) 586) 587(def-compound-type STRING (&optional (size '*)) (x) 588 (ensure-dim STRING size) 589 (and (stringp x) 590 (or (eq size '*) (eql size (array-dimension x 0))) 591 ) 592 (c-typep-vector 'STRINGP size x) 593) 594(def-compound-type SIMPLE-STRING (&optional (size '*)) (x) 595 (ensure-dim SIMPLE-STRING size) 596 (and (simple-string-p x) 597 (or (eq size '*) (eql size (array-dimension x 0))) 598 ) 599 (c-typep-vector 'SIMPLE-STRING-P size x) 600) 601(def-compound-type BASE-STRING (&optional (size '*)) (x) 602 (ensure-dim BASE-STRING size) 603 (and (stringp x) 604 (or (eq size '*) (eql size (array-dimension x 0))) 605 ) 606 (c-typep-vector 'STRINGP size x) 607) 608(def-compound-type SIMPLE-BASE-STRING (&optional (size '*)) (x) 609 (ensure-dim SIMPLE-BASE-STRING size) 610 (and (simple-string-p x) 611 (or (eq size '*) (eql size (array-dimension x 0))) 612 ) 613 (c-typep-vector 'SIMPLE-STRING-P size x) 614) 615(def-compound-type BIT-VECTOR (&optional (size '*)) (x) 616 (ensure-dim BIT-VECTOR size) 617 (and (bit-vector-p x) 618 (or (eq size '*) (eql size (array-dimension x 0))) 619 ) 620 (c-typep-vector 'BIT-VECTOR-P size x) 621) 622(def-compound-type SIMPLE-BIT-VECTOR (&optional (size '*)) (x) 623 (ensure-dim SIMPLE-BIT-VECTOR size) 624 (and (simple-bit-vector-p x) 625 (or (eq size '*) (eql size (array-dimension x 0))) 626 ) 627 (c-typep-vector 'SIMPLE-BIT-VECTOR-P size x) 628) 629(def-compound-type CONS (&optional (car-type '*) (cdr-type '*)) (x) 630 nil 631 (and (consp x) 632 (or (eq car-type '*) (typep (car x) car-type)) 633 (or (eq cdr-type '*) (typep (cdr x) cdr-type)) 634 ) 635 `(AND (CONSP ,x) 636 ,@(if (eq car-type '*) '() `((TYPEP (CAR ,x) ',car-type))) 637 ,@(if (eq cdr-type '*) '() `((TYPEP (CDR ,x) ',cdr-type))) 638 ) 639) 640 641(fmakunbound 'def-compound-type) 642 643;; ---------------------------------------------------------------------------- 644 645; Typtest ohne Gefahr einer Fehlermeldung. Für SIGNAL und HANDLER-BIND. 646(defun safe-typep (x y &optional env) 647 (let ((*error-handler* 648 #'(lambda (&rest error-args) 649 (declare (ignore error-args)) 650 (return-from safe-typep (values nil nil)) 651 )) ) 652 (values (typep x y env) t) 653) ) 654 655; Umwandlung eines "type for declaration" in einen "type for discrimination". 656(defun type-for-discrimination (y &optional (notp nil) &aux f) 657 (cond ((symbolp y) 658 (cond ((get y 'TYPE-SYMBOL) y) 659 ((get y 'TYPE-LIST) y) 660 ((setq f (get y 'DEFTYPE-EXPANDER)) 661 (let* ((z (funcall f (list y))) 662 (zx (type-for-discrimination z notp))) 663 (if (eql zx z) y zx) 664 )) 665 (t y) 666 ) ) 667 ((and (consp y) (symbolp (first y))) 668 (case (first y) 669 ((SATISFIES MEMBER EQL) y) 670 (NOT 671 (let* ((z (second y)) 672 (zx (type-for-discrimination z (not notp)))) 673 (if (eql zx z) y `(NOT ,zx)) 674 )) 675 ((AND OR COMPLEX VALUES) 676 (let* ((z (rest y)) 677 (zx (mapcar #'(lambda (x) (type-for-discrimination x notp)) z))) 678 (if (every #'eql z zx) y (cons (first y) zx)) 679 )) 680 (FUNCTION 681 ;; (FUNCTION arg-types res-type) is somewhere between 682 ;; NIL and FUNCTION, but undecidable. 683 (if notp 'NIL 'FUNCTION) 684 ) 685 (t (cond ((get (first y) 'TYPE-LIST) y) 686 ((setq f (get (first y) 'DEFTYPE-EXPANDER)) 687 (let* ((z (funcall f y)) 688 (zx (type-for-discrimination z notp))) 689 (if (eql zx z) y zx) 690 )) 691 (t y) 692 ) ) ) ) 693 (t y) 694) ) 695 696; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE. 697(defun %the (values type) ; ABI 698 (macrolet ((near-typep (objform typform) 699 ;; near-typep ist wie typep, nur dass das Objekt auch ein 700 ;; Read-Label sein darf. Das tritt z.B. auf bei 701 ;; (read-from-string "#1=#S(FOO :X #1#)") 702 ;; im Konstruktor MAKE-FOO. Die Implementation ist aber 703 ;; nicht gezwungen, bei fehlerhaftem THE zwingend einen 704 ;; Fehler zu melden, darum ist ein lascherer Typcheck hier 705 ;; erlaubt. 706 (let ((g (gensym))) 707 `(let ((,g ,objform)) 708 (or (typep ,g ,typform) (eq (type-of ,g) 'READ-LABEL)))))) 709 (if (and (consp type) (eq (car type) 'VALUES)) 710 ;; The VALUES type specifier is ill-defined in ANSI CL. 711 ;; 712 ;; There are two possibilities to define a VALUES type specifier in a 713 ;; sane way: 714 ;; - (EXACT-VALUES type1 ... [&optional ...]) describes the exact shape 715 ;; of the values list, as received by MULTIPLE-VALUE-LIST. 716 ;; For example, (EXACT-VALUES SYMBOL) is matched by (values 'a) but not 717 ;; by (values 'a 'b) or (values). 718 ;; - (ASSIGNABLE-VALUES type1 ... [&optional ...]) describes the values 719 ;; as received by a set of variables through MULTIPLE-VALUE-BIND or 720 ;; MULTIPLE-VALUE-SETQ. For example, (ASSIGNABLE-VALUES SYMBOL) is 721 ;; defined by whether 722 ;; (MULTIPLE-VALUE-BIND (var1) values (DECLARE (TYPE SYMBOL var1)) ...) 723 ;; is valid or not; therefore (ASSIGNABLE-VALUES SYMBOL) is matched by 724 ;; (values 'a) and (values 'a 'b) and (values). 725 ;; Note that &OPTIONAL is actually redundant here: 726 ;; (ASSIGNABLE-VALUES type1 ... &optional otype1 ...) 727 ;; is equivalent to 728 ;; (ASSIGNABLE-VALUES type1 ... (OR NULL otype1) ...) 729 ;; HyperSpec/Body/typspe_values.html indicates that VALUES means 730 ;; EXACT-VALUES; however, HyperSpec/Body/speope_the.html indicates that 731 ;; VALUES means ASSIGNABLE-VALUES. 732 ;; 733 ;; SBCL interprets the VALUES type specifier to mean EXACT-VALUES when 734 ;; it contains &OPTIONAL or &REST, but ASSIGNABLE-VALUES when it has 735 ;; only a tuple of type specifiers. This is utter nonsense, in particular 736 ;; because it makes (VALUES type1 ... typek &OPTIONAL) 737 ;; different from (VALUES type1 ... typek). 738 ;; 739 ;; Here we use the ASSIGNABLE-VALUES interpretation. 740 ;; In SUBTYPEP we just punt and don't assume any interpretation. 741 (let ((vals values) (types (cdr type))) 742 ;; required: 743 (loop 744 (when (or (atom types) (atom vals)) (return-from %the t)) 745 (when (memq (car types) lambda-list-keywords) (return)) 746 (unless (near-typep (pop vals) (pop types)) 747 (return-from %the nil))) 748 ;; &optional: 749 (when (and (consp types) (eq (car types) '&optional)) 750 (setq types (cdr types)) 751 (loop 752 (when (or (atom types) (atom vals)) (return-from %the t)) 753 (when (memq (car types) lambda-list-keywords) (return)) 754 (unless (near-typep (pop vals) (pop types)) 755 (return-from %the nil)))) 756 ;; &rest &key: 757 (case (car types) 758 (&rest 759 (setq types (cdr types)) 760 (when (atom types) (typespec-error 'the type)) 761 (unless (near-typep (pop vals) (pop types)) 762 (return-from %the nil))) 763 (&key) 764 (t (typespec-error 'the type))) 765 (if (eq (car types) '&key) 766 (progn 767 (setq types (cdr types)) 768 (when (oddp (length vals)) (return-from %the nil)) 769 (let ((keywords nil)) 770 (loop 771 (when (or (atom types) (atom vals)) (return-from %the t)) 772 (when (memq (car types) lambda-list-keywords) (return)) 773 (let ((item (pop types))) 774 (unless (and (listp item) (eql (length item) 2) 775 (symbolp (first item))) 776 (typespec-error 'the type)) 777 (let ((kw (symbol-to-keyword (first item)))) 778 (unless (near-typep (getf vals kw) (second item)) 779 (return-from %the nil)) 780 (push kw keywords)))) 781 (if (and (consp types) (eq (car types) '&allow-other-keys)) 782 (setq types (cdr types)) 783 (unless (getf vals ':allow-other-keys) 784 (do ((L vals (cddr L))) 785 ((atom L)) 786 (unless (memq (car L) keywords) 787 (return-from %the nil))))))) 788 (when (consp types) (typespec-error 'the type))) 789 t) 790 (near-typep (if (consp values) (car values) nil) type)))) 791 792;;; =========================================================================== 793 794;; SUBTYPEP 795(load "subtypep") 796 797 798;; Returns the number of bytes that are needed to represent #\Null in a 799;; given encoding. 800(defun encoding-zeroes (encoding) 801 #+UNICODE 802 ;; this should use min_bytes_per_char for cache, not the hash table 803 (let ((name (ext:encoding-charset encoding)) 804 (table #.(make-hash-table :key-type '(or string symbol) :value-type 'fixnum 805 :test 'stablehash-equal :warn-if-needs-rehash-after-gc t 806 :initial-contents '(("UTF-7" . 1)))) 807 (tester #.(make-string 2 :initial-element (code-char 0)))) 808 (or (gethash name table) 809 (setf (gethash name table) 810 (- (length (ext:convert-string-to-bytes tester encoding)) 811 (length (ext:convert-string-to-bytes tester encoding 812 :end 1)))))) 813 #-UNICODE 1) 814 815;; Determines two values low,high such that 816;; (subtypep type `(INTEGER ,low ,high)) 817;; holds and low is as large as possible and high is as small as possible. 818;; low = * means -infinity, high = * means infinity. 819;; When (subtypep type 'INTEGER) is false, the values NIL,NIL are returned. 820;; We need this function only for MAKE-ARRAY, UPGRADED-ARRAY-ELEMENT-TYPE and 821;; OPEN and can therefore w.l.o.g. replace 822;; type with `(OR ,type (MEMBER 0)) 823#| ;; The original implementation calls canonicalize-type and then applies 824 ;; a particular SUBTYPE variant: 825 (defun subtype-integer (type) 826 (macrolet ((yes () '(return-from subtype-integer (values low high))) 827 (no () '(return-from subtype-integer nil)) 828 (unknown () '(return-from subtype-integer nil))) 829 (setq type (canonicalize-type type)) 830 (if (consp type) 831 (case (first type) 832 (MEMBER ; (MEMBER &rest objects) 833 ;; All elements must be of type INTEGER. 834 (let ((low 0) (high 0)) ; wlog! 835 (dolist (x (rest type) (yes)) 836 (unless (typep x 'INTEGER) (return (no))) 837 (setq low (min low x) high (max high x))))) 838 (OR ; (OR type*) 839 ;; Every type must be subtype of INTEGER. 840 (let ((low 0) (high 0)) ; wlog! 841 (dolist (type1 (rest type) (yes)) 842 (multiple-value-bind (low1 high1) (subtype-integer type1) 843 (unless low1 (return (no))) 844 (setq low (if (or (eq low '*) (eq low1 '*)) '* (min low low1)) 845 high (if (or (eq high '*) (eq high1 '*)) 846 '* (max high high1))))))) 847 (AND ; (AND type*) 848 ;; If one of the types is subtype of INTEGER, then yes, 849 ;; otherwise unknown. 850 (let ((low nil) (high nil)) 851 (dolist (type1 (rest type)) 852 (multiple-value-bind (low1 high1) (subtype-integer type1) 853 (when low1 854 (if low 855 (setq low (if (eq low '*) low1 (if (eq low1 '*) low (max low low1))) 856 high (if (eq high '*) high1 (if (eq high1 '*) high (min high high1)))) 857 (setq low low1 high high1))))) 858 (if low 859 (progn 860 (when (and (numberp low) (numberp high) (not (<= low high))) 861 (setq low 0 high 0) ; type equivalent to NIL) 862 (yes)) 863 (unknown))))) 864 (setq type (list type))) 865 (if (eq (first type) 'INTEGER) 866 (let ((low (if (rest type) (second type) '*)) 867 (high (if (cddr type) (third type) '*))) 868 (when (consp low) 869 (setq low (first low)) 870 (when (numberp low) (incf low))) 871 (when (consp high) 872 (setq high (first high)) 873 (when (numberp high) (decf high))) 874 (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer? 875 (setq low 0 high 0)) 876 (yes)) 877 (if (and (eq (first type) 'INTERVALS) (eq (second type) 'INTEGER)) 878 (let ((low (third type)) 879 (high (car (last type)))) 880 (when (consp low) 881 (setq low (first low)) 882 (when (numberp low) (incf low))) 883 (when (consp high) 884 (setq high (first high)) 885 (when (numberp high) (decf high))) 886 (yes)) 887 (unknown))))) 888|# ;; This implementation inlines the (tail-recursive) canonicalize-type 889 ;; function. Its advantage is that it doesn't cons as much. 890 ;; (For example, (subtype-integer '(UNSIGNED-BYTE 8)) doesn't cons.) 891(defun subtype-integer (type) 892 (macrolet ((yes () '(return-from subtype-integer (values low high))) 893 (no () '(return-from subtype-integer nil)) 894 (unknown () '(return-from subtype-integer nil))) 895 (setq type (expand-deftype type)) 896 (cond ((symbolp type) 897 (case type 898 (BIT (let ((low 0) (high 1)) (yes))) 899 (FIXNUM 900 (let ((low '#,most-negative-fixnum) 901 (high '#,most-positive-fixnum)) 902 (yes))) 903 ((INTEGER BIGNUM SIGNED-BYTE) 904 (let ((low '*) (high '*)) (yes))) 905 (UNSIGNED-BYTE 906 (let ((low 0) (high '*)) (yes))) 907 ((NIL) 908 (let ((low 0) (high 0)) (yes))) ; wlog! 909 (t (no)))) 910 ((and (consp type) (symbolp (first type))) 911 (unless (and (list-length type) (null (cdr (last type)))) 912 (typespec-error 'subtypep type)) 913 (case (first type) 914 (MEMBER ; (MEMBER &rest objects) 915 ;; All elements must be of type INTEGER. 916 (let ((low 0) (high 0)) ; wlog! 917 (dolist (x (rest type) (yes)) 918 (unless (typep x 'INTEGER) (return (no))) 919 (setq low (min low x) high (max high x))))) 920 (EQL ; (EQL object) 921 (let ((x (second type))) 922 (if (typep x 'INTEGER) 923 (let ((low (min 0 x)) (high (max 0 x))) (yes)) 924 (no)))) 925 (OR ; (OR type*) 926 ;; Every type must be subtype of INTEGER. 927 (let ((low 0) (high 0)) ; wlog! 928 (dolist (type1 (rest type) (yes)) 929 (multiple-value-bind (low1 high1) (subtype-integer type1) 930 (unless low1 (return (no))) 931 (setq low (if (or (eq low '*) (eq low1 '*)) 932 '* (min low low1)) 933 high (if (or (eq high '*) (eq high1 '*)) 934 '* (max high high1))))))) 935 (AND ; (AND type*) 936 ;; If one of the types is subtype of INTEGER, then yes, 937 ;; otherwise unknown. 938 (let ((low nil) (high nil)) 939 (dolist (type1 (rest type)) 940 (multiple-value-bind (low1 high1) (subtype-integer type1) 941 (when low1 942 (if low 943 (setq low (if (eq low '*) low1 944 (if (eq low1 '*) low 945 (max low low1))) 946 high (if (eq high '*) high1 947 (if (eq high1 '*) high 948 (min high high1)))) 949 (setq low low1 950 high high1))))) 951 (if low 952 (progn 953 (when (and (numberp low) (numberp high) 954 (not (<= low high))) 955 (setq low 0 high 0)) ; type equivalent to NIL 956 (yes)) 957 (unknown)))) 958 (INTEGER 959 (let ((low (if (rest type) (second type) '*)) 960 (high (if (cddr type) (third type) '*))) 961 (when (consp low) 962 (setq low (first low)) 963 (when (numberp low) (incf low))) 964 (when (consp high) 965 (setq high (first high)) 966 (when (numberp high) (decf high))) 967 (when (and (numberp low) (numberp high) (not (<= low high))) 968 (setq low 0 high 0)) ; type equivalent to NIL 969 (yes))) 970 (INTERVALS 971 (if (eq (second type) 'INTEGER) 972 (let ((low (third type)) 973 (high (car (last type)))) 974 (when (consp low) 975 (setq low (first low)) 976 (when (numberp low) (incf low))) 977 (when (consp high) 978 (setq high (first high)) 979 (when (numberp high) (decf high))) 980 (yes)) 981 (unknown))) 982 (MOD ; (MOD n) 983 (let ((n (second type))) 984 (unless (and (integerp n) (>= n 0)) 985 (typespec-error 'subtypep type)) 986 (if (eql n 0) 987 (no) 988 (let ((low 0) (high (1- n))) 989 (yes))))) 990 (SIGNED-BYTE ; (SIGNED-BYTE &optional s) 991 (let ((s (if (cdr type) (second type) '*))) 992 (if (eq s '*) 993 (let ((low '*) (high '*)) (yes)) 994 (progn 995 (unless (and (integerp s) (plusp s)) 996 (typespec-error 'subtypep type)) 997 (let ((n (ash 1 (1- s)))) ; (ash 1 *) == (expt 2 *) 998 (let ((low (- n)) (high (1- n))) 999 (yes))))))) 1000 (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s) 1001 (let ((s (if (cdr type) (second type) '*))) 1002 (if (eq s '*) 1003 (let ((low 0) (high '*)) (yes)) 1004 (progn 1005 (unless (and (integerp s) (>= s 0)) 1006 (typespec-error 'subtypep type)) 1007 (let ((n (ash 1 s))) ; (ash 1 *) == (expt 2 *) 1008 (let ((low 0) (high (1- n))) 1009 (yes))))))) 1010 (t (no)))) 1011 ((clos::defined-class-p type) 1012 (if (and (clos::built-in-class-p type) 1013 (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type)) 1014 (return-from subtype-integer 1015 (subtype-integer (clos:class-name type))) 1016 (no))) 1017 ((clos::eql-specializer-p type) 1018 (let ((x (clos::eql-specializer-singleton type))) 1019 (if (typep x 'INTEGER) 1020 (let ((low (min 0 x)) (high (max 0 x))) (yes)) 1021 (no)))) 1022 ((encodingp type) (no)) 1023 (t (typespec-error 'subtypep type))))) 1024 1025#| TODO: Fix subtype-integer such that this works. 1026Henry Baker: 1027 (defun type-null (x) 1028 (values (and (eq 'bit (upgraded-array-element-type `(or bit ,x))) 1029 (not (typep 0 x)) 1030 (not (typep 1 x))) 1031 t)) 1032 (type-null '(and symbol number)) 1033 (type-null '(and integer symbol)) 1034 (type-null '(and integer character)) 1035|# 1036 1037;; Determines a sequence kind (an atom, as defined in defseq.lisp: one of 1038;; LIST - stands for LIST 1039;; VECTOR - stands for (VECTOR T) 1040;; STRING - stands for (VECTOR CHARACTER) 1041;; 1, 2, 4, 8, 16, 32 - stands for (VECTOR (UNSIGNED-BYTE n)) 1042;; 0 - stands for (VECTOR NIL)) 1043;; that indicates the sequence type meant by the given type. Other possible 1044;; return values are 1045;; SEQUENCE - denoting a type whose intersection with (OR LIST VECTOR) is not 1046;; subtype of LIST or VECTOR, or 1047;; NIL - indicating a type whose intersection with (OR LIST VECTOR) is empty. 1048;; When the type is (OR (VECTOR eltype1) ... (VECTOR eltypeN)), the chosen 1049;; element type is the smallest element type that contains all of eltype1 ... 1050;; eltypeN. 1051;; 1052;; User-defined sequence types are not supported here. 1053;; 1054;; This implementation inlines the (tail-recursive) canonicalize-type 1055;; function. Its advantage is that it doesn't cons as much. Also it employs 1056;; some heuristics and does not have the full power of SUBTYPEP. 1057(defun subtype-sequence (type) 1058 (setq type (expand-deftype type)) 1059 (cond ((symbolp type) 1060 (case type 1061 ((LIST CONS NULL) 'LIST) 1062 ((NIL) 'NIL) 1063 ((BIT-VECTOR SIMPLE-BIT-VECTOR) '1) 1064 ((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'STRING) 1065 ((VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY) 'VECTOR) 1066 ((SEQUENCE) 'SEQUENCE) 1067 (t 'NIL))) 1068 ((and (consp type) (symbolp (first type))) 1069 (unless (and (list-length type) (null (cdr (last type)))) 1070 (typespec-error 'subtypep type)) 1071 (case (first type) 1072 (MEMBER ; (MEMBER &rest objects) 1073 (let ((kind 'NIL)) 1074 (dolist (x (rest type)) 1075 (setq kind (sequence-type-union kind (type-of-sequence x)))) 1076 kind)) 1077 (EQL ; (EQL object) 1078 (unless (eql (length type) 2) 1079 (typespec-error 'subtypep type)) 1080 (type-of-sequence (second type))) 1081 (OR ; (OR type*) 1082 (let ((kind 'NIL)) 1083 (dolist (x (rest type)) 1084 (setq kind (sequence-type-union kind (subtype-sequence x)))) 1085 kind)) 1086 (AND ; (AND type*) 1087 (let ((kind 'SEQUENCE)) 1088 (dolist (x (rest type)) 1089 (setq kind (sequence-type-intersection kind (subtype-sequence x)))) 1090 kind)) 1091 ((SIMPLE-BIT-VECTOR BIT-VECTOR) ; (SIMPLE-BIT-VECTOR &optional size) 1092 (when (cddr type) 1093 (typespec-error 'subtypep type)) 1094 '1) 1095 ((SIMPLE-STRING STRING SIMPLE-BASE-STRING BASE-STRING) ; (SIMPLE-STRING &optional size) 1096 (when (cddr type) 1097 (typespec-error 'subtypep type)) 1098 'STRING) 1099 (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size) 1100 (when (cddr type) 1101 (typespec-error 'subtypep type)) 1102 'VECTOR) 1103 ((VECTOR ARRAY SIMPLE-ARRAY) ; (VECTOR &optional el-type size), (ARRAY &optional el-type dimensions) 1104 (when (cdddr type) 1105 (typespec-error 'subtypep type)) 1106 (let ((el-type (if (cdr type) (second type) '*))) 1107 (if (eq el-type '*) 1108 'VECTOR 1109 (let ((eltype (upgraded-array-element-type el-type))) 1110 (cond ((eq eltype 'T) 'VECTOR) 1111 ((eq eltype 'CHARACTER) 'STRING) 1112 ((eq eltype 'BIT) '1) 1113 ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype)) 1114 ((eq eltype 'NIL) '0) 1115 (t (error (TEXT "~S is not up-to-date with ~S for element type ~S") 1116 'subtypep-sequence 'upgraded-array-element-type eltype))))))) 1117 ((CONS) ; (CONS &optional cartype cdrtype) 1118 (when (cdddr type) 1119 (typespec-error 'subtypep type)) 1120 'LIST) 1121 (t 'NIL))) 1122 ((clos::defined-class-p type) 1123 (if (and (clos::built-in-class-p type) 1124 (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type)) 1125 (subtype-sequence (clos:class-name type)) 1126 'NIL)) 1127 ((clos::eql-specializer-p type) 1128 (type-of-sequence (clos::eql-specializer-singleton type))) 1129 (t 'NIL))) 1130(defun type-of-sequence (x) 1131 (cond ((listp x) 'LIST) 1132 ((vectorp x) 1133 (let ((eltype (array-element-type x))) 1134 (cond ((eq eltype 'T) 'VECTOR) 1135 ((eq eltype 'CHARACTER) 'STRING) 1136 ((eq eltype 'BIT) '1) 1137 ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype)) 1138 ((eq eltype 'NIL) '0) 1139 (t (error (TEXT "~S is not up-to-date with ~S for element type ~S") 1140 'type-of-sequence 'array-element-type eltype))))) 1141 (t 'NIL))) 1142(defun sequence-type-union (t1 t2) 1143 (cond ; Simple general rules. 1144 ((eql t1 t2) t1) 1145 ((eq t1 'NIL) t2) 1146 ((eq t2 'NIL) t1) 1147 ; Now the union of two different types. 1148 ((or (eq t1 'SEQUENCE) (eq t2 'SEQUENCE)) 'SEQUENCE) 1149 ((or (eq t1 'LIST) (eq t2 'LIST)) 1150 ; union of LIST and a vector type 1151 'SEQUENCE) 1152 ((or (eq t1 'VECTOR) (eq t2 'VECTOR)) 'VECTOR) 1153 ((eql t1 0) t2) 1154 ((eql t2 0) t1) 1155 ((or (eq t1 'STRING) (eq t2 'STRING)) 1156 ; union of STRING and an integer-vector type 1157 'VECTOR) 1158 (t (max t1 t2)))) 1159(defun sequence-type-intersection (t1 t2) 1160 (cond ; Simple general rules. 1161 ((eql t1 t2) t1) 1162 ((or (eq t1 'NIL) (eq t2 'NIL)) 'NIL) 1163 ; Now the intersection of two different types. 1164 ((eq t1 'SEQUENCE) t2) 1165 ((eq t2 'SEQUENCE) t1) 1166 ((or (eq t1 'LIST) (eq t2 'LIST)) 1167 ; intersection of LIST and a vector type 1168 'NIL) 1169 ((eq t1 'VECTOR) t2) 1170 ((eq t2 'VECTOR) t1) 1171 ((or (eql t1 0) (eql t2 0)) '0) 1172 ((or (eq t1 'STRING) (eq t2 'STRING)) 1173 ; intersection of STRING and an integer-vector type 1174 '0) 1175 (t (min t1 t2)))) 1176 1177;; ============================================================================ 1178 1179(defun type-expand (typespec &optional once-p) 1180 (multiple-value-bind (expanded user-defined-p) 1181 (expand-deftype typespec once-p) 1182 (if user-defined-p (values expanded user-defined-p) 1183 (cond ((symbolp typespec) 1184 (cond ((or (get typespec 'TYPE-SYMBOL) (get typespec 'TYPE-LIST)) 1185 (values typespec nil)) 1186 ((or (get typespec 'DEFSTRUCT-DESCRIPTION) 1187 (clos-class typespec)) 1188 (values typespec nil)) 1189 (t (typespec-error 'type-expand typespec)))) 1190 ((and (consp typespec) (symbolp (first typespec))) 1191 (case (first typespec) 1192 ((SATISFIES MEMBER EQL NOT AND OR) (values typespec nil)) 1193 (t (cond ((get (first typespec) 'TYPE-LIST) 1194 (values typespec nil)) 1195 (t (typespec-error 'type-expand typespec)))))) 1196 ((clos::defined-class-p typespec) (values typespec nil)) 1197 (t (typespec-error 'type-expand typespec)))))) 1198 1199;; ============================================================================ 1200 1201(unless (clos::funcallable-instance-p #'clos::class-name) 1202 (fmakunbound 'clos::class-name)) 1203 1204 1205(keywordp :junk) 1206 T 1207 1208(keywordp ::junk) 1209 T 1210 1211(symbol-name ::junk) 1212 "JUNK" 1213 1214(symbol-name :#junk) 1215 "#JUNK" 1216 1217(symbol-name :#.junk) 1218 "#.JUNK" 1219