predlib.lsp 58.3 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 50 51 52

(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)
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 139
  "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."
140
  '(INTEGER #.most-negative-fixnum #.most-positive-fixnum))
141 142
(deftype bignum ()
  '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
143

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

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

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

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

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

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

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

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

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

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

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

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

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

(deftype vector (&optional (element-type '*) (size '*))
253 254
  "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
255
        #(elem ... elem)
256 257
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
258
  `(array ,element-type (,size)))
259

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

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

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

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

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

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

jjgarcia's avatar
jjgarcia committed
303
(deftype simple-string (&optional size)
304 305
  "A simple-string is a string that is not displaced to another array, has no
fill-pointer, and is not adjustable."
306 307 308 309 310 311 312
  #-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
313
           (simple-array character (,size)))
314
      '(or (simple-array base-char (*)) (simple-array character (*)))))
315

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

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

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

328
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
329
;;                      TYPEP
330 331
;;************************************************************

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

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

344 345 346 347 348 349
(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))))

350 351 352 353 354 355 356 357
#+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
358 359 360 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
(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))

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

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

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

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

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

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

504 505 506 507
(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
508 509 510 511 512 513 514 515 516 517
        (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))))))
518

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

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

641 642 643
(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
644 645 646
               `(si::instance-ref ,x clos::+class-precedence-list-ndx+))
             (class-name (x)
               `(si::instance-ref ,x clos::+class-name-ndx+)))
647 648 649
    (let* ((x-class (class-of object)))
      (declare (class x-class))
      (if (eq x-class class)
Daniel Kochmański's avatar
Daniel Kochmański committed
650 651 652 653 654 655 656 657
          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)))))))))
658

659
#+(and clos ecl-min)
660 661 662
(defun clos::classp (foo)
  (declare (ignore foo))
  nil)
jjgarcia's avatar
jjgarcia committed
663

664
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
665
;;                      NORMALIZE-TYPE
666 667 668 669 670
;;************************************************************
;; 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
671 672 673
(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
674
         (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))
675
           (normalize-type (funcall fd nil))
Daniel Kochmański's avatar
Daniel Kochmański committed
676 677 678 679 680 681 682
           (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)))
683
         (normalize-type (funcall fd i)))
Daniel Kochmański's avatar
Daniel Kochmański committed
684 685 686
        ((and (eq tp 'INTEGER) (consp (cadr i)))
         (values tp (list (car i) (1- (caadr i)))))
        (t (values tp i))))
jjgarcia's avatar
jjgarcia committed
687

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

700
;;************************************************************
Daniel Kochmański's avatar
Daniel Kochmański committed
701
;;                      COERCE
702
;;************************************************************
jjgarcia's avatar
jjgarcia committed
703

704
(defun coerce (object type &aux aux)
705 706 707
  "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
708
  (when (typep object type)
709 710
    ;; Just return as it is.
    (return-from coerce object))
711 712 713 714 715 716 717 718 719 720 721 722 723
  (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))
724
               (SINGLE-FLOAT (float object 0.0F0))
725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
               (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))))
741
            ((member aux '(SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
742 743 744 745 746 747 748 749 750 751 752 753 754 755
             (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))))))
756

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

;; 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
823 824
          *elementary-types* (copy-tree *elementary-types*)
          *member-types* (copy-tree *member-types*))))
825 826 827 828 829 830 831

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

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

;; 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-<=)
885
  (declare (si::c-local)
886
           (optimize (safety 0))
Daniel Kochmański's avatar
Daniel Kochmański committed
887
           (function in-our-family-p type-<=))
888 889
  (or (find-registered-tag type)
      (multiple-value-bind (tag-super tag-sub)
Daniel Kochmański's avatar
Daniel Kochmański committed
890 891 892 893 894
          (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)))))
895 896 897

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

(defun simple-member-type (object)
924
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
925
           (ext:assume-no-errors))
926 927 928 929 930
  (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
931 932
        (when (typep object type)
          (setf (cdr i) (logior tag (cdr i))))))
933 934 935 936 937 938 939
    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
940
         (type (list base-type object object)))
941
    (or (find-registered-tag type)
Daniel Kochmański's avatar
Daniel Kochmański committed
942
        (register-interval-type type))))
943

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

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

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

;;----------------------------------------------------------------------
;; ARRAY types.
;;
(defun register-array-type (type)
  (declare (si::c-local))
993 994 995
  (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
996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008
           (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-<=)))))
1009 1010 1011 1012 1013 1014 1015 1016 1017

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

;;
;; This canonicalizes the array type into the form
Daniel Kochmański's avatar
Daniel Kochmański committed
1028
;;      ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)})
1029 1030 1031 1032 1033 1034
;;
;; 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
1035 1036 1037
         (name (pop type))
         (elt-type (fast-upgraded-array-element-type (if type (pop type) '*)))
         (dims (if type (pop type) '*)))
1038 1039 1040
    (when type
      (error "Wrong array type designator ~S." input))
    (cond ((numberp dims)
Daniel Kochmański's avatar
Daniel Kochmański committed
1041 1042 1043 1044 1045 1046 1047 1048 1049
           (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)))))
1050
    (values name elt-type dims)))
1051 1052 1053 1054 1055 1056

;;
;; This function checks whether the array type T1 is a subtype of the array
;; type T2.
;;
(defun array-type-<= (t1 t2)
1057
  (unless (and (eq (first t1) (first t2))
Daniel Kochmański's avatar
Daniel Kochmański committed
1058
               (eq (second t1) (second t2)))
1059 1060
    (return-from array-type-<= nil))
  (let ((dim (third t1))
Daniel Kochmański's avatar
Daniel Kochmański committed
1061
        (pat (third t2)))
1062
    (cond ((eq pat '*) t)
Daniel Kochmański's avatar
Daniel Kochmański committed
1063 1064 1065 1066 1067 1068 1069 1070 1071
          ((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)))
               )))))
1072 1073 1074

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

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

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

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

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

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

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

1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241
;;----------------------------------------------------------------------
;; 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
1242
(defconstant +built-in-type-list+
Daniel Kochmański's avatar
Daniel Kochmański committed
1243 1244 1245 1246 1247 1248 1249 1250 1251
             '((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) *)))
1252 1253
               #+short-float
               (SHORT-FLOAT (SHORT-FLOAT * *))
Daniel Kochmański's avatar
Daniel Kochmański committed
1254 1255 1256 1257 1258 1259 1260
               (SINGLE-FLOAT (SINGLE-FLOAT * *))
               (DOUBLE-FLOAT (DOUBLE-FLOAT * *))
               #+long-float
               (LONG-FLOAT (LONG-FLOAT * *))
               (RATIO (RATIO * *))

               (RATIONAL (OR INTEGER RATIO))
1261 1262 1263 1264
               (FLOAT (OR
                       #+short-float SHORT-FLOAT
                       SINGLE-FLOAT
                       DOUBLE-FLOAT
1265
                       #+long-float LONG-FLOAT))
1266 1267 1268 1269 1270 1271
               (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
1272
               (COMPLEX (COMPLEX REAL))
1273

Daniel Kochmański's avatar
Daniel Kochmański committed
1274
               (NUMBER (OR REAL COMPLEX))
1275

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

Daniel Kochmański's avatar
Daniel Kochmański committed
1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334
               (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)
1335
               (CODE-BLOCK)
Daniel Kochmański's avatar
Daniel Kochmański committed
1336
               ))
1337

1338 1339 1340 1341 1342
(defconstant +built-in-types+
  (ext:hash-table-fill
     (make-hash-table :test 'eq :size 128)
     '#.+built-in-type-list+))

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

(defun extend-type-tag (tag minimal-supertype-tag)
1364
  (declare (si::c-local)
Daniel Kochmański's avatar
Daniel Kochmański committed
1365
           (ext:assume-no-errors))
1366 1367 1368
  (dolist (type *elementary-types*)