predlib.lsp 58.5 KB
Newer Older
1 2 3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

4
;;;;
jjgarcia's avatar
jjgarcia committed
5 6
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
7
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
jjgarcia's avatar
jjgarcia committed
8 9 10 11 12 13 14 15 16 17 18 19
;;;;
;;;;    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")

20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
(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))))

36
(defparameter *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
37

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

40
(defun subtypep-clear-cache ()
41 42
  (ext:fill-array-with-elt *subtypep-cache* nil 0 nil)
  (ext:fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil))
43

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

(defun do-deftype (name form function)
  (unless (symbolp name)
50
    (error-type-specifier name))
51 52
  (create-type-name name)
  (put-sysprop name 'DEFTYPE-FORM form)
53 54
  (put-sysprop name 'DEFTYPE-DEFINITION
               (if (functionp function) function (constantly function)))
55
  (subtypep-clear-cache)
56 57
  name)

jjgarcia's avatar
jjgarcia committed
58
;;; DEFTYPE macro.
59
(defmacro deftype (name lambda-list &rest body &environment env)
60 61 62 63
  "Syntax: (deftype name macro-lambda-list {decl | doc}* {form}*)
Defines a new type-specifier abbreviation in terms of an 'expansion'
function

64
        (lambda (whole) {DECL}* {FORM}*)
65 66 67

where WHOLE is identical to MACRO-LAMBDA-LIST except that all optional
parameters with no default value specified in LAMBDA-LIST defaults to
68 69 70 71 72 73 74
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 argument (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)."
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
  (labels ((set-default (list*)
             "Sets default value for optional arguments to *. Doesn't
              modify arguments which happen to be in lambda-list
              keywords."
             (if (consp list*)
                 (let ((variable (car list*)))
                   (cons
                    (if (and (symbolp variable)
                             (not (member variable lambda-list-keywords)))
                        `(,variable '*)
                        variable)
                    (set-default (cdr list*))))
                 list*))
           (verify-tree (elt)
             "Vefrifies if ELT is the list containing optional arg."
             (and (consp elt)
                  (member (car elt)
                          '(&key &optional))))
           (maptree (function tree test)
             "Applies FUNCTION to branches for which TEST resolves to
              true. MAPTREE doesn't traverse this branch further. It
              is correct in this context, because we can't create
              nested lambda-list after both &key and &optional, since
              it would be considered as default value or an error."
             (cond ((funcall test tree)
                    (funcall function tree))
                   ((consp tree)
                    (cons
                     (maptree function (car tree) test)
                     (maptree function (cdr tree) test)))
                   (T tree))))
    (setf lambda-list
          (maptree #'set-default lambda-list #'verify-tree)))
108 109 110
  (multiple-value-bind (decls body documentation)
      (si::find-declarations body)
    (multiple-value-bind (ppn whole dl arg-check ignorables)
111
        (destructure lambda-list 'deftype)
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
      (declare (ignore ppn))
      (let ((function `#'(ext::lambda-block ,name (,whole &aux ,@dl)
                                            (declare (ignorable ,@ignorables))
                                            ,@decls ,@arg-check
                                            ,@body)))
        (when (and (null lambda-list)
                   (consp body)
                   (null (rest body)))
          (let ((form (first body)))
            (when (constantp form env)
              (setf function (ext:maybe-quote (ext:constant-form-value form env))))))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
           ,@(si::expand-set-documentation name 'type documentation)
           (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body)
                       ,function))))))
jjgarcia's avatar
jjgarcia committed
127 128

;;; Some DEFTYPE definitions.
129 130
(deftype boolean ()
  "A BOOLEAN is an object which is either NIL or T."
131
  '(member nil t))
132

133
(deftype index ()
134
  '(INTEGER 0 #.array-dimension-limit))
135

jjgarcia's avatar
jjgarcia committed
136
(deftype fixnum ()
137 138
  "A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM and
MOST-POSITIVE-FIXNUM inclusive.  Other integers are bignums."
139
  '(INTEGER #.most-negative-fixnum #.most-positive-fixnum))
140 141
(deftype bignum ()
  '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
142

143 144 145 146 147 148 149 150 151 152
(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))
153

154 155 156
(deftype real (&optional (start '* start-p) (end '*))
  (if start-p
      (let (rat-start
Daniel Kochmański's avatar
Daniel Kochmański committed
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
            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)))
181
      '(OR RATIONAL FLOAT)))
182

183
#-short-float
184
(deftype short-float (&rest args)
185
  (if args
186 187
      `(single-float ,@args)
      'single-float))
188

189
#-long-float
190
(deftype long-float (&rest args)
191
  (if args
192 193
      `(double-float ,@args)
      'double-float))
194

195 196 197 198
(deftype bit ()
  "A BIT is either integer 0 or 1."
  '(INTEGER 0 1))

jjgarcia's avatar
jjgarcia committed
199 200
(deftype mod (n)
  `(INTEGER 0 ,(1- n)))
201

jjgarcia's avatar
jjgarcia committed
202
(deftype signed-byte (&optional s)
203 204
  "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
205 206 207
  (if (or (null s) (eq s '*))
      '(INTEGER * *)
      `(INTEGER ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
208

jjgarcia's avatar
jjgarcia committed
209
(deftype unsigned-byte (&optional s)
210 211
  "As a type specifier, (UNSIGNED-BYTE n) specifies non-negative integers that
can be represented with N bits."
jjgarcia's avatar
jjgarcia committed
212 213 214 215
  (if (or (null s) (eq s '*))
      '(INTEGER 0 *)
      `(INTEGER 0 ,(1- (expt 2 s)))))

216 217 218 219 220 221 222 223
(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 * (*))))

224 225 226 227 228 229 230
(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 `(...)
Daniel Kochmański's avatar
Daniel Kochmański committed
231 232 233
        ,form embeds the value of FORM,
        ,@form and ,.form embed all elements of the list value of FORM,
        and other things embed itself
234
into the structure at their position.  For example,
Daniel Kochmański's avatar
Daniel Kochmański committed
235 236 237
        `(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)))"
238 239
  '(OR CONS NULL))

240 241 242
(deftype proper-list ()
  '(OR (CONS T PROPER-LIST) NULL))

243 244 245
(deftype property-list ()
  '(OR (CONS T (CONS T PROPERTY-LIST)) NULL))

246 247 248
(deftype atom ()
  "An ATOM is an object that is not a CONS."
  '(NOT CONS))
jjgarcia's avatar
jjgarcia committed
249 250 251
;(deftype null () '(MEMBER NIL))

(deftype vector (&optional (element-type '*) (size '*))
252 253
  "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
Daniel Kochmański's avatar
Daniel Kochmański committed
254
        #(elem ... elem)
255 256
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
257
  `(array ,element-type (,size)))
258

259
(deftype extended-char ()
260
  "A character which is not of type BASE-CHAR."
261 262
  '(and character (not base-char)))

jjgarcia's avatar
jjgarcia committed
263
(deftype string (&optional size)
264 265 266 267
  "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."
268
  #-unicode
269 270 271
  (if (eq size '*)
      '(array character (*))
      `(array character (,size)))
272
  #+unicode
273 274
  (if (eq size '*)
      '(or (array base-char (*)) (array character (*)))
275
      `(or (array base-char (,size))
Daniel Kochmański's avatar
Daniel Kochmański committed
276
           (array character (,size)))))
277

278
(deftype base-string (&optional (size '*))
279
  "A string which is made of BASE-CHAR."
280
  (if (eq size '*) '(array base-char (*)) `(array base-char (,size))))
281

282
(deftype extended-string (&optional (size '*))
283 284 285 286
  "A string which is nt a base string"
  #-unicode
  NIL
  #+unicode
287
  (if (eq size '*) '(array character (*)) `(array character (,size))))
288

289
(deftype bit-vector (&optional (size '*))
290 291 292 293 294
  "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 '#*'."
295
  (if (eq size '*) '(array bit (*)) `(array bit (,size))))
jjgarcia's avatar
jjgarcia committed
296

297
(deftype simple-vector (&optional (size '*))
298 299
  "A simple-vector is a vector that is not displaced to another array, has no
fill-pointer, and is not adjustable."
300
  (if (eq size '*) '(simple-array t (*)) `(simple-array t (,size))))
301

jjgarcia's avatar
jjgarcia committed
302
(deftype simple-string (&optional size)
303 304
  "A simple-string is a string that is not displaced to another array, has no
fill-pointer, and is not adjustable."
305 306 307 308 309 310 311
  #-unicode
  (if size
    `(simple-array character (,size))
    '(simple-array character (*)))
  #+unicode
  (if size
      `(or (simple-array base-char (,size))
Daniel Kochmański's avatar
Daniel Kochmański committed
312
           (simple-array character (,size)))
313
      '(or (simple-array base-char (*)) (simple-array character (*)))))
314

jjgarcia's avatar
jjgarcia committed
315
(deftype simple-base-string (&optional size)
316
  "A base-string which cannot be adjusted nor displaced."
317
  (if size `(simple-array base-char (,size)) '(simple-array base-char (*))))
318

jjgarcia's avatar
jjgarcia committed
319
(deftype simple-bit-vector (&optional size)
320 321
  "A bit-vector that is not displaced to another array, has no fill-pointer,
and is not adjustable."
jjgarcia's avatar
jjgarcia committed
322 323
  (if size `(simple-array bit (,size)) '(simple-array bit (*))))

324 325 326
(deftype array-index ()
  '(integer 0 #.(1- array-dimension-limit)))

327 328 329 330
(deftype ext:virtual-stream ()
  '(or string-stream
    #+clos-streams gray:fundamental-stream))

331
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
332
;;                      TYPEP
333 334
;;************************************************************

jjgarcia's avatar
jjgarcia committed
335 336 337 338
(defun simple-array-p (x)
  (and (arrayp x)
       (not (adjustable-array-p x))
       (not (array-has-fill-pointer-p x))
339
       (not (array-displacement x))))
jjgarcia's avatar
jjgarcia committed
340

341 342 343
(defun complex-array-p (x)
  (and (arrayp x)
       (or (adjustable-array-p x)
Daniel Kochmański's avatar
Daniel Kochmański committed
344 345
           (array-has-fill-pointer-p x)
           (array-displacement x))))
346

347 348 349 350 351 352
(defun ratiop (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_ratio" :one-liner t)
  #+ecl-min
  (and (rationalp x) (not (integerp x))))

353 354 355 356 357 358 359 360
#+short-float
(defun short-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_shortfloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'short-float))

#-short-float
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
(defun short-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_singlefloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'single-float))

(defun single-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_singlefloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'single-float))

(defun double-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_doublefloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'double-float))

#+long-float
(defun long-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_longfloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'long-float))

#-long-float
(defun long-float-p (x)
  #-ecl-min
  (ffi::c-inline (x) (t) :bool "type_of(#0) == t_doublefloat" :one-liner t)
  #+ecl-min
  (eq (type-of x) 'double-float))

393 394 395 396 397 398 399 400 401 402 403 404
(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)
405
      (COMPLEX-ARRAY . COMPLEX-ARRAY-P)
406
      (CONS . CONSP)
407
      (DOUBLE-FLOAT . SI:DOUBLE-FLOAT-P)
408
      (FLOAT . FLOATP)
409
      (SI:FOREIGN-DATA . SI:FOREIGN-DATA-P)
410 411 412 413 414 415 416
      (FUNCTION . FUNCTIONP)
      (HASH-TABLE . HASH-TABLE-P)
      (INTEGER . INTEGERP)
      (FIXNUM . SI::FIXNUMP)
      (KEYWORD . KEYWORDP)
      (LIST . LISTP)
      (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
417
      (LONG-FLOAT . SI:LONG-FLOAT-P)
418 419 420 421
      (NIL . CONSTANTLY-NIL)
      (NULL . NULL)
      (NUMBER . NUMBERP)
      (PACKAGE . PACKAGEP)
422
      (RATIO . SI:RATIOP)
423 424 425 426 427
      (RANDOM-STATE . RANDOM-STATE-P)
      (RATIONAL . RATIONALP)
      (PATHNAME . PATHNAMEP)
      (READTABLE . READTABLEP)
      (REAL . REALP)
428
      (SHORT-FLOAT . SI:SHORT-FLOAT-P)
429 430 431
      (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
      (SIMPLE-STRING . SIMPLE-STRING-P)
      (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
432
      (SINGLE-FLOAT . SI:SINGLE-FLOAT-P)
433 434 435 436
      (STREAM . STREAMP)
      (STRING . STRINGP)
      (STRUCTURE . SYS:STRUCTUREP)
      (SYMBOL . SYMBOLP)
437
      #+sse2 (EXT:SSE-PACK . EXT:SSE-PACK-P)
438 439 440
      #+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)
441 442 443 444
      (T . CONSTANTLY-T)
      (VECTOR . VECTORP))))

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

447
(defconstant +upgraded-array-element-types+
448 449 450 451 452 453 454
  '#.(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)))
455

456
(defun upgraded-array-element-type (element-type &optional env)
457
  (declare (ignore env))
458
  (let* ((hash (logand 127 (si:hash-eql element-type)))
Daniel Kochmański's avatar
Daniel Kochmański committed
459
         (record (aref *upgraded-array-element-type-cache* hash)))
460 461
    (declare (type (integer 0 127) hash))
    (if (and record (eq (car record) element-type))
Daniel Kochmański's avatar
Daniel Kochmański committed
462 463 464 465 466 467 468 469 470 471
        (cdr record)
        (let ((answer (if (member element-type +upgraded-array-element-types+
                                  :test #'eq)
                          element-type
                          (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
472

473
(defun upgraded-complex-part-type (real-type &optional env)
474
  (declare (ignore env))
475 476
  ;; ECL does not have specialized complex types. If we had them, the
  ;; code would look as follows
477
  ;;   (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
Daniel Kochmański's avatar
Daniel Kochmański committed
478
  ;;       (error "~S is not a valid part type for a complex." real-type))
479 480 481 482 483
  ;;     (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)
484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503

(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)
504
  (declare (si::c-local))
505
  (error "~S is not a valid type specifier." type))
506

507 508 509 510
(defun match-dimensions (array pat)
  (declare (si::c-local))
  (or (eq pat '*)
      (let ((rank (array-rank array)))
Daniel Kochmański's avatar
Daniel Kochmański committed
511 512 513 514 515 516 517 518 519 520
        (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))))))
521

522
(defun typep (object type &optional env &aux tp i c)
523 524
  "Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
525
  (declare (ignore env))
jjgarcia's avatar
jjgarcia committed
526
  (cond ((symbolp type)
Daniel Kochmański's avatar
Daniel Kochmański committed
527 528 529 530 531 532 533 534 535 536
         (let ((f (get-sysprop type 'TYPE-PREDICATE)))
           (if f
               (return-from typep (funcall f object))
               (setq tp type i nil))))
        ((consp type)
         (setq tp (car type) i (cdr type)))
        ((sys:instancep type)
         (return-from typep (si::subclassp (class-of object) type)))
        (t
         (error-type-specifier type)))
jjgarcia's avatar
jjgarcia committed
537
  (case tp
538
    ((EQL MEMBER) (and (member object i) t))
jjgarcia's avatar
jjgarcia committed
539 540
    (NOT (not (typep object (car i))))
    (OR (dolist (e i)
Daniel Kochmański's avatar
Daniel Kochmański committed
541
          (when (typep object e) (return t))))
jjgarcia's avatar
jjgarcia committed
542
    (AND (dolist (e i t)
Daniel Kochmański's avatar
Daniel Kochmański committed
543
           (unless (typep object e) (return nil))))
jjgarcia's avatar
jjgarcia committed
544
    (SATISFIES (funcall (car i) object))
545
    ((T *) t)
jjgarcia's avatar
jjgarcia committed
546
    ((NIL) nil)
547
    (BIGNUM (and (integerp object) (not (si::fixnump object))))
jjgarcia's avatar
jjgarcia committed
548 549 550 551
    (STANDARD-CHAR
     (and (characterp object) (standard-char-p object)))
    (INTEGER
     (and (integerp object) (in-interval-p object i)))
552 553
    (RATIO
     (and (ratiop object) (in-interval-p object i)))
jjgarcia's avatar
jjgarcia committed
554 555 556 557 558 559
    (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)))
560 561 562
    (SHORT-FLOAT
     (and (si:short-float-p object) (in-interval-p object i)))
    (SINGLE-FLOAT
563
     (and (si:single-float-p object) (in-interval-p object i)))
564
    (DOUBLE-FLOAT
565
     (and (si:double-float-p object) (in-interval-p object i)))
566
    (LONG-FLOAT
567
     (and (si:long-float-p object) (in-interval-p object i)))
jjgarcia's avatar
jjgarcia committed
568 569 570
    (COMPLEX
     (and (complexp object)
          (or (null i)
Daniel Kochmański's avatar
Daniel Kochmański committed
571 572 573 574 575
              (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))))
           ))
jjgarcia's avatar
jjgarcia committed
576
    (SEQUENCE (or (listp object) (vectorp object)))
577
    (CONS (and (consp object)
Daniel Kochmański's avatar
Daniel Kochmański committed
578 579 580 581 582 583
               (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))))))
584
    (BASE-STRING
585 586 587
     (and (base-string-p object)
          (or (null i) (match-dimensions object i))))
    (STRING
588 589
     (and (stringp object)
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
590 591
    (BIT-VECTOR
     (and (bit-vector-p object)
592
          (or (null i) (match-dimensions object i))))
593
    (SIMPLE-BASE-STRING
594 595
     (and (base-string-p object)
          (simple-string-p object)
Daniel Kochmański's avatar
Daniel Kochmański committed
596
          (or (null i) (match-dimensions object i))))
597
    (SIMPLE-STRING
598
     (and (simple-string-p object)
599
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
600 601
    (SIMPLE-BIT-VECTOR
     (and (simple-bit-vector-p object)
602
          (or (null i) (match-dimensions object i))))
jjgarcia's avatar
jjgarcia committed
603 604
    (SIMPLE-VECTOR
     (and (simple-vector-p object)
605
          (or (null i) (match-dimensions object i))))
606 607 608
    (COMPLEX-ARRAY
     (and (complex-array-p object)
          (or (endp i) (eq (car i) '*)
Daniel Kochmański's avatar
Daniel Kochmański committed
609 610 611
              ;; (car i) needs expansion
              (eq (array-element-type object)
                  (upgraded-array-element-type (car i))))
612
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
613 614 615
    (SIMPLE-ARRAY
     (and (simple-array-p object)
          (or (endp i) (eq (car i) '*)
Daniel Kochmański's avatar
Daniel Kochmański committed
616 617 618
              ;; (car i) needs expansion
              (eq (array-element-type object)
                  (upgraded-array-element-type (car i))))
619
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
620 621 622 623 624 625
    (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)
Daniel Kochmański's avatar
Daniel Kochmański committed
626
                  (upgraded-array-element-type (car i))))
627
          (or (endp (cdr i)) (match-dimensions object (second i)))))
jjgarcia's avatar
jjgarcia committed
628
    (t
629
     (cond ((get-sysprop tp 'DEFTYPE-DEFINITION)
630
            (typep object (funcall (get-sysprop tp 'DEFTYPE-DEFINITION) i)))
Daniel Kochmański's avatar
Daniel Kochmański committed
631 632 633 634 635 636 637
           ((consp i)
            (error-type-specifier type))
           ((setq c (find-class type nil))
            ;; Follow the inheritance chain
            (si::subclassp (class-of object) c))
           (t
            (error-type-specifier type))))))
jjgarcia's avatar
jjgarcia committed
638

639
(defun subclassp (low high)
640
  (or (eq low high)
641
      (member high (sys:instance-ref low clos::+class-precedence-list-ndx+)
Daniel Kochmański's avatar
Daniel Kochmański committed
642
              :test #'eq))) ; (class-precedence-list low)
643

644 645 646
(defun of-class-p (object class)
  (declare (optimize (speed 3) (safety 0)))
  (macrolet ((class-precedence-list (x)
Daniel Kochmański's avatar
Daniel Kochmański committed
647 648 649
               `(si::instance-ref ,x clos::+class-precedence-list-ndx+))
             (class-name (x)
               `(si::instance-ref ,x clos::+class-name-ndx+)))
650 651 652
    (let* ((x-class (class-of object)))
      (declare (class x-class))
      (if (eq x-class class)
Daniel Kochmański's avatar
Daniel Kochmański committed
653 654 655 656 657 658 659 660
          t
          (let ((x-cpl (class-precedence-list x-class)))
            (if (instancep class)
                (member class x-cpl :test #'eq)
                (dolist (c x-cpl)
                  (declare (class c))
                  (when (eq (class-name c) class)
                    (return t)))))))))
661

662
#+(and clos ecl-min)
663 664 665
(defun clos::classp (foo)
  (declare (ignore foo))
  nil)
jjgarcia's avatar
jjgarcia committed
666

667
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
668
;;                      NORMALIZE-TYPE
669 670 671 672 673
;;************************************************************
;; 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
674 675 676
(defun normalize-type (type &aux tp i fd)
  ;; Loops until the car of type has no DEFTYPE definition.
  (cond ((symbolp type)
Daniel Kochmański's avatar
Daniel Kochmański committed
677
         (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))
678
           (normalize-type (funcall fd nil))
Daniel Kochmański's avatar
Daniel Kochmański committed
679 680 681 682 683 684 685
           (values type nil)))
        ((clos::classp type) (values type nil))
        ((atom type)
         (error-type-specifier type))
        ((progn
           (setq tp (car type) i (cdr type))
           (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION)))
686
         (normalize-type (funcall fd i)))
Daniel Kochmański's avatar
Daniel Kochmański committed
687 688 689
        ((and (eq tp 'INTEGER) (consp (cadr i)))
         (values tp (list (car i) (1- (caadr i)))))
        (t (values tp i))))
jjgarcia's avatar
jjgarcia committed
690

691
(defun expand-deftype (type)
692 693 694 695 696 697
  (let (base args)
    (if (atom type)
        (setf base type
              args nil)
        (setf base (car type)
              args (cdr type)))
698
    (let ((fn (get-sysprop base 'DEFTYPE-DEFINITION)))
699
      (if fn
700
          (expand-deftype (funcall fn args))
701
          type))))
jjgarcia's avatar
jjgarcia committed
702

703
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
704
;;                      COERCE
705
;;************************************************************
jjgarcia's avatar
jjgarcia committed
706

707
(defun coerce (object type &aux aux)
708 709 710
  "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
711
  (when (typep object type)
712 713
    ;; Just return as it is.
    (return-from coerce object))
714 715 716 717 718 719 720 721 722 723 724 725 726
  (flet ((fail ()
           (error "Cannot coerce ~S to type ~S." object type)))
    (let ((type (expand-deftype type)))
      (cond ((atom type)
             (case type
               ((T) object)
               (LIST
                (do ((io (make-seq-iterator object) (seq-iterator-next object io))
                     (l nil (cons (seq-iterator-ref object io) l)))
                    ((null io) l)))
               ((CHARACTER BASE-CHAR) (character object))
               (FLOAT (float object))
               (SHORT-FLOAT (float object 0.0S0))
727
               (SINGLE-FLOAT (float object 0.0F0))
728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
               (DOUBLE-FLOAT (float object 0.0D0))
               (LONG-FLOAT (float object 0.0L0))
               (COMPLEX (complex (realpart object) (imagpart object)))
               (FUNCTION (coerce-to-function object))
               ((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING
                        #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
                (concatenate type object))
               (t
                (if (or (listp object) (vectorp object))
                    (concatenate type object)
                    (fail)))))
            ((eq (setq aux (first type)) 'COMPLEX)
             (if type
                 (complex (coerce (realpart object) (second type))
                          (coerce (imagpart object) (second type)))
                 (complex (realpart object) (imagpart object))))
744
            ((member aux '(SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
745 746 747 748 749 750 751 752 753 754 755 756 757 758
             (setq aux (coerce object aux))
             (unless (typep aux type)
               (fail))
             aux)
            ((eq aux 'AND)
             (dolist (type (rest type))
               (setq aux (coerce aux type)))
             (unless (typep aux type)
               (fail))
             aux)
            ((or (listp object) (vectorp object))
             (concatenate type object))
            (t
             (fail))))))
759

760
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
761
;;                      SUBTYPEP
762 763 764 765 766 767 768 769
;;************************************************************
;;
;; 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
;;
Daniel Kochmański's avatar
Daniel Kochmański committed
770 771 772 773
;;      Built-in objects --- Hash tables, etc
;;      Intervals --- (INTEGER a b), (REAL a b), etc
;;      Arrays --- (ARRAY * (2)), etc
;;      Classes
774 775 776 777 778 779 780
;;
;; 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)
;;
Daniel Kochmański's avatar
Daniel Kochmański committed
781 782 783
;;      f((AND T1 T2)) = (LOGIAND f(T1) f(T2))
;;      f((OR T1 T2)) = (LOGIOR f(T1) f(T2))
;;      f((NOT T1)) = (LOGNOT f(T2))
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802
;;
;; 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
803
  '()
804 805 806 807 808 809 810 811 812 813
  #-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.
;;
814
(defun find-registered-tag (type &optional (test #'equal))
815
  (declare (si::c-local))
816 817
  (let* ((pos (assoc type *elementary-types* :test test)))
    (and pos (cdr pos))))
818 819 820 821 822 823 824 825

;; 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
Daniel Kochmański's avatar
Daniel Kochmański committed
826 827
          *elementary-types* (copy-tree *elementary-types*)
          *member-types* (copy-tree *member-types*))))
828 829 830 831 832 833 834

;; 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)
835
  (declare (ext:assume-no-errors))
836 837
  (maybe-save-types)
  (dolist (i *elementary-types*)
838 839
    (unless (zerop (logand (cdr i) type-mask))
      (setf (cdr i) (logior new-tag (cdr i))))))
840 841 842 843 844 845 846 847 848 849 850 851 852 853 854

;; 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)
855
  (declare (si::c-local)
856
           (optimize (safety 0))
Daniel Kochmański's avatar
Daniel Kochmański committed
857
           (function in-our-family-p type-<=)) 
858
  (let* ((subtype-tag 0)
Daniel Kochmański's avatar
Daniel Kochmański committed
859 860
         (disjoint-tag 0)
         (supertype-tag (if minimize-super -1 0)))
861
    (dolist (i *elementary-types*)
862
      (declare (cons i))
863
      (let ((other-type (car i))
Daniel Kochmański's avatar
Daniel Kochmański committed
864 865 866 867 868 869 870 871 872 873 874
            (other-tag (cdr i)))
        (when (funcall in-our-family-p other-type)
          (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)
                 (setq subtype-tag (logior other-tag subtype-tag)))
                (t
                 (setq disjoint-tag (logior disjoint-tag other-tag)))))))
875
    (values (if (= supertype-tag -1) 0
Daniel Kochmański's avatar
Daniel Kochmański committed
876 877
                (logandc2 supertype-tag (logior disjoint-tag subtype-tag)))
            subtype-tag)))
878 879 880 881 882 883 884 885 886 887

;; 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-<=)
888
  (declare (si::c-local)
889
           (optimize (safety 0))
Daniel Kochmański's avatar
Daniel Kochmański committed
890
           (function in-our-family-p type-<=))
891 892
  (or (find-registered-tag type)
      (multiple-value-bind (tag-super tag-sub)
Daniel Kochmański's avatar
Daniel Kochmański committed
893 894 895 896 897
          (find-type-bounds type in-our-family-p type-<= nil)
        (let ((tag (new-type-tag)))
          (update-types (logandc2 tag-super tag-sub) tag)
          (setf tag (logior tag tag-sub))
          (push-type type tag)))))
898 899 900

;;----------------------------------------------------------------------
;; MEMBER types. We register this object in a separate list, *MEMBER-TYPES*,
901 902
;; and tag all types to which it belongs. We need to treat three cases
;; separately
Daniel Kochmański's avatar
Daniel Kochmański committed
903 904 905 906 907 908
;;      - 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)))
909 910
;;
(defun register-member-type (object)
911
  ;(declare (si::c-local))
912
  (let ((pos (assoc object *member-types*)))
913
    (cond ((and pos (cdr pos)))
Daniel Kochmański's avatar
Daniel Kochmański committed
914 915 916 917 918 919 920 921 922 923 924
          ((not (realp object))
           (simple-member-type object))
          ((and (floatp object) (zerop object))
           #.(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))))))
          (t
           (number-member-type object)))))
925 926

(defun simple-member-type (object)
927
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
928
           (ext:assume-no-errors))
929 930 931 932 933
  (let* ((tag (new-type-tag)))
    (maybe-save-types)
    (setq *member-types* (acons object tag *member-types*))
    (dolist (i *elementary-types*)
      (let ((type (car i)))
Daniel Kochmański's avatar
Daniel Kochmański committed
934 935
        (when (typep object type)
          (setf (cdr i) (logior tag (cdr i))))))
936 937 938 939 940 941 942
    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)))
Daniel Kochmański's avatar
Daniel Kochmański committed
943
         (type (list base-type object object)))
944
    (or (find-registered-tag type)
Daniel Kochmański's avatar
Daniel Kochmański committed
945
        (register-interval-type type))))
946

947
(defun push-type (type tag)
948
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
949
           (ext:assume-no-errors))
950 951 952 953
  (dolist (i *member-types*)
    (declare (cons i))
    (when (typep (car i) type)
      (setq tag (logior tag (cdr i)))))
954 955
  (push (cons type tag) *elementary-types*)
  tag)
956

957 958 959 960 961
;;----------------------------------------------------------------------
;; 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)
962
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
963
           (ignore type))
964 965 966 967 968 969
  (throw '+canonical-type-failure+ 'satisfies))

;;----------------------------------------------------------------------
;; CLOS classes and structures.
;;
(defun register-class (class)
970
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
971
           (notinline class-name))
972 973 974 975
  (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)))
Daniel Kochmański's avatar
Daniel Kochmański committed
976 977 978 979
        (and name
             (eq class (find-class name 'nil))
             (or (find-registered-tag name)
                 (find-built-in-tag name))))
980 981
      (and (not (clos::class-finalized-p class))
           (throw '+canonical-type-failure+ nil))
982
      (register-type class
Daniel Kochmański's avatar
Daniel Kochmański committed
983 984 985 986 987 988 989
                     #'(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)))
                         (and c1 c2 (si::subclassp c1 c2))))))
990 991 992 993 994 995

;;----------------------------------------------------------------------
;; ARRAY types.
;;
(defun register-array-type (type)
  (declare (si::c-local))
996 997 998
  (multiple-value-bind (array-class elt-type dimensions)
      (parse-array-type type)
    (cond ((eq elt-type '*)
Daniel Kochmański's avatar
Daniel Kochmański committed
999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011
           (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-<=)))))
1012 1013 1014 1015 1016 1017 1018 1019 1020

;;
;; 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))
1021
  (cond ((eql type '*) '*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1022 1023 1024 1025 1026 1027
        ((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))))))
1028 1029 1030

;;
;; This canonicalizes the array type into the form
Daniel Kochmański's avatar
Daniel Kochmański committed
1031
;;      ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)})
1032 1033 1034 1035 1036 1037
;;
;; ELT-TYPE is the upgraded element type of the input.
;;
(defun parse-array-type (input)
  (declare (si::c-local))
  (let* ((type input)
Daniel Kochmański's avatar
Daniel Kochmański committed
1038 1039 1040
         (name (pop type))
         (elt-type (fast-upgraded-array-element-type (if type (pop type) '*)))
         (dims (if type (pop type) '*)))
1041 1042 1043
    (when type
      (error "Wrong array type designator ~S." input))
    (cond ((numberp dims)
Daniel Kochmański's avatar
Daniel Kochmański committed
1044 1045 1046 1047 1048 1049 1050 1051 1052
           (unless (< -1 dims array-rank-limit)
             (error "Wrong rank size array type ~S." input))
           (setq dims (nthcdr (- array-rank-limit dims)
                              '#.(make-list array-rank-limit :initial-element '*))))
          ((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)))))
1053
    (values name elt-type dims)))
1054 1055 1056 1057 1058 1059

;;
;; This function checks whether the array type T1 is a subtype of the array
;; type T2.
;;
(defun array-type-<= (t1 t2)
1060
  (unless (and (eq (first t1) (first t2))
Daniel Kochmański's avatar
Daniel Kochmański committed
1061
               (eq (second t1) (second t2)))
1062 1063
    (return-from array-type-<= nil))
  (let ((dim (third t1))
Daniel Kochmański's avatar
Daniel Kochmański committed
1064
        (pat (third t2)))
1065
    (cond ((eq pat '*) t)
Daniel Kochmański's avatar
Daniel Kochmański committed
1066 1067 1068 1069 1070 1071 1072 1073 1074
          ((eq dim '*) nil)
          (t (do ((a dim (cdr a))
                  (b pat (cdr b)))
                 ((or (endp a)
                      (endp b)
                      (not (or (eq (car b) '*)
                               (eql (car b) (car a)))))
                  (and (null a) (null b)))
               )))))
1075 1076 1077

(defun array-type-p (type)
  (and (consp type)
1078
       (member (first type) '(COMPLEX-ARRAY SIMPLE-ARRAY))))
1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092

;;----------------------------------------------------------------------
;; 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))
1093
  (or (find-registered-tag type #'equalp)
1094
      (multiple-value-bind (tag-super tag-sub)
Daniel Kochmański's avatar
Daniel Kochmański committed
1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106
          (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))
          (push-type type tag)))))
1107 1108 1109 1110

(defun register-interval-type (interval)
  (declare (si::c-local))
  (let* ((i interval)
Daniel Kochmański's avatar
Daniel Kochmański committed
1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132
         (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)))
1133
    (unless (eq high '*)
1134
      (push-type interval tag))
1135 1136 1137 1138
    tag))

;; All comparisons between intervals operations may be defined in terms of
;;
Daniel Kochmański's avatar
Daniel Kochmański committed
1139
;;      (BOUNDS-<= b1 b2)       and     (BOUNDS-< b1 b2)
1140 1141 1142 1143 1144 1145 1146
;;
;; 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)
Daniel Kochmański's avatar
Daniel Kochmański committed
1147 1148 1149 1150 1151 1152 1153 1154 1155
        ((eq b2 '*) nil)
        ((consp b1)
         (if (consp b2)
             (<= (first b1) (first b2))
             (< (first b1) b2)))
        ((consp b2)
         (<= b1 (first b2)))
        (t
         (<= b1 b2))))
1156 1157 1158

(defun bounds-< (b1 b2)
  (cond ((eq b1 '*) (not (eq b2 '*)))
Daniel Kochmański's avatar
Daniel Kochmański committed
1159 1160 1161 1162 1163 1164 1165 1166 1167
        ((eq b2 '*) nil)
        ((consp b1)
         (if (consp b2)
             (< (first b1) (first b2))
             (< (first b1) b2)))
        ((consp b2)
         (<= b1 (first b2)))
        (t
         (< b1 b2))))
1168 1169 1170 1171 1172 1173 1174 1175 1176

;;----------------------------------------------------------------------
;; 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))
1177 1178 1179 1180 1181 1182
  ;; 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)))
Daniel Kochmański's avatar
Daniel Kochmański committed
1183
        (push-type '(COMPLEX REAL) tag)))
1184
  #+(or)
1185
  (case real-type
1186 1187 1188 1189 1190 1191
    ((#+short-float SHORT-FLOAT
      SINGLE-FLOAT
      DOUBLE-FLOAT
      INTEGER
      RATIO
      #+long-float LONG-FLOAT)
1192
     (let ((tag (new-type-tag)))
1193
       (push-type `(COMPLEX ,real-type) tag)))
1194
    ((RATIONAL) (canonical-type '(OR (COMPLEX INTEGER) (COMPLEX RATIO))))
1195 1196 1197 1198
    ((FLOAT) (canonical-type '(OR
                               #+short-float (COMPLEX SHORT-FLOAT)
                               (COMPLEX SINGLE-FLOAT)
                               (COMPLEX DOUBLE-FLOAT)
Daniel Kochmański's avatar
Daniel Kochmański committed
1199
                               #+long-float (COMPLEX LONG-FLOAT))))
1200
    ((* NIL REAL) (canonical-type
Daniel Kochmański's avatar
Daniel Kochmański committed
1201
                   '(OR (COMPLEX INTEGER) (COMPLEX RATIO)
1202 1203 1204
                     #+short-float (COMPLEX SHORT-FLOAT)
                     (COMPLEX SINGLE-FLOAT)
                     (COMPLEX DOUBLE-FLOAT)
Daniel Kochmański's avatar
Daniel Kochmański committed
1205 1206
                     #+long-float (COMPLEX LONG-FLOAT)
                     )))
1207
    (otherwise (canonical-complex-type (upgraded-complex-part-type real-type)))))
1208

1209 1210 1211 1212 1213
;;----------------------------------------------------------------------
;; 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 '*))
1214 1215 1216 1217
  ;; 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)
1218
  (canonical-type 'CONS)
1219
  (let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
Daniel Kochmański's avatar
Daniel Kochmański committed
1220
        (cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
1221
    (cond ((or (zerop car-tag) (zerop cdr-tag))
Daniel Kochmański's avatar
Daniel Kochmański committed
1222 1223 1224 1225 1226
           0)
          ((and (= car-tag -1) (= cdr-tag -1))
           (canonical-type 'CONS))
          (t
           (throw '+canonical-type-failure+ 'CONS)))))
1227

1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244
;;----------------------------------------------------------------------
;; 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
1245
(defconstant +built-in-type-list+
Daniel Kochmański's avatar
Daniel Kochmański committed
1246 1247 1248 1249 1250 1251 1252 1253 1254
             '((SYMBOL)
               (KEYWORD NIL SYMBOL)
               (PACKAGE)
               (COMPILED-FUNCTION)
               (FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION))

               (INTEGER (INTEGER * *))
               (FIXNUM (INTEGER #.most-negative-fixnum #.most-positive-fixnum))
               (BIGNUM (OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
1255 1256
               #+short-float
               (SHORT-FLOAT (SHORT-FLOAT * *))
Daniel Kochmański's avatar
Daniel Kochmański committed
1257 1258 1259 1260 1261 1262 1263
               (SINGLE-FLOAT (SINGLE-FLOAT * *))
               (DOUBLE-FLOAT (DOUBLE-FLOAT * *))
               #+long-float
               (LONG-FLOAT (LONG-FLOAT * *))
               (RATIO (RATIO * *))

               (RATIONAL (OR INTEGER RATIO))
1264 1265 1266 1267
               (FLOAT (OR
                       #+short-float SHORT-FLOAT
                       SINGLE-FLOAT
                       DOUBLE-FLOAT
1268
                       #+long-float LONG-FLOAT))
1269 1270 1271 1272 1273 1274
               (REAL (OR INTEGER
                      #+short-float SHORT-FLOAT
                      SINGLE-FLOAT
                      DOUBLE-FLOAT
                      #+long-float LONG-FLOAT
                      RATIO))
Daniel Kochmański's avatar
Daniel Kochmański committed
1275
               (COMPLEX (COMPLEX REAL))
1276

Daniel Kochmański's avatar
Daniel Kochmański committed
1277
               (NUMBER (OR REAL COMPLEX))
1278

Daniel Kochmański's avatar
Daniel Kochmański committed
1279
               (CHARACTER)
1280
               #-unicode
Daniel Kochmański's avatar
Daniel Kochmański committed
1281
               (BASE-CHAR CHARACTER)
1282
               #+unicode
Daniel Kochmański's avatar
Daniel Kochmański committed
1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295
               (BASE-CHAR NIL CHARACTER)
               (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 (*)))
1296
               #+unicode
Daniel Kochmański's avatar
Daniel Kochmański committed
1297 1298
               (BASE-STRING (ARRAY BASE-CHAR (*)))
               (SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*)))
1299
               #+unicode
Daniel Kochmański's avatar
Daniel Kochmański committed
1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317
               (SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*)))
               (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)
               (EXT:SEQUENCE-STREAM)
               (EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM
1318
                                 FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM
1319 1320 1321 1322
                                 EXT:SEQUENCE-STREAM))
               #+clos-streams (GRAY:FUNDAMENTAL-STREAM)
               (STREAM (OR EXT:ANSI-STREAM
                        #+clos-streams GRAY:FUNDAMENTAL-STREAM))
1323
               (EXT:VIRTUAL-STREAM (OR STRING-STREAM #+clos-streams GRAY:FUNDAMENTAL-STREAM))
1324

Daniel Kochmański's avatar
Daniel Kochmański committed
1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339
               (READTABLE)
               #+threads (MP::PROCESS)
               #+threads (MP::LOCK)
               #+threads (MP::RWLOCK)
               #+threads (MP::CONDITION-VARIABLE)
               #+threads (MP::SEMAPHORE)
               #+threads (MP::BARRIER)
               #+threads (MP::MAILBOX)
               #+ffi (FOREIGN-DATA)
               #+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)
1340
               (CODE-BLOCK)
Daniel Kochmański's avatar
Daniel Kochmański committed
1341
               ))
1342

1343 1344 1345 1346 1347
(defconstant +built-in-types+
  (ext:hash-table-fill
     (make-hash-table :test 'eq :size 128)
     '#.+built-in-type-list+))

1348
(defun find-built-in-tag (name)
1349
  (declare (si::c-local))
1350 1351
  (let (record)
    (cond ((eq name T)
Daniel Kochmański's avatar
Daniel Kochmański committed
1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366
           -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))))
             (push-type name tag))))))
1367 1368

(defun extend-type-tag (tag minimal-supertype-tag)
1369
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
1370
           (ext:assume-no-errors))
1371 1372 1373
  (dolist (type *elementary-types*)
    (let ((other-tag (cdr type)))
      (when (zerop (logandc2 minimal-supertype-tag other-tag))
Daniel Kochmański's avatar
Daniel Kochmański committed
1374
        (setf (cdr type) (logior tag other-tag))))))
1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385

;;----------------------------------------------------------------------
;; 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*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1386 1387 1388
        (*save-types-database* t)
        (*member-types* *member-types*)
        (*elementary-types* *elementary-types*))
1389
    (let ((tag (canonical-type type))
Daniel Kochmański's avatar
Daniel Kochmański committed
1390
          (out))
1391 1392 1393 1394
      (setq tag (canonical-type type))
      ;;(print-types-database *elementary-types*)
      ;;(print-types-database *member-types*)
      (dolist (i *member-types*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1395 1396
        (unless (zerop (logand (cdr i) tag))
          (push (car i) out)))
1397
      (when out
Daniel Kochmański's avatar
Daniel Kochmański committed
1398
        (setq out `((MEMBER ,@out))))
1399
      (dolist (i *elementary-types*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1400 1401 1402 1403
        (unless (zerop (logand (cdr i) tag))
          ;;(print (list tag (cdr i) (logand tag (cdr i))))
          (push (car i) out)))
        (values tag `(OR ,@out)))))
1404

1405 1406 1407 1408 1409 1410 1411 1412 1413
;;----------------------------------------------------------------------
;; (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)
1414
  (declare (notinline clos::classp))
1415
  (cond ((find-registered-tag type))
Daniel Kochmański's avatar
Daniel Kochmański committed
1416 1417
        ((eq type 'T) -1)
        ((eq type 'NIL) 0)
1418
        ((symbolp type)
Daniel Kochmański's avatar
Daniel Kochmański committed
1419 1420
         (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION)))
           (cond (expander
1421
                  (canonical-type (funcall expander nil)))
Daniel Kochmański's avatar
Daniel Kochmański committed
1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433
                 ((find-built-in-tag type))
                 (t (let ((class (find-class type nil)))
                      (if class
                          (register-class class)
                          (throw '+canonical-type-failure+ nil)))))))
        ((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))
1434 1435 1436 1437 1438
           ((INTEGER #+short-float SHORT-FLOAT
                     SINGLE-FLOAT
                     DOUBLE-FLOAT
                     RATIO
                     #+long-float LONG-FLOAT)
Daniel Kochmański's avatar
Daniel Kochmański committed
1439 1440
            (register-interval-type type))
           ((FLOAT)
1441 1442 1443
            (canonical-type `(OR #+short-float
                                 (SHORT-FLOAT ,@(rest type))
                                 (SINGLE-FLOAT ,@(rest type))
Daniel Kochmański's avatar
Daniel Kochmański committed
1444 1445 1446 1447 1448 1449
                                 (DOUBLE-FLOAT ,@(rest type))
                                 #+long-float
                                 (LONG-FLOAT ,@(rest type)))))
           ((REAL)
            (canonical-type `(OR (INTEGER ,@(rest type))
                                 (RATIO ,@(rest type))
1450 1451
                                 #+short-float
                                 (SHORT-FLOAT ,@(rest type))
Daniel Kochmański's avatar
Daniel Kochmański committed
1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470
                                 (SINGLE-FLOAT ,@(rest type))
                                 (DOUBLE-FLOAT ,@(rest type))
                                 #+long-float
                                 (LONG-FLOAT ,@(rest type)))))
           ((RATIONAL)
            (canonical-type `(OR (INTEGER ,@(rest type))
                                 (RATIO ,@(rest type)))))
           (COMPLEX
            (or (find-built-in-tag type)
                (canonical-complex-type (second type))))
           (CONS (apply #'register-cons-type (rest type)))
           (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type)))
                          (register-array-type `(SIMPLE-ARRAY ,@(rest type)))))
           ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type))
           ;;(FUNCTION (register-function-type type))
           ;;(VALUES (register-values-type type))
           (FUNCTION (canonical-type 'FUNCTION))
           (t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
                (if expander
1471
                    (canonical-type (funcall expander (rest type)))
Daniel Kochmański's avatar
Daniel Kochmański committed
1472 1473 1474 1475 1476 1477 1478 1479 1480 1481
                    (unless (assoc (first type) *elementary-types*)
                      (throw '+canonical-type-failure+ nil)))))))
        ((clos::classp type)
         (register-class type))
        ((and (fboundp 'function-type-p) (function-type-p type))
         (register-function-type type))
        ((and (fboundp 'values-type-p) (values-type-p type))
         (register-values-type type))
        (t
         (error-type-specifier type))))
1482 1483 1484 1485 1486

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

1487
(defun fast-subtypep (t1 t2)
1488
  (declare (si::c-local))
1489
  (when (eq t1 t2)
1490 1491
    (return-from fast-subtypep (values t t)))
  (let* ((tag1 (safe-canonical-type t1))
Daniel Kochmański's avatar
Daniel Kochmański committed
1492
         (tag2 (safe-canonical-type t2)))
1493
    (cond ((and (numberp tag1) (numberp tag2))
Daniel Kochmański's avatar
Daniel Kochmański committed
1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504
           (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)))))
1505

1506
(defun subtypep (t1 t2 &optional env)
1507
  (declare (ignore env))
1508
  ;; One easy case: types are equal
1509 1510
  (when (eq t1 t2)
    (return-from subtypep (values t t)))
1511 1512
  ;; Another easy case: types are classes.
  (when (and (instancep t1) (instancep t2)
Daniel Kochmański's avatar
Daniel Kochmański committed
1513
             (clos::classp t1) (clos::classp t2))
1514
    (return-from subtypep (values (subclassp t1 t2) t)))
1515 1516
  ;; Finally, cached results.
  (let* ((cache *subtypep-cache*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1517 1518
         (hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255)))
         (elt (aref cache hash)))
1519 1520 1521 1522
    (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*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1523 1524 1525
           (*save-types-database* t)
           (*member-types* *member-types*)
           (*elementary-types* *elementary-types*))
1526
      (multiple-value-bind (test confident)
Daniel Kochmański's avatar
Daniel Kochmański committed
1527 1528 1529
          (fast-subtypep t1 t2)
        (setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
        (values test confident)))))
1530 1531 1532 1533 1534 1535

(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))
Daniel Kochmański's avatar
Daniel Kochmański committed
1536
         (tag2 (safe-canonical-type t2)))
1537
    (cond ((and (numberp tag1) (numberp tag2))
Daniel Kochmański's avatar
Daniel Kochmański committed
1538 1539 1540 1541 1542 1543 1544 1545 1546 1547
           (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)))))
1548 1549 1550

(defun type= (t1 t2)
  (let ((*highest-type-tag* *highest-type-tag*)
Daniel Kochmański's avatar
Daniel Kochmański committed
1551 1552 1553
        (*save-types-database* t)
        (*member-types* *member-types*)
        (*elementary-types* *elementary-types*))
1554
    (fast-type= t1 t2)))