predlib.lsp 49.4 KB
Newer Older
1 2
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
jjgarcia's avatar
jjgarcia committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

;;;;                              predicate routines

(in-package "SYSTEM")

17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
(defun constantly-t (&rest foo)
  (declare (ignore foo))
  t)

(defun constantly-nil (&rest foo)
  (declare (ignore foo))
  nil)

(defun constantly (n)
  "Args: (n)
Builds a new function which accepts any number of arguments but always outputs N."
  (case n
    ((nil) #'constantly-nil)
    ((t) #'constantly-t)
    (t #'(lambda (&rest x) (declare (ignore x)) n))))

33
(defparameter *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
34

35
(defparameter *upgraded-array-element-type-cache* (si:make-vector t 128 nil nil nil 0))
36

37
(defun subtypep-clear-cache ()
38 39
  (ext:fill-array-with-elt *subtypep-cache* nil 0 nil)
  (ext:fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil))
40

41 42
(defun create-type-name (name)
  (when (member name *alien-declarations*)
43
    (error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name)))
44 45 46 47 48 49

(defun do-deftype (name form function)
  (unless (symbolp name)
    (error "~s is not a valid type specifier" name))
  (create-type-name name)
  (put-sysprop name 'DEFTYPE-FORM form)
50 51
  (put-sysprop name 'DEFTYPE-DEFINITION
               (if (functionp function) function (constantly function)))
52
  (subtypep-clear-cache)
53 54
  name)

jjgarcia's avatar
jjgarcia committed
55
;;; DEFTYPE macro.
56
(defmacro deftype (name lambda-list &rest body &environment env)
57 58 59 60 61 62 63 64 65 66 67 68
  "Syntax: (deftype name lambda-list {decl | doc}* {form}*)
Defines a new type-specifier abbreviation in terms of an 'expansion' function
	(lambda lambda-list1 {DECL}* {FORM}*)
where LAMBDA-LIST1 is identical to LAMBDA-LIST except that all optional
parameters with no default value specified in LAMBDA-LIST defaults to the
symbol '*', but not to NIL.  When the type system of ECL encounters a type
specifier (NAME arg1 ... argn), it calls the expansion function with the
arguments ARG1 ... ARGn, and uses the returned value instead of the original
type specifier.  When the symbol NAME is used as a type specifier, the
expansion function is called with no argument.
The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved
by (documentation 'NAME 'type)."
69 70
  (multiple-value-bind (body doc)
      (remove-documentation body)
71
    (setf lambda-list (copy-list lambda-list))
72 73 74 75 76 77 78
    (dolist (x '(&optional &key))
      (do ((l (rest (member x lambda-list)) (rest l)))
	  ((null l))
	(let ((variable (first l)))
	  (when (and (symbolp variable)
		     (not (member variable lambda-list-keywords)))
	    (setf (first l) `(,variable '*))))))
79 80 81
    (let ((function `#'(LAMBDA-BLOCK ,name ,lambda-list ,@body)))
      (when (and (null lambda-list) (consp body) (null (rest body)))
        (let ((form (first body)))
82
          (when (constantp form env)
83 84 85 86 87
            (setf function form))))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         ,@(si::expand-set-documentation name 'type doc)
         (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body)
                     ,function)))))
jjgarcia's avatar
jjgarcia committed
88 89 90


;;; Some DEFTYPE definitions.
91 92
(deftype boolean ()
  "A BOOLEAN is an object which is either NIL or T."
93
  '(member nil t))
94

95
(deftype index ()
96
  '(INTEGER 0 #.array-dimension-limit))
97

jjgarcia's avatar
jjgarcia committed
98
(deftype fixnum ()
99 100 101
  "A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM (= - 2^29 in ECL) and
MOST-POSITIVE-FIXNUM (= 2^29 - 1 in ECL) inclusive.  Other integers are
bignums."
102
  '(INTEGER #.most-negative-fixnum #.most-positive-fixnum))
103 104
(deftype bignum ()
  '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
105

106 107 108 109 110 111 112 113 114 115
(deftype ext::byte8 () '(INTEGER 0 255))
(deftype ext::integer8 () '(INTEGER -128 127))
(deftype ext::byte16 () '(INTEGER 0 #xFFFF))
(deftype ext::integer16 () '(INTEGER #x-8000 #x7FFF))
(deftype ext::byte32 () '(INTEGER 0 #xFFFFFFFF))
(deftype ext::integer32 () '(INTEGER #x-80000000 #x7FFFFFFF))
(deftype ext::byte64 () '(INTEGER 0 #xFFFFFFFFFFFFFFFF))
(deftype ext::integer64 () '(INTEGER #x-8000000000000000 #x7FFFFFFFFFFFFFFF))
(deftype ext::cl-fixnum () '(SIGNED-BYTE #.CL-FIXNUM-BITS))
(deftype ext::cl-index () '(UNSIGNED-BYTE #.CL-FIXNUM-BITS))
116

117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
(deftype real (&optional (start '* start-p) (end '*))
  (if start-p
      (let (rat-start
	    real-start
	    rat-end
	    real-end)
	(cond ((consp start)
	       (setf start (first start)
		     rat-start (list (rational start))
		     real-start (list (float start))))
	      ((numberp start)
	       (setf rat-start (rational start)
		     real-start (float start)))
	      (t
	       (setf rat-start start
		     real-start start)))
	(cond ((consp end)
	       (setf end (first end)
		     rat-end (list (rational end))
		     real-end (list (float end))))
	      ((numberp end)
	       (setf rat-end (rational end)
		     real-end (float end)))
	      (t
	       (setf rat-end end
		     real-end end)))
	`(OR (RATIONAL ,rat-start ,rat-end) (FLOAT ,real-start ,real-end)))
      '(OR RATIONAL FLOAT)))
145

146
#-short-float
147
(deftype short-float (&rest args)
148
  (if args
149 150
      `(single-float ,@args)
      'single-float))
151

152
#-long-float
153
(deftype long-float (&rest args)
154
  (if args
155 156
      `(double-float ,@args)
      'double-float))
157

158 159 160 161
(deftype bit ()
  "A BIT is either integer 0 or 1."
  '(INTEGER 0 1))

jjgarcia's avatar
jjgarcia committed
162 163
(deftype mod (n)
  `(INTEGER 0 ,(1- n)))
164

jjgarcia's avatar
jjgarcia committed
165
(deftype signed-byte (&optional s)
166 167
  "As a type specifier, (SIGNED-BYTE n) specifies those integers that can be
represented with N bits in 2's complement representation."
jjgarcia's avatar
jjgarcia committed
168 169 170
  (if (or (null s) (eq s '*))
      '(INTEGER * *)
      `(INTEGER ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
171

jjgarcia's avatar
jjgarcia committed
172
(deftype unsigned-byte (&optional s)
173 174
  "As a type specifier, (UNSIGNED-BYTE n) specifies non-negative integers that
can be represented with N bits."
jjgarcia's avatar
jjgarcia committed
175 176 177 178
  (if (or (null s) (eq s '*))
      '(INTEGER 0 *)
      `(INTEGER 0 ,(1- (expt 2 s)))))

179 180 181 182 183 184 185 186
(deftype null ()
  "The type to which only NIL belongs."
  '(MEMBER NIL))

(deftype sequence ()
  "A sequence is either a list or a vector."
  '(OR CONS NULL (ARRAY * (*))))

187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
(deftype list ()
  "As a type specifier, LIST is used to specify the type consisting of NIL and
cons objects.  In our ordinary life with Lisp, however, a list is either NIL
or a cons whose cdr is a list, and is notated by its elements surrounded with
parentheses.
The backquote macro is sometimes useful to construct a complicated list
structure.  When evaluating `(...)
	,form embeds the value of FORM,
	,@form and ,.form embed all elements of the list value of FORM,
	and other things embed itself
into the structure at their position.  For example,
	`(a b ,c d e) expands to (list* 'a 'b c '(d e))
	`(a b ,@c d e) expands to (list* 'a 'b (append c '(d e)))
	`(a b ,.c d e) expands to (list* 'a 'b (nconc c '(d e)))"
  '(OR CONS NULL))

203 204 205
(deftype proper-list ()
  '(OR (CONS T PROPER-LIST) NULL))

206 207 208
(deftype property-list ()
  '(OR (CONS T (CONS T PROPERTY-LIST)) NULL))

209 210 211
(deftype atom ()
  "An ATOM is an object that is not a CONS."
  '(NOT CONS))
jjgarcia's avatar
jjgarcia committed
212 213 214
;(deftype null () '(MEMBER NIL))

(deftype vector (&optional (element-type '*) (size '*))
215 216 217 218 219
  "A vector is a one-dimensional array.  Strings and bit-vectors are kinds of
vectors.  Other vectors are called general vectors and are notated as
	#(elem ... elem)
Some vectors may be displaced to another array, may have a fill-pointer, or
may be adjustable.  Other vectors are called simple-vectors."
jjgarcia's avatar
jjgarcia committed
220
  `(array ,element-type (,size)))
221

222
(deftype extended-char ()
223
  "A character which is not of type BASE-CHAR."
224 225
  '(and character (not base-char)))

jjgarcia's avatar
jjgarcia committed
226
(deftype string (&optional size)
227 228 229 230
  "A string is a vector of characters.  A string is notated by surrounding the
characters with double quotes.  Some strings may be displaced to another
string, may have a fill-pointer, or may be adjustable.  Other strings are
called simple-strings."
231
  #-unicode
232 233 234
  (if (eq size '*)
      '(array character (*))
      `(array character (,size)))
235
  #+unicode
236 237
  (if (eq size '*)
      '(or (array base-char (*)) (array character (*)))
238
      `(or (array base-char (,size))
239
	   (array character (,size)))))
240

241
(deftype base-string (&optional (size '*))
242
  "A string which is made of BASE-CHAR."
243
  (if (eq size '*) '(array base-char (*)) `(array base-char (,size))))
244

245
(deftype extended-string (&optional (size '*))
246 247 248 249
  "A string which is nt a base string"
  #-unicode
  NIL
  #+unicode
250
  (if (eq size '*) '(array character (*)) `(array character (,size))))
251

252
(deftype bit-vector (&optional (size '*))
253 254 255 256 257
  "A bit-vector is a vector of bits.  A bit-vector is notated by '#*' followed
by its elements (0 or 1).  Bit-vectors may be displaced to another array, may
have a fill-pointer, or may be adjustable.  Other bit-vectors are called
simple-bit-vectors.  Only simple-bit-vectors can be input in the above format
using '#*'."
258
  (if (eq size '*) '(array bit (*)) `(array bit (,size))))
jjgarcia's avatar
jjgarcia committed
259

260
(deftype simple-vector (&optional (size '*))
261 262
  "A simple-vector is a vector that is not displaced to another array, has no
fill-pointer, and is not adjustable."
263
  (if (eq size '*) '(simple-array t (*)) `(simple-array t (,size))))
264

jjgarcia's avatar
jjgarcia committed
265
(deftype simple-string (&optional size)
266 267
  "A simple-string is a string that is not displaced to another array, has no
fill-pointer, and is not adjustable."
268 269 270 271 272 273 274 275 276
  #-unicode
  (if size
    `(simple-array character (,size))
    '(simple-array character (*)))
  #+unicode
  (if size
      `(or (simple-array base-char (,size))
	   (simple-array character (,size)))
      '(or (simple-array base-char (*)) (simple-array character (*)))))
277

jjgarcia's avatar
jjgarcia committed
278
(deftype simple-base-string (&optional size)
279
  "A base-string which cannot be adjusted nor displaced."
280
  (if size `(simple-array base-char (,size)) '(simple-array base-char (*))))
281

jjgarcia's avatar
jjgarcia committed
282
(deftype simple-bit-vector (&optional size)
283 284
  "A bit-vector that is not displaced to another array, has no fill-pointer,
and is not adjustable."
jjgarcia's avatar
jjgarcia committed
285 286
  (if size `(simple-array bit (,size)) '(simple-array bit (*))))

287 288 289
(deftype array-index ()
  '(integer 0 #.(1- array-dimension-limit)))

290 291 292 293
;;************************************************************
;;			TYPEP
;;************************************************************

jjgarcia's avatar
jjgarcia committed
294 295 296 297
(defun simple-array-p (x)
  (and (arrayp x)
       (not (adjustable-array-p x))
       (not (array-has-fill-pointer-p x))
298
       (not (array-displacement x))))
jjgarcia's avatar
jjgarcia committed
299

300 301 302 303 304 305
(defun complex-array-p (x)
  (and (arrayp x)
       (or (adjustable-array-p x)
	   (array-has-fill-pointer-p x)
	   (array-displacement x))))

306 307 308 309 310 311 312 313 314 315 316 317
(eval-when (:execute :load-toplevel :compile-toplevel)
  (defconstant +known-typep-predicates+
    '((ARRAY . ARRAYP)
      (ATOM . ATOM)
      #-unicode
      (EXTENDED-CHAR . CONSTANTLY-NIL)
      (BASE-CHAR . BASE-CHAR-P)
      (BASE-STRING . BASE-STRING-P)
      (BIT-VECTOR . BIT-VECTOR-P)
      (CHARACTER . CHARACTERP)
      (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
      (COMPLEX . COMPLEXP)
318
      (COMPLEX-ARRAY . COMPLEX-ARRAY-P)
319 320
      (CONS . CONSP)
      (FLOAT . FLOATP)
321
      (SI:FOREIGN-DATA . SI:FOREIGN-DATA-P)
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344
      (FUNCTION . FUNCTIONP)
      (HASH-TABLE . HASH-TABLE-P)
      (INTEGER . INTEGERP)
      (FIXNUM . SI::FIXNUMP)
      (KEYWORD . KEYWORDP)
      (LIST . LISTP)
      (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
      (NIL . CONSTANTLY-NIL)
      (NULL . NULL)
      (NUMBER . NUMBERP)
      (PACKAGE . PACKAGEP)
      (RANDOM-STATE . RANDOM-STATE-P)
      (RATIONAL . RATIONALP)
      (PATHNAME . PATHNAMEP)
      (READTABLE . READTABLEP)
      (REAL . REALP)
      (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
      (SIMPLE-STRING . SIMPLE-STRING-P)
      (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
      (STREAM . STREAMP)
      (STRING . STRINGP)
      (STRUCTURE . SYS:STRUCTUREP)
      (SYMBOL . SYMBOLP)
345
      #+sse2 (EXT:SSE-PACK . EXT:SSE-PACK-P)
346 347 348
      #+sse2 (EXT:INT-SSE-PACK . EXT:SSE-PACK-P)
      #+sse2 (EXT:FLOAT-SSE-PACK . EXT:SSE-PACK-P)
      #+sse2 (EXT:DOUBLE-SSE-PACK . EXT:SSE-PACK-P)
349 350 351 352
      (T . CONSTANTLY-T)
      (VECTOR . VECTORP))))

(dolist (l +known-typep-predicates+)
353
  (put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
jjgarcia's avatar
jjgarcia committed
354

355
(defconstant +upgraded-array-element-types+
356 357 358 359 360 361 362
  '#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT:BYTE8 EXT:INTEGER8)
             #+:uint16-t '(EXT:BYTE16 EXT:INTEGER16)
             #+:uint32-t '(EXT:BYTE32 EXT:INTEGER32)
             (when (< 32 cl-fixnum-bits 64) '(EXT::CL-INDEX FIXNUM))
             #+:uint64-t '(EXT:BYTE64 EXT:INTEGER64)
             (when (< 64 cl-fixnum-bits) '(EXT::CL-INDEX FIXNUM))
             '(SINGLE-FLOAT DOUBLE-FLOAT T)))
363

364
(defun upgraded-array-element-type (element-type &optional env)
365
  (declare (ignore env))
366 367 368 369 370
  (let* ((hash (logand 127 (si:hash-eql element-type)))
	 (record (aref *upgraded-array-element-type-cache* hash)))
    (declare (type (integer 0 127) hash))
    (if (and record (eq (car record) element-type))
	(cdr record)
371
	(let ((answer (if (member element-type +upgraded-array-element-types+
372
				  :test #'eq)
373
			  element-type
374 375 376 377 378 379
			  (dolist (v +upgraded-array-element-types+ 'T)
			    (when (subtypep element-type v)
			      (return v))))))
	  (setf (aref *upgraded-array-element-type-cache* hash)
		(cons element-type answer))
	  answer))))
jjgarcia's avatar
jjgarcia committed
380

381
(defun upgraded-complex-part-type (real-type &optional env)
382
  (declare (ignore env))
383 384
  ;; ECL does not have specialized complex types. If we had them, the
  ;; code would look as follows
385
  ;;   (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
386 387 388 389 390 391
  ;; 	   (error "~S is not a valid part type for a complex." real-type))
  ;;     (when (subtypep real-type v)
  ;;       (return v))))
  (unless (subtypep real-type 'REAL)
    (error "~S is not a valid part type for a complex." real-type))
  'REAL)
392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411

(defun in-interval-p (x interval)
  (declare (si::c-local))
  (let* (low high)
    (if (endp interval)
        (setq low '* high '*)
        (if (endp (cdr interval))
            (setq low (car interval) high '*)
            (setq low (car interval) high (second interval))))
    (cond ((eq low '*))
          ((consp low)
           (when (<= x (car low)) (return-from in-interval-p nil)))
          ((when (< x low) (return-from in-interval-p nil))))
    (cond ((eq high '*))
          ((consp high)
           (when (>= x (car high)) (return-from in-interval-p nil)))
          ((when (> x high) (return-from in-interval-p nil))))
    (return-from in-interval-p t)))

(defun error-type-specifier (type)
412
  (declare (si::c-local))
413
  (error "~S is not a valid type specifier." type))
414

415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
(defun match-dimensions (array pat)
  (declare (si::c-local))
  (or (eq pat '*)
      (let ((rank (array-rank array)))
	(cond ((numberp pat) (= rank pat))
	      ((listp pat)
	       (dotimes (i rank (null pat))
		 (unless (and (consp pat)
			      (or (eq (car pat) '*)
				  (eql (array-dimension array i) (car pat))))
		   (return nil))
		 (setq pat (cdr pat))))
	      ((atom pat)
	       (error "~S does not describe array dimensions." pat))))))

430
(defun typep (object type &optional env &aux tp i c)
431 432
  "Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
433
  (declare (ignore env))
jjgarcia's avatar
jjgarcia committed
434
  (cond ((symbolp type)
435
	 (let ((f (get-sysprop type 'TYPE-PREDICATE)))
436 437 438
	   (cond (f (return-from typep (funcall f object)))
		 ((eq (type-of object) type) (return-from typep t))
		 (t (setq tp type i nil)))))
jjgarcia's avatar
jjgarcia committed
439 440 441 442
	((consp type)
	 (setq tp (car type) i (cdr type)))
	#+clos
	((sys:instancep type)
443
	 (return-from typep (si::subclassp (class-of object) type)))
jjgarcia's avatar
jjgarcia committed
444
	(t
445
	 (error-type-specifier type)))
jjgarcia's avatar
jjgarcia committed
446
  (case tp
447
    ((EQL MEMBER) (and (member object i) t))
jjgarcia's avatar
jjgarcia committed
448 449 450 451 452 453 454 455
    (NOT (not (typep object (car i))))
    (OR (dolist (e i)
	  (when (typep object e) (return t))))
    (AND (dolist (e i t)
	   (unless (typep object e) (return nil))))
    (SATISFIES (funcall (car i) object))
    ((T) t)
    ((NIL) nil)
456
    (BIGNUM (and (integerp object) (not (si::fixnump object))))
jjgarcia's avatar
jjgarcia committed
457 458 459 460 461 462 463 464 465 466 467
    (RATIO (eq (type-of object) 'RATIO))
    (STANDARD-CHAR
     (and (characterp object) (standard-char-p object)))
    (INTEGER
     (and (integerp object) (in-interval-p object i)))
    (RATIONAL
     (and (rationalp object) (in-interval-p object i)))
    (FLOAT
     (and (floatp object) (in-interval-p object i)))
    (REAL
     (and (or (rationalp object) (floatp object)) (in-interval-p object i)))
468
    ((SINGLE-FLOAT #-short-float SHORT-FLOAT)
469
     (and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i)))
470
    ((DOUBLE-FLOAT #-long-float LONG-FLOAT)
471
     (and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i)))
472 473 474
    #+long-float
    (LONG-FLOAT
     (and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
jjgarcia's avatar
jjgarcia committed
475 476 477 478 479 480 481 482 483
    (COMPLEX
     (and (complexp object)
          (or (null i)
	      (and (typep (realpart object) (car i))
		   ;;wfs--should only have to check one.
		   ;;Illegal to mix real and imaginary types!
		   (typep (imagpart object) (car i))))
	   ))
    (SEQUENCE (or (listp object) (vectorp object)))
484
    (CONS (and (consp object)
485 486 487 488 489 490
	       (or (endp i)
		   (let ((car-type (first i)))
		     (or (eq car-type '*) (typep (car object) car-type))))
	       (or (endp (cdr i))
		   (let ((cdr-type (second i)))
		     (or (eq cdr-type '*) (typep (cdr object) cdr-type))))))
491
    (BASE-STRING
492 493 494
     (and (base-string-p object)
          (or (null i) (match-dimensions object i))))
    (STRING
495 496
     (and (stringp object)
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
497 498
    (BIT-VECTOR
     (and (bit-vector-p object)
499
          (or (null i) (match-dimensions object i))))
500
    (SIMPLE-BASE-STRING
501 502 503 504
     (and (base-string-p object)
          (simple-string-p object)
	  (or (null i) (match-dimensions object i))))
    (SIMPLE-STRING
505
     (and (simple-string-p object)
506
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
507 508
    (SIMPLE-BIT-VECTOR
     (and (simple-bit-vector-p object)
509
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
510 511
    (SIMPLE-VECTOR
     (and (simple-vector-p object)
512
          (or (null i) (match-dimensions object i))))
513 514 515 516 517 518 519
    (COMPLEX-ARRAY
     (and (complex-array-p object)
          (or (endp i) (eq (car i) '*)
	      ;; (car i) needs expansion
	      (eq (array-element-type object)
		  (upgraded-array-element-type (car i))))
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
520 521 522 523 524
    (SIMPLE-ARRAY
     (and (simple-array-p object)
          (or (endp i) (eq (car i) '*)
	      ;; (car i) needs expansion
	      (eq (array-element-type object)
525
		  (upgraded-array-element-type (car i))))
526
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
527 528 529 530 531 532
    (ARRAY
     (and (arrayp object)
          (or (endp i) (eq (car i) '*)
              ;; Or the element type of object should be EQUAL to (car i).
              ;; Is this too strict?
              (eq (array-element-type object)
533
		  (upgraded-array-element-type (car i))))
534
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
535 536
    (t
     (cond
537 538
           ((get-sysprop tp 'DEFTYPE-DEFINITION)
            (typep object (apply (get-sysprop tp 'DEFTYPE-DEFINITION) i)))
539 540
	   ((consp i)
	    (error-type-specifier type))
jjgarcia's avatar
jjgarcia committed
541 542 543
           #+clos
	   ((setq c (find-class type nil))
	    ;; Follow the inheritance chain
544
	    (si::subclassp (class-of object) c))
jjgarcia's avatar
jjgarcia committed
545
	   #-clos
546
	   ((get-sysprop tp 'IS-A-STRUCTURE)
jjgarcia's avatar
jjgarcia committed
547 548 549
            (when (sys:structurep object)
	      ;; Follow the chain of structure-include.
	      (do ((stp (sys:structure-name object)
550
			(get-sysprop stp 'STRUCTURE-INCLUDE)))
jjgarcia's avatar
jjgarcia committed
551
		  ((eq tp stp) t)
552
		(when (null (get-sysprop stp 'STRUCTURE-INCLUDE))
jjgarcia's avatar
jjgarcia committed
553
		  (return nil)))))
554 555
	   (t
	    (error-type-specifier type))))))
jjgarcia's avatar
jjgarcia committed
556 557

#+clos
558
(defun subclassp (low high)
559
  (or (eq low high)
560 561
      (member high (sys:instance-ref low clos::+class-precedence-list-ndx+)
	      :test #'eq))) ; (class-precedence-list low)
562

563 564 565 566
#+clos
(defun of-class-p (object class)
  (declare (optimize (speed 3) (safety 0)))
  (macrolet ((class-precedence-list (x)
567
	       `(si::instance-ref ,x clos::+class-precedence-list-ndx+))
568
	     (class-name (x)
569
	       `(si::instance-ref ,x clos::+class-name-ndx+)))
570 571 572 573 574 575 576
    (let* ((x-class (class-of object)))
      (declare (class x-class))
      (if (eq x-class class)
	  t
	  (let ((x-cpl (class-precedence-list x-class)))
	    (if (instancep class)
		(member class x-cpl :test #'eq)
577
		(dolist (c x-cpl)
578 579 580 581
		  (declare (class c))
		  (when (eq (class-name c) class)
		    (return t)))))))))

582
#+(and clos ecl-min)
583 584 585
(defun clos::classp (foo)
  (declare (ignore foo))
  nil)
jjgarcia's avatar
jjgarcia committed
586

587 588 589 590 591 592 593
;;************************************************************
;;			NORMALIZE-TYPE
;;************************************************************
;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
;; The result is a pair of values
;;  VALUE-1 = normalized type name or object
;;  VALUE-2 = normalized type arguments or nil
jjgarcia's avatar
jjgarcia committed
594 595 596
(defun normalize-type (type &aux tp i fd)
  ;; Loops until the car of type has no DEFTYPE definition.
  (cond ((symbolp type)
597
	 (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))
jjgarcia's avatar
jjgarcia committed
598 599 600 601 602
	   (normalize-type (funcall fd))
	   (values type nil)))
	#+clos
	((clos::classp type) (values type nil))
	((atom type)
603
	 (error-type-specifier type))
jjgarcia's avatar
jjgarcia committed
604 605
	((progn
	   (setq tp (car type) i (cdr type))
606
	   (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION)))
jjgarcia's avatar
jjgarcia committed
607 608 609 610 611
	 (normalize-type (apply fd i)))
	((and (eq tp 'INTEGER) (consp (cadr i)))
	 (values tp (list (car i) (1- (caadr i)))))
	(t (values tp i))))

612 613 614 615 616 617 618 619 620 621 622 623 624 625
(defun expand-deftype (type)
  (cond ((symbolp type)
	 (let ((fd (get-sysprop type 'DEFTYPE-DEFINITION)))
	   (if fd
	       (expand-deftype (funcall fd))
	       type)))
	((and (consp type)
	      (symbolp type))
	 (let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
	   (if fd
	       (expand-deftype (funcall fd (rest type)))
	       type)))
	(t
	 type)))
jjgarcia's avatar
jjgarcia committed
626

627 628 629
;;************************************************************
;;			COERCE
;;************************************************************
jjgarcia's avatar
jjgarcia committed
630

631 632 633 634
(defun error-coerce (object type)
  (error "Cannot coerce ~S to type ~S." object type))

(defun coerce (object type &aux aux)
635 636 637
  "Args: (x type)
Coerces X to an object of the specified type, if possible.  Signals an error
if not possible."
jjgarcia's avatar
jjgarcia committed
638
  (when (typep object type)
639 640 641 642 643 644 645
    ;; Just return as it is.
    (return-from coerce object))
  (setq type (expand-deftype type))
  (cond ((atom type)
	 (case type
	   ((T) object)
	   (LIST
646 647 648
	    (do ((io (make-seq-iterator object) (seq-iterator-next object io))
	         (l nil (cons (seq-iterator-ref object io) l)))
	        ((null io) l)))
649 650
	   ((CHARACTER BASE-CHAR) (character object))
	   (FLOAT (float object))
651 652 653 654
	   (SINGLE-FLOAT (float object 0.0F0))
	   (SHORT-FLOAT (float object 0.0S0))
	   (DOUBLE-FLOAT (float object 0.0D0))
	   (LONG-FLOAT (float object 0.0L0))
655 656
	   (COMPLEX (complex (realpart object) (imagpart object)))
	   (FUNCTION (coerce-to-function object))
657
	   ((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
658 659 660 661 662 663 664 665 666 667 668 669
	    (concatenate type object))
	   (t
	    (if (or (listp object) (vector object))
		(concatenate type object)
		(error-coerce object type)))))
	((eq (setq aux (first type)) 'COMPLEX)
	 (if type
	     (complex (coerce (realpart object) (second type))
		      (coerce (imagpart object) (second type)))
	     (complex (realpart object) (imagpart object))))
	((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
	 (setq aux (coerce object aux))
670 671 672
	 (unless (typep aux type)
	   (error-coerce object type))
	 aux)
673
	((eq aux 'AND)
674 675 676 677 678
	 (dolist (type (rest type))
	   (setq aux (coerce aux type)))
	 (unless (typep aux type)
	   (error-coerce object type))
	 aux)
679 680 681 682
	((or (listp object) (vector object))
	 (concatenate type object))
	(t
	 (error-coerce object type))))
683

684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726
;;************************************************************
;;			SUBTYPEP
;;************************************************************
;;
;; TYPES LATTICE (Following Henry Baker's paper)
;;
;; The algorithm works as follows. Types are identified with sets. Some sets
;; are elementary, in the sense that other types may be expressed as
;; combination of them. We partition these sets into FAMILIES
;;
;;	Built-in objects --- Hash tables, etc
;;	Intervals --- (INTEGER a b), (REAL a b), etc
;;	Arrays --- (ARRAY * (2)), etc
;;	Classes
;;
;; When passed a type specifier, ECL canonicalizes it: it decomposes the
;; type into the most elementary sets, assigns a unique bit pattern (TAG) to
;; each of these sets, and builds a composite tag for the type by LOGIOR.
;; Operations between these sets reduce to logical operations between these
;; bit patterns. Given types T1, T2 and a function which produces tags f(T)
;;
;;	f((AND T1 T2)) = (LOGIAND f(T1) f(T2))
;;	f((OR T1 T2)) = (LOGIOR f(T1) f(T2))
;;	f((NOT T1)) = (LOGNOT f(T2))
;;
;; However, tags are not permanent: whenever a new type is registered, the
;; tag associated to a type may be changed (for instance, because new
;; elementary sets are discovered, which also belong to existing types).

(defparameter *save-types-database* nil)

(defparameter *highest-type-tag*
  #+ecl-min #B1
  #-ecl-min '#.*highest-type-tag*)

(defparameter *member-types*
  #+ecl-min NIL
  #-ecl-min '#.*member-types*)

(defparameter *intervals-mask* #B1)

(defparameter *elementary-types*
  #+ecl-min
727
  '()
728 729 730 731 732 733 734 735 736 737
  #-ecl-min
  '#.*elementary-types*)

(defun new-type-tag ()
  (declare (si::c-local))
  (prog1 *highest-type-tag*
    (setq *highest-type-tag* (ash *highest-type-tag* 1))))

;; Find out the tag for a certain type, if it has been already registered.
;;
738
(defun find-registered-tag (type &optional (test #'equal))
739
  (declare (si::c-local))
740 741
  (let* ((pos (assoc type *elementary-types* :test test)))
    (and pos (cdr pos))))
742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758

;; We are going to make changes in the types database. Save a copy if this
;; will cause trouble.
;;
(defun maybe-save-types ()
  (declare (si::c-local))
  (when *save-types-database*
    (setf *save-types-database* nil
	  *elementary-types* (copy-tree *elementary-types*)
	  *member-types* (copy-tree *member-types*))))

;; We have created and tagged a new type (NEW-TAG). However, there are
;; composite and synonym types registered around which are supertypes of
;; this type and need to be tagged. TYPE-MASK is a bit pattern which helps
;; us in recognizing these supertypes.
;;
(defun update-types (type-mask new-tag)
759
  (declare (ext:assume-no-errors))
760 761
  (maybe-save-types)
  (dolist (i *elementary-types*)
762 763
    (unless (zerop (logand (cdr i) type-mask))
      (setf (cdr i) (logior new-tag (cdr i))))))
764 765 766 767 768 769 770 771 772 773 774 775 776 777 778

;; FIND-TYPE-BOUNDS => (VALUES TAG-SUPER TAG-SUB)
;;
;; This function outputs two values: TAG-SUB, the tag for the union-type of all
;; types which are subtypes of the supplied one; and TAG-SUPER, which is either
;; the tag for the union-type of all types which a supertype of the supplied
;; one (MINIMIZE-SUPER = NIL) or the tag for the smallest type which is a
;; supertype of the given one (MINIMIZE-SUPER = TRUE). The search process is
;; restricted to types in the same family class.
;;
;; A value of MINIMIZE-SUPER = TRUE only makes sense for some families (such
;; as semi-infinite intervals), for which (SUBTYPEP T1 T2) = T and (SUBTYPEP T1
;; T3) = T implies either (SUBTYPEP T2 T3) = T or (SUBTYPEP T3 T2) = T.
;;
(defun find-type-bounds (type in-our-family-p type-<= minimize-super)
779
  (declare (si::c-local)
780
           (optimize (safety 0))
781
	   (function in-our-family-p type-<=)) 
782
  (let* ((subtype-tag 0)
783
	 (disjoint-tag 0)
784 785
	 (supertype-tag (if minimize-super -1 0)))
    (dolist (i *elementary-types*)
786
      (declare (cons i))
787 788 789
      (let ((other-type (car i))
	    (other-tag (cdr i)))
	(when (funcall in-our-family-p other-type)
790 791 792 793 794 795
	  (cond ((funcall type-<= type other-type)
		 (if minimize-super
		     (when (zerop (logandc2 other-tag supertype-tag))
		       (setq supertype-tag other-tag))
		     (setq supertype-tag (logior other-tag supertype-tag))))
		((funcall type-<= other-type type)
796 797 798 799 800 801
		 (setq subtype-tag (logior other-tag subtype-tag)))
		(t
		 (setq disjoint-tag (logior disjoint-tag other-tag)))))))
    (values (if (= supertype-tag -1) 0
		(logandc2 supertype-tag (logior disjoint-tag subtype-tag)))
	    subtype-tag)))
802 803 804 805 806 807 808 809 810 811

;; A new type is to be registered, which is not simply a composition of
;; previous types. A new tag has to be created, and all supertypes are to be
;; tagged. Here we have to distinguish two possibilities: first, a supertype
;; may belong to the same family (intervals, arrays, etc); second, some
;; supertypes may be basic types (NUMBER is a supertype for (INTEGER 0 2),
;; for instance). The first possibility is detected with the comparison
;; procedure, TYPE-<=; the second possibility is detected by means of tags.
;;
(defun register-type (type in-our-family-p type-<=)
812
  (declare (si::c-local)
813
           (optimize (safety 0))
814
	   (function in-our-family-p type-<=))
815 816 817
  (or (find-registered-tag type)
      (multiple-value-bind (tag-super tag-sub)
	  (find-type-bounds type in-our-family-p type-<= nil)
818
	(let ((tag (new-type-tag)))
819
	  (update-types (logandc2 tag-super tag-sub) tag)
820
	  (setf tag (logior tag tag-sub))
821
	  (push-type type tag)))))
822 823 824

;;----------------------------------------------------------------------
;; MEMBER types. We register this object in a separate list, *MEMBER-TYPES*,
825 826 827 828 829 830 831 832
;; and tag all types to which it belongs. We need to treat three cases
;; separately
;;	- Ordinary types, via simple-member-type, check the objects
;;	  against all pre-registered types, adding their tags.
;;	- Ordinary numbers, are translated into intervals.
;;	- Floating point zeros, have to be treated separately. This
;;	  is done by assigning a special tag to -0.0 and translating
;;	  (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0)))
833 834
;;
(defun register-member-type (object)
835
  ;(declare (si::c-local))
836
  (let ((pos (assoc object *member-types*)))
837 838 839 840
    (cond ((and pos (cdr pos)))
	  ((not (realp object))
	   (simple-member-type object))
	  ((and (floatp object) (zerop object))
841 842 843 844 845 846
	   #.(if (eql (- 0.0) 0.0)
		 '(number-member-type object)
		 '(if (minusp (float-sign object))
		      (simple-member-type object)
		      (logandc2 (number-member-type object)
			        (register-member-type (- object))))))
847 848 849 850
	  (t
	   (number-member-type object)))))

(defun simple-member-type (object)
851 852
  (declare (si::c-local)
	   (ext:assume-no-errors))
853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
  (let* ((tag (new-type-tag)))
    (maybe-save-types)
    (setq *member-types* (acons object tag *member-types*))
    (dolist (i *elementary-types*)
      (let ((type (car i)))
	(when (typep object type)
	  (setf (cdr i) (logior tag (cdr i))))))
    tag))

;; We convert number into intervals, so that (AND INTEGER (NOT (EQL
;; 10))) is detected as a subtype of (OR (INTEGER * 9) (INTEGER 11
;; *)).
(defun number-member-type (object)
  (let* ((base-type (if (integerp object) 'INTEGER (type-of object)))
	 (type (list base-type object object)))
    (or (find-registered-tag type)
	(register-interval-type type))))
870

871
(defun push-type (type tag)
872 873
  (declare (si::c-local)
	   (ext:assume-no-errors))
874 875 876 877
  (dolist (i *member-types*)
    (declare (cons i))
    (when (typep (car i) type)
      (setq tag (logior tag (cdr i)))))
878 879
  (push (cons type tag) *elementary-types*)
  tag)
880

881 882 883 884 885
;;----------------------------------------------------------------------
;; SATISFIES types. Here we should signal some error which is caught
;; somewhere up, to denote failure of the decision procedure.
;;
(defun register-satisfies-type (type)
886 887
  (declare (si::c-local)
	   (ignore type))
888 889 890 891 892 893
  (throw '+canonical-type-failure+ 'satisfies))

;;----------------------------------------------------------------------
;; CLOS classes and structures.
;;
(defun register-class (class)
894 895
  (declare (si::c-local)
	   (notinline class-name))
896 897 898 899 900 901
  (or (find-registered-tag class)
      ;; We do not need to register classes which belong to the core type
      ;; system of LISP (ARRAY, NUMBER, etc).
      (let* ((name (class-name class)))
	(and name
	     (eq class (find-class name 'nil))
902 903
	     (or (find-registered-tag name)
		 (find-built-in-tag name))))
904 905
      (and (not (clos::class-finalized-p class))
           (throw '+canonical-type-failure+ nil))
906 907 908 909 910 911 912
      (register-type class
		     #'(lambda (c) (or (si::instancep c) (symbolp c)))
		     #'(lambda (c1 c2)
			 (when (symbolp c1)
			   (setq c1 (find-class c1 nil)))
			 (when (symbolp c2)
			   (setq c2 (find-class c2 nil)))
913
			 (and c1 c2 (si::subclassp c1 c2))))))
914 915 916 917 918 919

;;----------------------------------------------------------------------
;; ARRAY types.
;;
(defun register-array-type (type)
  (declare (si::c-local))
920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935
  (multiple-value-bind (array-class elt-type dimensions)
      (parse-array-type type)
    (cond ((eq elt-type '*)
	   (canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions))
					  +upgraded-array-element-types+))))
	  ((find-registered-tag (setq type (list array-class elt-type dimensions))))
	  (t
	   #+nil
	   (when (and (consp dimensions) (> (count-if #'numberp dimensions) 1))
	     (dotimes (i (length dimensions))
	       (when (numberp (elt dimensions i))
		 (let ((dims (make-list (length dimensions) :initial-element '*)))
		   (setf (elt dims i) (elt dimensions i))
		   (register-type (list array-class elt-type dims)
				  #'array-type-p #'array-type-<=)))))
	   (register-type type #'array-type-p #'array-type-<=)))))
936 937 938 939 940 941 942 943 944

;;
;; We look for the most specialized type which is capable of containing
;; this object. LIST always contains 'T, so that this procedure never
;; fails. It is faster than UPGRADED-... because we use the tags of types
;; that have been already registered.
;;
(defun fast-upgraded-array-element-type (type)
  (declare (si::c-local))
945 946 947 948 949 950 951
  (cond ((eql type '*) '*)
	((member type +upgraded-array-element-types+ :test #'eq)
	 type)
	(t
	 (dolist (other-type +upgraded-array-element-types+ 'T)
	   (when (fast-subtypep type other-type)
	     (return other-type))))))
952 953 954

;;
;; This canonicalizes the array type into the form
955
;;	({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)})
956 957 958 959 960 961 962 963 964 965 966 967 968 969
;;
;; ELT-TYPE is the upgraded element type of the input.
;;
(defun parse-array-type (input)
  (declare (si::c-local))
  (let* ((type input)
	 (name (pop type))
	 (elt-type (fast-upgraded-array-element-type (if type (pop type) '*)))
	 (dims (if type (pop type) '*)))
    (when type
      (error "Wrong array type designator ~S." input))
    (cond ((numberp dims)
	   (unless (< -1 dims array-rank-limit)
	     (error "Wrong rank size array type ~S." input))
970 971
	   (setq dims (nthcdr (- array-rank-limit dims)
			      '#.(make-list array-rank-limit :initial-element '*))))
972 973 974 975 976
	  ((consp dims)
	   (dolist (i dims)
	     (unless (or (eq i '*)
			 (and (integerp i) (< -1 i array-dimension-limit)))
	       (error "Wrong dimension size in array type ~S." input)))))
977
    (values name elt-type dims)))
978 979 980 981 982 983

;;
;; This function checks whether the array type T1 is a subtype of the array
;; type T2.
;;
(defun array-type-<= (t1 t2)
984
  (unless (and (eq (first t1) (first t2))
985 986 987 988 989 990 991 992 993 994
	       (eq (second t1) (second t2)))
    (return-from array-type-<= nil))
  (let ((dim (third t1))
	(pat (third t2)))
    (cond ((eq pat '*) t)
	  ((eq dim '*) nil)
	  (t (do ((a dim (cdr a))
		  (b pat (cdr b)))
		 ((or (endp a)
		      (endp b)
995 996
		      (not (or (eq (car b) '*)
			       (eql (car b) (car a)))))
997 998 999 1000 1001
		  (and (null a) (null b)))
	       )))))

(defun array-type-p (type)
  (and (consp type)
1002
       (member (first type) '(COMPLEX-ARRAY SIMPLE-ARRAY))))
1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016

;;----------------------------------------------------------------------
;; INTERVALS:
;;
;; Arbitrary intervals may be defined as the union or intersection of
;; semi-infinite intervals, of the form (number-type b *), where B is
;; either a real number, a list with one real number or *.
;; Any other interval, may be defined using these. For instance
;;  (INTEGER 0 2) = (AND (INTEGER 0 *) (NOT (INTEGER (2) *)))
;;  (SHORT-FLOAT (0.2) (2)) = (AND (SHORT-FLOAT (0.2) *) (NOT (SHORT-FLOAT 2 *)))

(defun register-elementary-interval (type b)
  (declare (si::c-local))
  (setq type (list type b))
1017
  (or (find-registered-tag type #'equalp)
1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029
      (multiple-value-bind (tag-super tag-sub)
	  (find-type-bounds type
			    #'(lambda (other-type)
				(and (consp other-type)
				     (null (cddr other-type))))
			    #'(lambda (i1 i2)
				(and (eq (first i1) (first i2))
				     (bounds-<= (second i2) (second i1))))
			    t)
	(let ((tag (new-type-tag)))
	  (update-types (logandc2 tag-super tag-sub) tag)
	  (setq tag (logior tag tag-sub))
1030
	  (push-type type tag)))))
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057

(defun register-interval-type (interval)
  (declare (si::c-local))
  (let* ((i interval)
	 (type (pop i))
	 (low (if i (pop i) '*))
	 (high (if i (pop i) '*))
	 (tag-high (cond ((eq high '*)
			  0)
			 ((eq type 'INTEGER)
			  (setq high (if (consp high)
					 (ceiling (first high))
					 (floor (1+ high))))
			  (register-elementary-interval type high))
			 ((consp high)
			  (register-elementary-interval type (first high)))
			 (t
			  (register-elementary-interval type (list high)))))
	 (tag-low (register-elementary-interval type
		    (cond ((or (eq '* low) (not (eq type 'INTEGER)) (integerp low))
			   low)
			  ((consp low)
			   (floor (1+ (first low))))
			  (t
			   (ceiling low)))))
	 (tag (logandc2 tag-low tag-high)))
    (unless (eq high '*)
1058
      (push-type interval tag))
1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100
    tag))

;; All comparisons between intervals operations may be defined in terms of
;;
;;	(BOUNDS-<= b1 b2)	and	(BOUNDS-< b1 b2)
;;
;; The first one checks whether (REAL b2 *) is contained in (REAL b1 *). The
;; second one checks whether (REAL b2 *) is strictly contained in (REAL b1 *)
;; (i.e., (AND (REAL b1 *) (NOT (REAL b2 *))) is not empty).
;;
(defun bounds-<= (b1 b2)
  (cond ((eq b1 '*) t)
	((eq b2 '*) nil)
	((consp b1)
	 (if (consp b2)
	     (<= (first b1) (first b2))
	     (< (first b1) b2)))
	((consp b2)
	 (<= b1 (first b2)))
	(t
	 (<= b1 b2))))

(defun bounds-< (b1 b2)
  (cond ((eq b1 '*) (not (eq b2 '*)))
	((eq b2 '*) nil)
	((consp b1)
	 (if (consp b2)
	     (< (first b1) (first b2))
	     (< (first b1) b2)))
	((consp b2)
	 (<= b1 (first b2)))
	(t
	 (< b1 b2))))

;;----------------------------------------------------------------------
;; COMPLEX types. We do not need to register anything, because all
;; possibilities have been covered by the definitions above. We only have to
;; bring the type to canonical form, which is a union of all specialized
;; complex types that can store an element of the corresponding type.
;;
(defun canonical-complex-type (real-type)
  (declare (si::c-local))
1101 1102 1103 1104 1105 1106
  ;; UPGRADE-COMPLEX-PART-TYPE will signal an error if REAL-TYPE
  ;; is not a subtype of REAL.
  (unless (eq real-type '*)
    (upgraded-complex-part-type real-type))
  (or (find-registered-tag '(COMPLEX REAL))
      (let ((tag (new-type-tag)))
1107
	(push-type '(COMPLEX REAL) tag)))
1108
  #+(or)
1109
  (case real-type
1110
    ((SINGLE-FLOAT DOUBLE-FLOAT INTEGER RATIO #+long-float LONG-FLOAT)
1111
     (let ((tag (new-type-tag)))
1112
       (push-type `(COMPLEX ,real-type) tag)))
1113
    ((RATIONAL) (canonical-type '(OR (COMPLEX INTEGER) (COMPLEX RATIO))))
1114
    ((FLOAT) (canonical-type '(OR (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
1115
			       #+long-float (COMPLEX LONG-FLOAT))))
1116 1117
    ((* NIL REAL) (canonical-type
		   '(OR (COMPLEX INTEGER) (COMPLEX RATIO)
1118 1119 1120
		        (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
		     #+long-float (COMPLEX LONG-FLOAT)
		     )))
1121
    (otherwise (canonical-complex-type (upgraded-complex-part-type real-type)))))
1122

1123 1124 1125 1126 1127
;;----------------------------------------------------------------------
;; CONS types. Only (CONS T T) and variants, as well as (CONS NIL *), etc
;; are strictly supported.
;;
(defun register-cons-type (&optional (car-type '*) (cdr-type '*))
1128 1129 1130 1131
  ;; The problem with the code below is that it does not suport infinite
  ;; recursion. Instead we just canonicalize everything to CONS, irrespective
  ;; of whether the arguments are valid types or not!
  #+(or)
1132
  (canonical-type 'CONS)
1133 1134
  (let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
	(cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
1135 1136 1137 1138 1139 1140
    (cond ((or (zerop car-tag) (zerop cdr-tag))
	   0)
	  ((and (= car-tag -1) (= cdr-tag -1))
	   (canonical-type 'CONS))
	  (t
	   (throw '+canonical-type-failure+ 'CONS)))))
1141

1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158
;;----------------------------------------------------------------------
;; FIND-BUILT-IN-TAG
;;
;; This function computes the tags for all builtin types. We used to
;; do this computation and save it. However, for most cases it seems
;; faster if we just repeat it every time we need it, because the list of
;; *elementary-types* is kept smaller and *highest-type-tag* may be just
;; a fixnum.
;;
;; Note 1: There is some redundancy between this and the built-in
;; classes definitions. REGISTER-CLASS knows this and calls
;; FIND-BUILT-IN-TAG, which has priority. This is because some built-in
;; classes are also interpreted as intervals, arrays, etc.
;;
;; Note 2: All built in types listed here have to be symbols.
;;
#+ecl-min
1159
(defconstant +built-in-type-list+
1160 1161 1162 1163 1164 1165 1166
	     '((SYMBOL)
	       (KEYWORD NIL SYMBOL)
	       (PACKAGE)
	       (COMPILED-FUNCTION)
	       (FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION))

	       (INTEGER (INTEGER * *))
1167 1168
	       (SINGLE-FLOAT (SINGLE-FLOAT * *))
	       (DOUBLE-FLOAT (DOUBLE-FLOAT * *))
1169 1170
	       #+long-float
	       (LONG-FLOAT (LONG-FLOAT * *))
1171 1172 1173
	       (RATIO (RATIO * *))

	       (RATIONAL (OR INTEGER RATIO))
1174
	       (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT
1175
                       #+long-float LONG-FLOAT))
1176 1177
	       (REAL (OR INTEGER SINGLE-FLOAT DOUBLE-FLOAT
		      #+long-float LONG-FLOAT RATIO))
1178 1179 1180 1181 1182
	       (COMPLEX (COMPLEX REAL))

	       (NUMBER (OR REAL COMPLEX))

	       (CHARACTER)
1183
               #-unicode
1184
	       (BASE-CHAR CHARACTER)
1185 1186
               #+unicode
	       (BASE-CHAR NIL CHARACTER)
1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198
	       (STANDARD-CHAR NIL BASE-CHAR)

	       (CONS)
	       (NULL (MEMBER NIL))
	       (LIST (OR CONS (MEMBER NIL)))

	       (ARRAY (ARRAY * *))
 	       (SIMPLE-ARRAY (SIMPLE-ARRAY * *))
	       (SIMPLE-VECTOR (SIMPLE-ARRAY T (*)))
	       (SIMPLE-BIT-VECTOR (SIMPLE-ARRAY BIT (*)))
	       (VECTOR (ARRAY * (*)))
	       (STRING (ARRAY CHARACTER (*)))
1199 1200
               #+unicode
	       (BASE-STRING (ARRAY BASE-CHAR (*)))
1201
	       (SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*)))
1202 1203
               #+unicode
	       (SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*)))
1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218
	       (BIT-VECTOR (ARRAY BIT (*)))

	       (SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*))))

	       (HASH-TABLE)
	       (PATHNAME)
	       (LOGICAL-PATHNAME NIL PATHNAME)

	       (BROADCAST-STREAM)
	       (CONCATENATED-STREAM)
	       (ECHO-STREAM)
	       (FILE-STREAM)
	       (STRING-STREAM)
	       (SYNONYM-STREAM)
 	       (TWO-WAY-STREAM)
1219
	       (EXT:SEQUENCE-STREAM)
1220
	       (EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM
1221 1222 1223
                                 FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM
                                 EXT:SEQUENCE-STREAM
                                 #+clos-streams GRAY:FUNDAMENTAL-STREAM))
1224
               (STREAM EXT:ANSI-STREAM)
1225 1226 1227 1228

	       (READTABLE)
	       #+threads (MP::PROCESS)
	       #+threads (MP::LOCK)
1229
	       #+threads (MP::RWLOCK)
1230 1231 1232
	       #+threads (MP::CONDITION-VARIABLE)
	       #+threads (MP::SEMAPHORE)
	       #+threads (MP::BARRIER)
1233
	       #+threads (MP::MAILBOX)
1234
	       #+ffi (FOREIGN-DATA)
1235 1236 1237 1238 1239 1240
	       #+sse2 (EXT:SSE-PACK (OR EXT:INT-SSE-PACK
				     EXT:FLOAT-SSE-PACK
				     EXT:DOUBLE-SSE-PACK))
	       #+sse2 (EXT:INT-SSE-PACK)
	       #+sse2 (EXT:FLOAT-SSE-PACK)
	       #+sse2 (EXT:DOUBLE-SSE-PACK)
1241
               (CODE-BLOCK)
1242 1243
	       ))

1244 1245 1246 1247 1248
(defconstant +built-in-types+
  (ext:hash-table-fill
     (make-hash-table :test 'eq :size 128)
     '#.+built-in-type-list+))

1249
(defun find-built-in-tag (name)
1250
  (declare (si::c-local))
1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266
  (let (record)
    (cond ((eq name T)
	   -1)
	  ((eq (setf record (gethash name +built-in-types+ name))
		    name)
	   nil)
	  (t
	   (let* ((alias (pop record))
		  tag)
	     (if alias
		 (setq tag (canonical-type alias))
		 (let* ((strict-supertype (or (first record) 'T))
			(strict-supertype-tag (canonical-type strict-supertype)))
		   (setq tag (new-type-tag))
		   (unless (eq strict-supertype 't)
		     (extend-type-tag tag strict-supertype-tag))))
1267
	     (push-type name tag))))))
1268 1269

(defun extend-type-tag (tag minimal-supertype-tag)
1270 1271
  (declare (si::c-local)
	   (ext:assume-no-errors))
1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305
  (dolist (type *elementary-types*)
    (let ((other-tag (cdr type)))
      (when (zerop (logandc2 minimal-supertype-tag other-tag))
	(setf (cdr type) (logior tag other-tag))))))

;;----------------------------------------------------------------------
;; CANONICALIZE (removed)
;;
;; This function takes a type tag and produces a more or less human
;; readable representation of the type in terms of elementary types,
;; intervals, arrays and classes.
;;
#+nil
(defun canonicalize (type)
  (let ((*highest-type-tag* *highest-type-tag*)
	(*save-types-database* t)
	(*member-types* *member-types*)
	(*elementary-types* *elementary-types*))
    (let ((tag (canonical-type type))
	  (out))
      (setq tag (canonical-type type))
      ;;(print-types-database *elementary-types*)
      ;;(print-types-database *member-types*)
      (dolist (i *member-types*)
	(unless (zerop (logand (cdr i) tag))
	  (push (car i) out)))
      (when out
	(setq out `((MEMBER ,@out))))
      (dolist (i *elementary-types*)
	(unless (zerop (logand (cdr i) tag))
	  ;;(print (list tag (cdr i) (logand tag (cdr i))))
	  (push (car i) out)))
	(values tag `(OR ,@out)))))

1306 1307 1308 1309 1310 1311 1312 1313 1314
;;----------------------------------------------------------------------
;; (CANONICAL-TYPE TYPE)
;;
;; This function registers all types mentioned in the given expression,
;; and outputs a code corresponding to the represented type. This
;; function has side effects: it destructively modifies the content of
;; *ELEMENTARY-TYPES* and *MEMBER-TYPES*.
;;
(defun canonical-type (type)
1315
  (declare (notinline clos::classp))
1316
  (cond ((find-registered-tag type))
1317 1318
	((eq type 'T) -1)
	((eq type 'NIL) 0)
1319 1320
        ((symbolp type)
	 (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION)))
1321 1322 1323 1324 1325 1326 1327
	   (cond (expander
		  (canonical-type (funcall expander)))
		 ((find-built-in-tag type))
		 (t (let ((class (find-class type nil)))
		      (if class
			  (register-class class)
			  (throw '+canonical-type-failure+ nil)))))))
1328 1329 1330 1331 1332 1333 1334
	((consp type)
	 (case (first type)
	   (AND (apply #'logand (mapcar #'canonical-type (rest type))))
	   (OR (apply #'logior (mapcar #'canonical-type (rest type))))
	   (NOT (lognot (canonical-type (second type))))
	   ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type))))
	   (SATISFIES (register-satisfies-type type))
1335
	   ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT)
1336 1337
	    (register-interval-type type))
	   ((FLOAT)
1338
	    (canonical-type `(OR (SINGLE-FLOAT ,@(rest type))
1339 1340 1341
				 (DOUBLE-FLOAT ,@(rest type))
				 #+long-float
				 (LONG-FLOAT ,@(rest type)))))
1342 1343
	   ((REAL)
	    (canonical-type `(OR (INTEGER ,@(rest type))
1344 1345 1346 1347 1348
				 (RATIO ,@(rest type))
				 (SINGLE-FLOAT ,@(rest type))
				 (DOUBLE-FLOAT ,@(rest type))
				 #+long-float
				 (LONG-FLOAT ,@(rest type)))))
1349 1350
	   ((RATIONAL)
	    (canonical-type `(OR (INTEGER ,@(rest type))
1351
				 (RATIO ,@(rest type)))))
1352 1353 1354
	   (COMPLEX
	    (or (find-built-in-tag type)
		(canonical-complex-type (second type))))
1355
	   (CONS (apply #'register-cons-type (rest type)))
1356 1357 1358
	   (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type)))
			  (register-array-type `(SIMPLE-ARRAY ,@(rest type)))))
	   ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type))
1359 1360 1361
	   ;;(FUNCTION (register-function-type type))
	   ;;(VALUES (register-values-type type))
	   (FUNCTION (canonical-type 'FUNCTION))
1362 1363 1364 1365 1366 1367 1368
	   (t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
		(if expander
		    (canonical-type (apply expander (rest type)))
		    (unless (assoc (first type) *elementary-types*)
		      (throw '+canonical-type-failure+ nil)))))))
	((clos::classp type)
	 (register-class type))
1369
	((and (fboundp 'function-type-p) (function-type-p type))
1370
	 (register-function-type type))
1371
	((and (fboundp 'values-type-p) (values-type-p type))
1372
	 (register-values-type type))
1373 1374 1375 1376 1377 1378 1379
	(t
	 (error-type-specifier type))))

(defun safe-canonical-type (type)
  (catch '+canonical-type-failure+
    (canonical-type type)))

1380
(defun fast-subtypep (t1 t2)
1381
  (declare (si::c-local))
1382
  (when (eq t1 t2)
1383 1384
    (return-from fast-subtypep (values t t)))
  (let* ((tag1 (safe-canonical-type t1))
1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398
	 (tag2 (safe-canonical-type t2)))
    (cond ((and (numberp tag1) (numberp tag2))
	   (values (zerop (logandc2 (safe-canonical-type t1)
				    (safe-canonical-type t2)))
		   t))
	  #+nil
	  ((null tag1)
	   (error "Unknown type specifier ~S." t1))
	  #+nil
	  ((null tag2)
	   (error "Unknown type specifier ~S." t2))
	  (t
	   (values nil nil)))))

1399
(defun subtypep (t1 t2 &optional env)
1400
  (declare (ignore env))
1401
  ;; One easy case: types are equal
1402 1403
  (when (eq t1 t2)
    (return-from subtypep (values t t)))
1404 1405 1406
  ;; Another easy case: types are classes.
  (when (and (instancep t1) (instancep t2)
	     (clos::classp t1) (clos::classp t2))
1407
    (return-from subtypep (values (subclassp t1 t2) t)))
1408 1409
  ;; Finally, cached results.
  (let* ((cache *subtypep-cache*)
1410
	 (hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255)))
1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422
	 (elt (aref cache hash)))
    (when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
      (setf elt (cdr elt))
      (return-from subtypep (values (car elt) (cdr elt))))
    (let* ((*highest-type-tag* *highest-type-tag*)
	   (*save-types-database* t)
	   (*member-types* *member-types*)
	   (*elementary-types* *elementary-types*))
      (multiple-value-bind (test confident)
	  (fast-subtypep t1 t2)
	(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
	(values test confident)))))
1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447

(defun fast-type= (t1 t2)
  (declare (si::c-local))
  (when (eq t1 t2)
    (return-from fast-type= (values t t)))
  (let* ((tag1 (safe-canonical-type t1))
	 (tag2 (safe-canonical-type t2)))
    (cond ((and (numberp tag1) (numberp tag2))
	   (values (= (safe-canonical-type t1) (safe-canonical-type t2))
		   t))
	  #+nil
	  ((null tag1)
	   (error "Unknown type specifier ~S." t1))
	  #+nil
	  ((null tag2)
	   (error "Unknown type specifier ~S." t2))
	  (t
	   (values nil nil)))))

(defun type= (t1 t2)
  (let ((*highest-type-tag* *highest-type-tag*)
	(*save-types-database* t)
	(*member-types* *member-types*)
	(*elementary-types* *elementary-types*))
    (fast-type= t1 t2)))