source: trunk/source/level-1/l1-typesys.lisp @ 8524

Last change on this file since 8524 was 8524, checked in by gz, 12 years ago

Fix ticket#245

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 146.2 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; This is a hacked-up version of the CMU CL type system.
18
19(in-package "CCL")
20
21
22
23;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
24;;; compiler warnings can be emitted as appropriate.
25;;;
26(define-condition parse-unknown-type (condition)
27  ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
28
29(defun parse-lambda-list (list)
30  (let* ((required)
31         (optional)
32         (keys)
33         (aux))
34    (let ((restp nil)
35          (rest nil)
36          (keyp nil)
37          (allowp nil)
38          (state :required))
39      (dolist (arg list)
40        (if (and (symbolp arg)
41                 (let ((name (symbol-name arg)))
42                   (and (/= (length name) 0)
43                        (char= (char name 0) #\&))))
44          (case arg
45            (&optional
46             (unless (eq state :required)
47               (error "Misplaced &optional in lambda-list: ~S." list))
48             (setq state '&optional))
49            (&rest
50             (unless (member state '(:required &optional))
51               (error "Misplaced &rest in lambda-list: ~S." list))
52             (setq state '&rest))
53            (&key
54             (unless (member state '(:required &optional :post-rest
55                                     ))
56               (error "Misplaced &key in lambda-list: ~S." list))
57             (setq keyp t)
58             (setq state '&key))
59            (&allow-other-keys
60             (unless (eq state '&key)
61               (error "Misplaced &allow-other-keys in lambda-list: ~S." list))
62             (setq allowp t  state '&allow-other-keys))
63            (&aux
64             (when (member state '(&rest))
65               (error "Misplaced &aux in lambda-list: ~S." list))
66             (setq state '&aux))
67            (t
68             (error "Unknown &keyword in lambda-list: ~S." arg)))
69          (case state
70            (:required (push arg required))
71            (&optional (push arg optional))
72            (&rest
73             (setq restp t  rest arg  state :post-rest))
74            (&key (push arg keys))
75            (&aux (push arg aux))
76            (t
77             (error "Found garbage in lambda-list when expecting a keyword: ~S." arg)))))
78     
79      (values (nreverse required) (nreverse optional) restp rest keyp (nreverse keys) allowp (nreverse aux)))))
80
81(defvar %deftype-expanders% (make-hash-table :test #'eq))
82(defvar *type-translators* (make-hash-table :test #'eq))
83(defvar *builtin-type-info* (make-hash-table :test #'equal))
84(defvar %builtin-type-cells% (make-hash-table :test 'equal))
85
86(defvar *use-implementation-types* t)
87
88(defun info-type-builtin (name)
89  (gethash name *builtin-type-info*))
90
91(defun (setf info-type-builtin) (val name)
92  (setf (gethash name *builtin-type-info*) val))
93
94(defun info-type-translator (name)
95  (gethash name *type-translators*))
96
97
98
99
100;;; Allow bootstrapping: mostly, allow us to bootstrap the type system
101;;; by having DEFTYPE expanders defined on built-in classes (the user
102;;; shouldn't be allowed to do so, at least not easily.
103
104;(defvar *type-system-initialized* nil)
105
106(defun %deftype (name fn doc)
107  (clear-type-cache)
108  (cond ((null fn)
109         (remhash name %deftype-expanders%))
110        ((and *type-system-initialized*
111              (or (built-in-type-p name) (find-class name nil)))
112         (error "Cannot redefine type ~S" name))
113        (t (setf (gethash name %deftype-expanders%) fn)
114           (record-source-file name 'type)))
115  (set-documentation name 'type doc)   ; nil clears it.
116  name)
117
118(defun %define-type-translator (name fn doc)
119  (declare (ignore doc))
120  (setf (gethash name *type-translators*) fn)
121  name)
122
123;;;(defun %deftype-expander (name)
124;;;  (or (gethash name %deftype-expanders%)
125;;;      (and *compiling-file* (%cdr (assq name *compile-time-deftype-expanders*)))))
126(defun %deftype-expander (name)
127  (gethash name %deftype-expanders%))
128
129(defun process-deftype-arglist (arglist &aux (in-optional? nil))
130  "Returns a NEW list similar to arglist except
131    inserts * as the default default for &optional args."
132  (mapcar #'(lambda (item)
133              (cond ((eq item '&optional) (setq in-optional? t) item)
134                    ((memq item lambda-list-keywords) (setq in-optional? nil) item)
135                    ((and in-optional? (symbolp item)) (list item ''*))
136                    (t item)))
137          arglist))
138
139
140(defun expand-type-macro (definer name arglist body env)
141  (setq name (require-type name 'symbol))
142  (multiple-value-bind (lambda doc)
143      (parse-macro-internal name arglist body env '*)
144      `(eval-when (:compile-toplevel :load-toplevel :execute)
145         (,definer ',name
146                   (nfunction ,name ,lambda)
147                   ,doc))))
148
149(defmacro deftype (name arglist &body body &environment env)
150  "Define a new type, with syntax like DEFMACRO."
151  (expand-type-macro '%deftype name arglist body env))
152
153(defmacro def-type-translator (name arglist &body body &environment env)
154  (expand-type-macro '%define-type-translator name arglist body env))
155
156
157(defun type-expand (form &optional env &aux def)
158  (while (setq def (cond ((symbolp form)
159                          (gethash form %deftype-expanders%))
160                         ((and (consp form) (symbolp (%car form)))
161                          (gethash (%car form) %deftype-expanders%))
162                         (t nil)))
163    (setq form (funcall def (if (consp form) form (list form)) env)))
164  form)
165
166(defmethod print-object ((tc type-class) stream)
167  (print-unreadable-object (tc stream :type t :identity t)
168    (format stream "~s" (type-class-name tc))))
169
170(defmethod print-object ((c ctype) stream)
171  (print-unreadable-object (c stream :type t)
172    (format stream "~S" (type-specifier c))))
173
174(defmethod make-load-form ((c ctype) &optional env)
175  (declare (ignore env))
176  `(specifier-type ',(type-specifier c)))
177
178
179(defun make-key-info (&key name type)
180  (%istruct 'key-info name type))
181
182(defun type-class-or-lose (name)
183  (or (cdr (assq name *type-classes*))
184      (error "~S is not a defined type class." name)))
185
186(eval-when (:compile-toplevel :execute)
187
188(defconstant type-class-function-slots
189  '((:simple-subtypep . #.type-class-simple-subtypep)
190    (:complex-subtypep-arg1 . #.type-class-complex-subtypep-arg1)
191    (:complex-subtypep-arg2 . #.type-class-complex-subtypep-arg2)
192    (:simple-union . #.type-class-simple-union)
193    (:complex-union . #.type-class-complex-union)
194    (:simple-intersection . #.type-class-simple-intersection)
195    (:complex-intersection . #.type-class-complex-intersection)
196    (:simple-= . #.type-class-simple-=)
197    (:complex-= . #.type-class-complex-=)
198    (:unparse . #.type-class-unparse)))
199
200)
201
202(defun class-typep (form class)
203  (memq class (%inited-class-cpl (class-of form))))
204
205;;; CLASS-FUNCTION-SLOT-OR-LOSE  --  Interface
206;;;
207(defun class-function-slot-or-lose (name)
208  (or (cdr (assoc name type-class-function-slots))
209      (error "~S is not a defined type class method." name)))
210
211
212(eval-when (:compile-toplevel :execute)
213
214;;; INVOKE-TYPE-METHOD  --  Interface
215;;;
216;;;    Invoke a type method on TYPE1 and TYPE2.  If the two types have the same
217;;; class, invoke the simple method.  Otherwise, invoke any complex method.  If
218;;; there isn't a distinct complex-arg1 method, then swap the arguments when
219;;; calling type1's method.  If no applicable method, return DEFAULT.
220;;;
221
222(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key
223                                     (default '(values nil t))
224                                     complex-arg1)
225  (let ((simple (class-function-slot-or-lose simple))
226        (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2)))
227        (cslot2 (class-function-slot-or-lose complex-arg2)))
228    (once-only ((n-type1 type1)
229                (n-type2 type2))
230      (once-only ((class1 `(ctype-class-info ,n-type1))
231                  (class2 `(ctype-class-info ,n-type2)))
232        `(if (eq ,class1 ,class2)
233           (funcall (%svref ,class1 ,simple) ,n-type1 ,n-type2)
234           ,(once-only ((complex1 `(%svref ,class1 ,cslot1))
235                        (complex2 `(%svref ,class2 ,cslot2)))
236              `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2))
237                     (,complex1
238                      ,(if complex-arg1
239                         `(funcall ,complex1 ,n-type1 ,n-type2)
240                         `(funcall ,complex1 ,n-type2 ,n-type1)))
241                     (t ,default))))))))
242
243
244;;;; Utilities:
245
246;;; ANY-TYPE-OP, EVERY-TYPE-OP  --  Interface
247;;;
248;;;    Like ANY and EVERY, except that we handle two-arg uncertain predicates.
249;;; If the result is uncertain, then we return Default from the block PUNT.
250;;; If LIST-FIRST is true, then the list element is the first arg, otherwise
251;;; the second.
252;;;
253(defmacro any-type-op (op thing list &key (default '(values nil nil))
254                                list-first)
255  (let ((n-this (gensym))
256          (n-thing (gensym))
257          (n-val (gensym))
258          (n-win (gensym))
259          (n-uncertain (gensym)))
260    `(let ((,n-thing ,thing)
261             (,n-uncertain nil))
262       (dolist (,n-this ,list
263                              (if ,n-uncertain
264                                (return-from PUNT ,default)
265                                nil))
266           (multiple-value-bind (,n-val ,n-win)
267                                    ,(if list-first
268                                         `(,op ,n-this ,n-thing)
269                                         `(,op ,n-thing ,n-this))
270             (unless ,n-win (setq ,n-uncertain t))
271             (when ,n-val (return t)))))))
272;;;
273(defmacro every-type-op (op thing list &key (default '(values nil nil))
274                                  list-first)
275  (let ((n-this (gensym))
276          (n-thing (gensym))
277          (n-val (gensym))
278          (n-win (gensym)))
279    `(let ((,n-thing ,thing))
280       (dolist (,n-this ,list t)
281           (multiple-value-bind (,n-val ,n-win)
282                                    ,(if list-first
283                                         `(,op ,n-this ,n-thing)
284                                         `(,op ,n-thing ,n-this))
285             (unless ,n-win (return-from PUNT ,default))
286             (unless ,n-val (return nil)))))))
287
288)
289
290 
291;;; VANILLA-INTERSECTION  --  Interface
292;;;
293;;;    Compute the intersection for types that intersect only when one is a
294;;; hierarchical subtype of the other.
295;;;
296(defun vanilla-intersection (type1 type2)
297  (multiple-value-bind (stp1 win1)
298                           (csubtypep type1 type2)
299    (multiple-value-bind (stp2 win2)
300                               (csubtypep type2 type1)
301      (cond (stp1 (values type1 t))
302              (stp2 (values type2 t))
303              ((and win1 win2) (values *empty-type* t))
304              (t
305               (values type1 nil))))))
306
307
308;;; VANILLA-UNION  --  Interface
309;;;
310(defun vanilla-union (type1 type2)
311  (cond ((csubtypep type1 type2) type2)
312        ((csubtypep type2 type1) type1)
313        (t nil)))
314
315(defun hierarchical-intersection2 (type1 type2)
316  (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
317    (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
318      (cond (subtypep1 type1)
319            (subtypep2 type2)
320            ((and win1 win2) *empty-type*)
321            (t nil)))))
322
323(defun hierarchical-union2 (type1 type2)
324  (cond ((csubtypep type1 type2) type2)
325        ((csubtypep type2 type1) type1)
326        (t nil)))
327
328;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION}  --  Interface
329;;;
330;;;    These functions are used as method for types which need a complex
331;;; subtypep method to handle some superclasses, but cover a subtree of the
332;;; type graph (i.e. there is no simple way for any other type class to be a
333;;; subtype.)  There are always still complex ways, namely UNION and MEMBER
334;;; types, so we must give TYPE1's method a chance to run, instead of
335;;; immediately returning NIL, T.
336;;;
337(defun delegate-complex-subtypep-arg2 (type1 type2)
338  (let ((subtypep-arg1
339         (type-class-complex-subtypep-arg1
340          (ctype-class-info type1))))
341    (if subtypep-arg1
342        (funcall subtypep-arg1 type1 type2)
343        (values nil t))))
344;;;
345(defun delegate-complex-intersection (type1 type2)
346  (let ((method (type-class-complex-intersection (ctype-class-info type1))))
347    (if (and method (not (eq method #'delegate-complex-intersection)))
348        (funcall method type2 type1)
349        (hierarchical-intersection2 type1 type2))))
350
351;;; HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1  --  Internal
352;;;
353;;;    Used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 method.  Info is
354;;; a list of conses (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).  Will
355;;; never be called with a hairy type as type2, since the hairy type type2
356;;; method gets first crack.
357;;;
358#|
359(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info)
360  (values
361   (and (typep type2 'class)
362        (dolist (x info nil)
363          (when (or (not (cdr x))
364                    (csubtypep type1 (specifier-type (cdr x))))
365            (return
366             (or (eq type2 (car x))
367                 (let ((inherits (layout-inherits (class-layout (car x)))))
368                   (dotimes (i (length inherits) nil)
369                     (when (eq type2 (layout-class (svref inherits i)))
370                       (return t)))))))))
371   t))
372|#
373
374(eval-when (:compile-toplevel :execute)
375;;; DEFINE-SUPERCLASSES  --  Interface
376;;;
377;;;    Takes a list of specs of the form (superclass &optional guard).
378;;; Consider one spec (with no guard): any instance of type-class is also a
379;;; subtype of SUPERCLASS and of any of its superclasses.  If there are
380;;; multiple specs, then some will have guards.  We choose the first spec whose
381;;; guard is a supertype of TYPE1 and use its superclass.  In effect, a
382;;; sequence of guards G0, G1, G2 is actually G0, (and G1 (not G0)),
383;;; (and G2 (not (or G0 G1))).
384;;;
385#|
386(defmacro define-superclasses (type-class &rest specs)
387  (let ((info
388         (mapcar #'(lambda (spec)
389                     (destructuring-bind (super &optional guard)
390                                         spec
391                       (cons (find-class super) guard)))
392                 specs)))
393    `(progn
394      (setf (type-class-complex-subtypep-arg1
395             (type-class-or-lose ',type-class))
396            #'(lambda (type1 type2)
397                (has-superclasses-complex-subtypep-arg1 type1 type2 ',info)))
398       
399       (setf (type-class-complex-subtypep-arg2
400              (type-class-or-lose ',type-class))
401             #'delegate-complex-subtypep-arg2)
402       
403       (setf (type-class-complex-intersection
404              (type-class-or-lose ',type-class))
405             #'delegate-complex-intersection))))
406|#
407
408); eval-when (compile eval)
409
410
411(defun reparse-unknown-ctype (type)
412  (if (unknown-ctype-p type)
413    (specifier-type (type-specifier type))
414    type))
415
416(defun swapped-args-fun (f)
417  #'(lambda (x y)
418      (funcall f y x)))
419
420(defun equal-but-no-car-recursion (x y)
421  (cond ((eql x y) t)
422        ((consp x)
423         (and (consp y)
424              (eql (car x) (car y))
425              (equal-but-no-car-recursion (cdr x) (cdr y))))
426        (t nil)))
427
428(defun any/type (op thing list)
429  (declare (type function op))
430  (let ((certain? t))
431    (dolist (i list (values nil certain?))
432      (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
433        (if sub-certain?
434            (when sub-value (return (values t t)))
435            (setf certain? nil))))))
436
437(defun every/type (op thing list)
438  (declare (type function op))
439  (let ((certain? t))
440    (dolist (i list (if certain? (values t t) (values nil nil)))
441      (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
442        (if sub-certain?
443            (unless sub-value (return (values nil t)))
444            (setf certain? nil))))))
445
446(defun invoke-complex-=-other-method (type1 type2)
447  (let* ((type-class (ctype-class-info type1))
448         (method-fun (type-class-complex-= type-class)))
449    (if method-fun
450        (funcall (the function method-fun) type2 type1)
451        (values nil t))))
452
453(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
454  (let* ((type-class (ctype-class-info type1))
455         (method-fun (type-class-complex-subtypep-arg1 type-class)))
456    (if method-fun
457      (funcall (the function method-fun) type1 type2)
458      (values subtypep win))))
459
460(defun type-might-contain-other-types-p (type)
461  (or (hairy-ctype-p type)
462      (negation-ctype-p type)
463      (union-ctype-p type)
464      (intersection-ctype-p type)))
465
466
467(eval-when (:compile-toplevel :execute)
468
469(defmacro define-type-method ((class method &rest more-methods)
470                                    lambda-list &body body)
471  `(progn
472     (let* ((fn #'(lambda ,lambda-list ,@body)))
473       ,@(mapcar #'(lambda (method)
474                         `(setf (%svref
475                                   (type-class-or-lose ',class)
476                             ,(class-function-slot-or-lose method))
477                                  fn))
478                     (cons method more-methods)))
479     nil))
480
481)
482
483
484(defun ctype-p (x)
485  (and (eql (typecode x) target::subtag-istruct)
486       (memq (%svref x 0) 
487             '#.(cons 'ctype 
488                      (cons 'unknown-ctype                             
489                            (append (mapcar #'class-name 
490                                            (class-direct-subclasses (find-class 'args-ctype)))
491                                    (mapcar #'class-name 
492                                            (class-direct-subclasses (find-class 'ctype)))))))))
493
494
495(setf (type-predicate 'ctype) 'ctype-p)
496
497
498;;;; Function and Values types.
499;;;
500;;;    Pretty much all of the general type operations are illegal on VALUES
501;;; types, since we can't discriminate using them, do SUBTYPEP, etc.  FUNCTION
502;;; types are acceptable to the normal type operations, but are generally
503;;; considered to be equivalent to FUNCTION.  These really aren't true types in
504;;; any type theoretic sense, but we still parse them into CTYPE structures for
505;;; two reasons:
506;;; -- Parsing and unparsing work the same way, and indeed we can't tell
507;;;    whether a type is a function or values type without parsing it.
508;;; -- Many of the places that can be annotated with real types can also be
509;;;    annotated function or values types.
510
511;; Methods on the VALUES type class.
512
513(defun make-values-ctype (&key
514                          required
515                          optional
516                          rest
517                          keyp
518                          keywords
519                          allowp)
520  (%istruct 'values-ctype
521            (type-class-or-lose 'values)
522            nil
523            required
524            optional
525            rest
526            keyp
527            keywords
528            allowp
529           ))
530
531(defun values-ctype-p (x) (istruct-typep x 'values-ctype))
532(setf (type-predicate 'values-ctype) 'values-ctype-p)
533
534
535(define-type-method (values :simple-subtypep :complex-subtypep-arg1)
536                    (type1 type2)
537  (declare (ignore type2))
538  (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type1)))
539
540(define-type-method (values :complex-subtypep-arg2)
541                    (type1 type2)
542  (declare (ignore type1))
543  (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type2)))
544
545
546(define-type-method (values :unparse) (type)
547  (cons 'values (unparse-args-types type)))
548
549
550;;; TYPE=-LIST  --  Internal
551;;;
552;;;    Return true if List1 and List2 have the same elements in the same
553;;; positions according to TYPE=.  We return NIL, NIL if there is an uncertain
554;;; comparison.
555;;;
556(defun type=-list (list1 list2)
557  (declare (list list1 list2))
558  (do ((types1 list1 (cdr types1))
559       (types2 list2 (cdr types2)))
560      ((or (null types1) (null types2))
561       (if (or types1 types2)
562           (values nil t)
563           (values t t)))
564    (multiple-value-bind (val win)
565                               (type= (first types1) (first types2))
566      (unless win
567          (return (values nil nil)))
568      (unless val
569          (return (values nil t))))))
570
571(define-type-method (values :simple-=) (type1 type2)
572  (let ((rest1 (args-ctype-rest type1))
573        (rest2 (args-ctype-rest type2)))
574    (cond ((or (args-ctype-keyp type1) (args-ctype-keyp type2)
575               (args-ctype-allowp type1) (args-ctype-allowp type2))
576             (values nil nil))
577            ((and rest1 rest2 (type/= rest1 rest2))
578             (type= rest1 rest2))
579            ((or rest1 rest2)
580             (values nil t))
581            (t
582             (multiple-value-bind (req-val req-win)
583                 (type=-list (values-ctype-required type1)
584                             (values-ctype-required type2))
585               (multiple-value-bind (opt-val opt-win)
586                   (type=-list (values-ctype-optional type1)
587                               (values-ctype-optional type2))
588                 (values (and req-val opt-val) (and req-win opt-win))))))))
589
590
591;; Methods on the FUNCTION type class.
592
593
594(defun make-function-ctype (&key
595                            required
596                            optional
597                            rest
598                            keyp
599                            keywords
600                            allowp
601                            wild-args
602                            returns)
603  (%istruct 'function-ctype
604            (type-class-or-lose 'function)
605            nil
606            required
607            optional
608            rest
609            keyp
610            keywords
611            allowp
612            wild-args
613            returns
614           ))
615
616(defun function-ctype-p (x) (istruct-typep x 'function-ctype))
617(setf (type-predicate 'function-ctype) 'function-ctype-p)
618
619;;; A flag that we can bind to cause complex function types to be unparsed as
620;;; FUNCTION.  Useful when we want a type that we can pass to TYPEP.
621;;;
622(defvar *unparse-function-type-simplify* nil)
623
624(define-type-method (function :unparse) (type)
625  (if *unparse-function-type-simplify*
626    'function
627    (list 'function
628            (if (function-ctype-wild-args type)
629                '*
630                (unparse-args-types type))
631            (type-specifier
632             (function-ctype-returns type)))))
633
634;;; Since all function types are equivalent to FUNCTION, they are all subtypes
635;;; of each other.
636;;;
637
638(define-type-method (function :simple-subtypep) (type1 type2)
639 (flet ((fun-type-simple-p (type)
640          (not (or (function-ctype-rest type)
641                   (function-ctype-keyp type))))
642        (every-csubtypep (types1 types2)
643          (loop
644             for a1 in types1
645             for a2 in types2
646             do (multiple-value-bind (res sure-p)
647                    (csubtypep a1 a2)
648                  (unless res (return (values res sure-p))))
649             finally (return (values t t)))))
650   (macrolet ((3and (x y)
651                `(multiple-value-bind (val1 win1) ,x
652                   (if (and (not val1) win1)
653                       (values nil t)
654                       (multiple-value-bind (val2 win2) ,y
655                         (if (and val1 val2)
656                             (values t t)
657                             (values nil (and win2 (not val2)))))))))
658     (3and (values-subtypep (function-ctype-returns type1)
659                            (function-ctype-returns type2))
660           (cond ((function-ctype-wild-args type2) (values t t))
661                 ((function-ctype-wild-args type1)
662                  (cond ((function-ctype-keyp type2) (values nil nil))
663                        ((not (function-ctype-rest type2)) (values nil t))
664                        ((not (null (function-ctype-required type2))) (values nil t))
665                        (t (3and (type= *universal-type* (function-ctype-rest type2))
666                                 (every/type #'type= *universal-type*
667                                             (function-ctype-optional type2))))))
668                 ((not (and (fun-type-simple-p type1)
669                            (fun-type-simple-p type2)))
670                  (values nil nil))
671                 (t (multiple-value-bind (min1 max1) (function-type-nargs type1)
672                      (multiple-value-bind (min2 max2) (function-type-nargs type2)
673                        (cond ((or (> max1 max2) (< min1 min2))
674                               (values nil t))
675                              ((and (= min1 min2) (= max1 max2))
676                               (3and (every-csubtypep (function-ctype-required type1)
677                                                      (function-ctype-required type2))
678                                     (every-csubtypep (function-ctype-optional type1)
679                                                      (function-ctype-optional type2))))
680                              (t (every-csubtypep
681                                  (concatenate 'list
682                                               (function-ctype-required type1)
683                                               (function-ctype-optional type1))
684                                  (concatenate 'list
685                                               (function-ctype-required type2)
686                                               (function-ctype-optional type2)))))))))))))
687
688
689                   
690;(define-superclasses function (function))       
691
692
693;;; The union or intersection of two FUNCTION types is FUNCTION.
694;;; (unless the types are type=)
695;;;
696(define-type-method (function :simple-union) (type1 type2)
697  (if (type= type1 type2)
698    type1
699    (specifier-type 'function)))
700
701;;;
702(define-type-method (function :simple-intersection) (type1 type2)
703  (if (type= type1 type2)
704    type1
705    (specifier-type 'function)))
706
707
708;;; ### Not very real, but good enough for redefining transforms according to
709;;; type:
710;;;
711(define-type-method (function :simple-=) (type1 type2)
712  (values (equalp type1 type2) t))
713
714;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type
715;;; specifier", which is only meaningful in function argument type specifiers
716;;; used within the compiler.
717;;;
718
719(defun clone-type-class-methods (src-tc dest-tc)
720  (do* ((n (uvsize src-tc))
721        (i 2 (1+ i)))
722       ((= i n) dest-tc)
723    (declare (fixnum i n))
724    (setf (%svref dest-tc i)
725          (%svref src-tc i))))
726
727(clone-type-class-methods (type-class-or-lose 'values) (type-class-or-lose 'constant))
728
729(defun make-constant-ctype (&key type)
730  (%istruct 'constant-ctype
731            (type-class-or-lose 'constant)
732            nil
733            type))
734
735(defun constant-ctype-p (x) (istruct-typep x 'constant-ctype))
736(setf (type-predicate 'constant-ctype) 'constant-ctype-p)
737
738(define-type-method (constant :unparse) (type)
739  `(constant-argument ,(type-specifier (constant-ctype-type type))))
740
741(define-type-method (constant :simple-=) (type1 type2)
742  (type= (constant-ctype-type type1) (constant-ctype-type type2)))
743
744(def-type-translator constant-argument (type)
745  (make-constant-ctype :type (specifier-type type)))
746
747
748;;; Parse-Args-Types  --  Internal
749;;;
750;;;    Given a lambda-list like values type specification and a Args-Type
751;;; structure, fill in the slots in the structure accordingly.  This is used
752;;; for both FUNCTION and VALUES types.
753;;;
754
755(defun parse-args-types (lambda-list result)
756  (multiple-value-bind (required optional restp rest keyp keys allowp aux)
757                           (parse-lambda-list lambda-list)
758    (when aux
759      (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
760    (setf (args-ctype-required result) (mapcar #'specifier-type required))
761    (setf (args-ctype-optional result) (mapcar #'specifier-type optional))
762    (setf (args-ctype-rest result) (if restp (specifier-type rest) nil))
763    (setf (args-ctype-keyp result) keyp)
764    (let* ((key-info ()))
765      (dolist (key keys)
766          (when (or (atom key) (/= (length key) 2))
767            (signal-program-error "Keyword type description is not a two-list: ~S." key))
768          (let ((kwd (first key)))
769            (when (member kwd key-info :test #'eq :key #'(lambda (x) (key-info-name x)))
770              (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
771            (push (make-key-info :name kwd
772                               :type (specifier-type (second key))) key-info)))
773      (setf (args-ctype-keywords result) (nreverse key-info)))
774    (setf (args-ctype-allowp result) allowp)))
775
776;;; Unparse-Args-Types  --  Internal
777;;;
778;;;    Return the lambda-list like type specification corresponding
779;;; to a Args-Type.
780;;;
781(defun unparse-args-types (type)
782  (let* ((result ()))
783
784    (dolist (arg (args-ctype-required type))
785      (push (type-specifier arg) result))
786
787    (when (args-ctype-optional type)
788      (push '&optional result)
789      (dolist (arg (args-ctype-optional type))
790          (push (type-specifier arg) result)))
791
792    (when (args-ctype-rest type)
793      (push '&rest result)
794      (push (type-specifier (args-ctype-rest type)) result))
795
796    (when (args-ctype-keyp type)
797      (push '&key result)
798      (dolist (key (args-ctype-keywords type))
799          (push (list (key-info-name key)
800                    (type-specifier (key-info-type key))) result)))
801
802    (when (args-ctype-allowp type)
803      (push '&allow-other-keys result))
804
805    (nreverse result)))
806
807(def-type-translator function (&optional (args '*) (result '*))
808  (let ((res (make-function-ctype
809                :returns (values-specifier-type result))))
810    (if (eq args '*)
811        (setf (function-ctype-wild-args res) t)
812        (parse-args-types args res))
813    res))
814
815(def-type-translator values (&rest values)
816  (let ((res (make-values-ctype)))
817    (parse-args-types values res)
818    (when (or (values-ctype-keyp res) (values-ctype-allowp res))
819      (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s"
820                            res))
821    res))
822
823;;; Single-Value-Type  --  Interface
824;;;
825;;;    Return the type of the first value indicated by Type.  This is used by
826;;; people who don't want to have to deal with values types.
827;;;
828(defun single-value-type (type)
829  (declare (type ctype type))
830  (cond ((values-ctype-p type)
831         (or (car (args-ctype-required type))
832             (if (args-ctype-optional type)
833                 (type-union (car (args-ctype-optional type))
834                             (specifier-type 'null)))
835             (args-ctype-rest type)
836             (specifier-type 'null)))
837        ((eq type *wild-type*)
838         *universal-type*)
839        (t
840         type)))
841
842
843;;; FUNCTION-TYPE-NARGS  --  Interface
844;;;
845;;;    Return the minmum number of arguments that a function can be called
846;;; with, and the maximum number or NIL.  If not a function type, return
847;;; NIL, NIL.
848;;;
849(defun function-type-nargs (type)
850  (declare (type ctype type))
851  (if (function-ctype-p type)
852    (let ((fixed (length (args-ctype-required type))))
853        (if (or (args-ctype-rest type)
854                  (args-ctype-keyp type)
855                  (args-ctype-allowp type))
856        (values fixed nil)
857        (values fixed (+ fixed (length (args-ctype-optional type))))))
858    (values nil nil)))
859
860
861;;; Values-Types  --  Interface
862;;;
863;;;    Determine if Type corresponds to a definite number of values.  The first
864;;; value is a list of the types for each value, and the second value is the
865;;; number of values.  If the number of values is not fixed, then return NIL
866;;; and :Unknown.
867;;;
868(defun values-types (type)
869  (declare (type ctype type))
870  (cond ((eq type *wild-type*)
871           (values nil :unknown))
872          ((not (values-ctype-p type))
873           (values (list type) 1))
874          ((or (args-ctype-optional type)
875               (args-ctype-rest type)
876               (args-ctype-keyp type)
877               (args-ctype-allowp type))
878           (values nil :unknown))
879          (t
880           (let ((req (args-ctype-required type)))
881             (values (mapcar #'single-value-type req) (length req))))))
882
883
884;;; Values-Type-Types  --  Internal
885;;;
886;;;    Return two values:
887;;; 1] A list of all the positional (fixed and optional) types.
888;;; 2] The rest type (if any).  If keywords allowed, *universal-type*.  If no
889;;;    keywords or rest, *empty-type*.
890;;;
891(defun values-type-types (type &optional (default-type *empty-type*))
892  (declare (type values-type type))
893  (values (append (args-ctype-required type)
894                  (args-ctype-optional type))
895            (cond ((args-ctype-keyp type) *universal-type*)
896                  ((args-ctype-rest type))
897                  (t default-type))))
898
899
900;;; Fixed-Values-Op  --  Internal
901;;;
902;;;    Return a list of Operation applied to the types in Types1 and Types2,
903;;; padding with Rest2 as needed.  Types1 must not be shorter than Types2.  The
904;;; second value is T if Operation always returned a true second value.
905;;;
906(defun fixed-values-op (types1 types2 rest2 operation)
907  (declare (list types1 types2) (type ctype rest2) (type function operation))
908  (let ((exact t))
909    (values (mapcar #'(lambda (t1 t2)
910                              (multiple-value-bind (res win)
911                                  (funcall operation t1 t2)
912                                (unless win (setq exact nil))
913                                res))
914                        types1
915                        (append types2
916                                (make-list (- (length types1) (length types2))
917                                           :initial-element rest2)))
918              exact)))
919
920;;; Coerce-To-Values  --  Internal
921;;;
922;;; If Type isn't a values type, then make it into one:
923;;;    <type>  ==>  (values type &rest t)
924;;;
925(defun coerce-to-values (type)
926  (declare (type ctype type))
927  (if (values-ctype-p type)
928    type
929    (make-values-ctype :required (list type))))
930
931
932;;; Args-Type-Op  --  Internal
933;;;
934;;;    Do the specified Operation on Type1 and Type2, which may be any type,
935;;; including Values types.  With values types such as:
936;;;    (values a0 a1)
937;;;    (values b0 b1)
938;;;
939;;; We compute the more useful result:
940;;;    (values (<operation> a0 b0) (<operation> a1 b1))
941;;;
942;;; Rather than the precise result:
943;;;    (<operation> (values a0 a1) (values b0 b1))
944;;;
945;;; This has the virtue of always keeping the values type specifier outermost,
946;;; and retains all of the information that is really useful for static type
947;;; analysis.  We want to know what is always true of each value independently.
948;;; It is worthless to know that IF the first value is B0 then the second will
949;;; be B1.
950;;;
951;;; If the values count signatures differ, then we produce result with the
952;;; required value count chosen by Nreq when applied to the number of required
953;;; values in type1 and type2.  Any &key values become &rest T (anyone who uses
954;;; keyword values deserves to lose.)
955;;;
956;;; The second value is true if the result is definitely empty or if Operation
957;;; returned true as its second value each time we called it.  Since we
958;;; approximate the intersection of values types, the second value being true
959;;; doesn't mean the result is exact.
960;;;
961(defun args-type-op (type1 type2 operation nreq default-type)
962  (declare (type ctype type1 type2 default-type)
963           (type function operation nreq))
964  (if (eq type1 type2)
965    (values type1 t)
966    (if (or (values-ctype-p type1) (values-ctype-p type2))
967      (let ((type1 (coerce-to-values type1))
968            (type2 (coerce-to-values type2)))
969        (multiple-value-bind (types1 rest1)
970            (values-type-types type1 default-type)
971          (multiple-value-bind (types2 rest2)
972              (values-type-types type2 default-type)
973            (multiple-value-bind (rest rest-exact)
974                (funcall operation rest1 rest2)
975              (multiple-value-bind
976                  (res res-exact)
977                  (if (< (length types1) (length types2))
978                    (fixed-values-op types2 types1 rest1 operation)
979                    (fixed-values-op types1 types2 rest2 operation))
980                (let* ((req (funcall nreq
981                                     (length (args-ctype-required type1))
982                                     (length (args-ctype-required type2))))
983                       (required (subseq res 0 req))
984                       (opt (subseq res req))
985                       (opt-last (position rest opt :test-not #'type=
986                                           :from-end t)))
987                  (if (find *empty-type* required :test #'type=)
988                    (values *empty-type* t)
989                    (values (make-values-ctype
990                             :required required
991                             :optional (if opt-last
992                                         (subseq opt 0 (1+ opt-last))
993                                         ())
994                             :rest (if (eq rest *empty-type*) nil rest))
995                            (and rest-exact res-exact)))))))))
996      (funcall operation type1 type2))))
997
998;;; Values-Type-Union, Values-Type-Intersection  --  Interface
999;;;
1000;;;    Do a union or intersection operation on types that might be values
1001;;; types.  The result is optimized for utility rather than exactness, but it
1002;;; is guaranteed that it will be no smaller (more restrictive) than the
1003;;; precise result.
1004;;;
1005
1006(defun values-type-union (type1 type2)
1007  (declare (type ctype type1 type2))
1008  (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
1009        ((eq type1 *empty-type*) type2)
1010        ((eq type2 *empty-type*) type1)
1011        (t
1012         (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
1013
1014(defun values-type-intersection (type1 type2)
1015  (declare (type ctype type1 type2))
1016  (cond ((eq type1 *wild-type*) (values type2 t))
1017        ((eq type2 *wild-type*) (values type1 t))
1018        (t
1019         (args-type-op type1 type2 #'type-intersection #'max
1020                       (specifier-type 'null)))))
1021
1022
1023;;; Values-Types-Intersect  --  Interface
1024;;;
1025;;;    Like Types-Intersect, except that it sort of works on values types.
1026;;; Note that due to the semantics of Values-Type-Intersection, this might
1027;;; return {T, T} when there isn't really any intersection (?).
1028;;;
1029(defun values-types-intersect (type1 type2)
1030  (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
1031           (values t t))
1032          ((or (values-ctype-p type1) (values-ctype-p type2))
1033           (multiple-value-bind (res win)
1034                                    (values-type-intersection type1 type2)
1035             (values (not (eq res *empty-type*))
1036                       win)))
1037          (t
1038           (types-intersect type1 type2))))
1039
1040;;; Values-Subtypep  --  Interface
1041;;;
1042;;;    A subtypep-like operation that can be used on any types, including
1043;;; values types.
1044;;;
1045
1046(defun values-subtypep (type1 type2)
1047  (declare (type ctype type1 type2))
1048  (cond ((eq type2 *wild-type*) (values t t))
1049        ((eq type1 *wild-type*)
1050         (values (eq type2 *universal-type*) t))
1051        ((not (values-types-intersect type1 type2))
1052         (values nil t))
1053        (t
1054         (if (or (values-ctype-p type1) (values-ctype-p type2))
1055           (let ((type1 (coerce-to-values type1))
1056                 (type2 (coerce-to-values type2)))
1057             (multiple-value-bind (types1 rest1)
1058                 (values-type-types type1)
1059               (multiple-value-bind (types2 rest2)
1060                   (values-type-types type2)
1061                 (cond ((< (length (values-ctype-required type1))
1062                           (length (values-ctype-required type2)))
1063                        (values nil t))
1064                       ((< (length types1) (length types2))
1065                        (values nil nil))
1066                       ((or (values-ctype-keyp type1)
1067                            (values-ctype-keyp type2))
1068                        (values nil nil))
1069                       (t
1070                        (do ((t1 types1 (rest t1))
1071                             (t2 types2 (rest t2)))
1072                            ((null t2)
1073                             (csubtypep rest1 rest2))
1074                          (multiple-value-bind
1075                              (res win-p)
1076                              (csubtypep (first t1) (first t2))
1077                            (unless win-p
1078                              (return (values nil nil)))
1079                            (unless res
1080                              (return (values nil t))))))))))
1081           (csubtypep type1 type2)))))
1082 
1083
1084;;;; Type method interfaces:
1085
1086;;; Csubtypep  --  Interface
1087;;;
1088;;;    Like subtypep, only works on Type structures.
1089;;;
1090(defun csubtypep (type1 type2)
1091  (declare (type ctype type1 type2))
1092  (unless (typep type1 'ctype)
1093    (report-bad-arg type1 'ctype))
1094  (unless (typep type2 'ctype)
1095    (report-bad-arg type2 'ctype))
1096  (cond ((or (eq type1 type2)
1097             (eq type1 *empty-type*)
1098             (eq type2 *wild-type*))
1099         (values t t))
1100        (t
1101         (invoke-type-method :simple-subtypep :complex-subtypep-arg2
1102                             type1 type2
1103                             :complex-arg1 :complex-subtypep-arg1))))
1104;;; Type=  --  Interface
1105;;;
1106;;;    If two types are definitely equivalent, return true.  The second value
1107;;; indicates whether the first value is definitely correct.  This should only
1108;;; fail in the presence of Hairy types.
1109;;;
1110
1111(defun type= (type1 type2)
1112   (declare (type ctype type1 type2))
1113   (if (eq type1 type2)
1114     (values t t)
1115     (invoke-type-method :simple-= :complex-= type1 type2)))
1116
1117;;; TYPE/=  --  Interface
1118;;;
1119;;;    Not exactly the negation of TYPE=, since when the relationship is
1120;;; uncertain, we still return NIL, NIL.  This is useful in cases where the
1121;;; conservative assumption is =.
1122;;;
1123(defun type/= (type1 type2)
1124  (declare (type ctype type1 type2))
1125  (multiple-value-bind (res win)
1126      (type= type1 type2)
1127    (if win
1128        (values (not res) t)
1129        (values nil nil))))
1130
1131;;; Type-Union  --  Interface
1132;;;
1133;;;    Find a type which includes both types.  Any inexactness is represented
1134;;; by the fuzzy element types; we return a single value that is precise to the
1135;;; best of our knowledge.  This result is simplified into the canonical form,
1136;;; thus is not a UNION type unless there is no other way to represent the
1137;;; result.
1138;;;
1139
1140(defun type-union (&rest input-types)
1141  (%type-union input-types))
1142
1143(defun %type-union (input-types)
1144  (let* ((simplified (simplify-unions input-types)))
1145    (cond ((null simplified) *empty-type*)
1146          ((null (cdr simplified)) (car simplified))
1147          (t (make-union-ctype simplified)))))
1148
1149(defun simplify-unions (types)
1150  (when types
1151    (multiple-value-bind (first rest)
1152        (if (union-ctype-p (car types))
1153          (values (car (union-ctype-types (car types)))
1154                  (append (cdr (union-ctype-types (car types)))
1155                          (cdr types)))
1156          (values (car types) (cdr types)))
1157      (let ((rest (simplify-unions rest)) u)
1158        (dolist (r rest (cons first rest))
1159          (when (setq u (type-union2 first r))
1160            (return (simplify-unions (nsubstitute u r rest)))))))))
1161
1162(defun type-union2 (type1 type2)
1163  (declare (type ctype type1 type2))
1164  (setq type1 (reparse-unknown-ctype type1))
1165  (setq type2 (reparse-unknown-ctype type2))
1166  (cond ((eq type1 type2) type1)
1167        ((csubtypep type1 type2) type2)
1168        ((csubtypep type2 type1) type1)
1169        (t
1170         (flet ((1way (x y)
1171                  (invoke-type-method :simple-union :complex-union
1172                                      x y
1173                                      :default nil)))
1174           (or (1way type1 type2)
1175               (1way type2 type1))))))
1176
1177;;; Return as restrictive and simple a type as we can discover that is
1178;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
1179;;; worst, we arbitrarily return one of the arguments as the first
1180;;; value (trying not to return a hairy type).
1181(defun type-approx-intersection2 (type1 type2)
1182  (cond ((type-intersection2 type1 type2))
1183        ((hairy-ctype-p type1) type2)
1184        (t type1)))
1185
1186
1187;;; Type-Intersection  --  Interface
1188;;;
1189;;;    Return as restrictive a type as we can discover that is no more
1190;;; restrictive than the intersection of Type1 and Type2.  The second value is
1191;;; true if the result is exact.  At worst, we randomly return one of the
1192;;; arguments as the first value (trying not to return a hairy type).
1193;;;
1194
1195(defun type-intersection (&rest input-types)
1196  (%type-intersection input-types))
1197
1198(defun %type-intersection (input-types)
1199  (let ((simplified (simplify-intersections input-types)))
1200    ;;(declare (type (vector ctype) simplified))
1201    ;; We want to have a canonical representation of types (or failing
1202    ;; that, punt to HAIRY-TYPE). Canonical representation would have
1203    ;; intersections inside unions but not vice versa, since you can
1204    ;; always achieve that by the distributive rule. But we don't want
1205    ;; to just apply the distributive rule, since it would be too easy
1206    ;; to end up with unreasonably huge type expressions. So instead
1207    ;; we try to generate a simple type by distributing the union; if
1208    ;; the type can't be made simple, we punt to HAIRY-TYPE.
1209    (if (and (cdr simplified) (some #'union-ctype-p simplified))
1210      (let* ((first-union (find-if #'union-ctype-p simplified))
1211             (other-types (remove first-union simplified))
1212             (distributed (maybe-distribute-one-union first-union other-types)))
1213        (if distributed
1214          (apply #'type-union distributed)
1215          (make-hairy-ctype
1216           :specifier `(and ,@(mapcar #'type-specifier simplified)))))
1217      (cond
1218        ((null simplified) *universal-type*)
1219        ((null (cdr simplified)) (car simplified))
1220        (t (make-intersection-ctype
1221            (some #'(lambda (c) (ctype-enumerable c)) simplified)
1222            simplified))))))
1223
1224(defun simplify-intersections (types)
1225  (when types
1226    (multiple-value-bind (first rest)
1227        (if (intersection-ctype-p (car types))
1228            (values (car (intersection-ctype-types (car types)))
1229                    (append (cdr (intersection-ctype-types (car types)))
1230                            (cdr types)))
1231            (values (car types) (cdr types)))
1232      (let ((rest (simplify-intersections rest)) u)
1233        (dolist (r rest (cons first rest))
1234          (when (setq u (type-intersection2 first r))
1235            (return (simplify-intersections (nsubstitute u r rest)))))))))
1236
1237(defun type-intersection2 (type1 type2)
1238  (declare (type ctype type1 type2))
1239  (setq type1 (reparse-unknown-ctype type1))
1240  (setq type2 (reparse-unknown-ctype type2))
1241  (cond ((eq type1 type2)
1242         type1)
1243        ((or (intersection-ctype-p type1)
1244             (intersection-ctype-p type2))
1245         ;; Intersections of INTERSECTION-TYPE should have the
1246         ;; INTERSECTION-CTYPE-TYPES values broken out and intersected
1247         ;; separately. The full TYPE-INTERSECTION function knows how
1248         ;; to do that, so let it handle it.
1249         (type-intersection type1 type2))
1250        ;;
1251        ;; (AND (FUNCTION (T) T) GENERIC-FUNCTION) for instance, but
1252        ;; not (AND (FUNCTION (T) T) (FUNCTION (T) T)).
1253        ((let ((function (specifier-type 'function)))
1254           (or (and (function-ctype-p type1)
1255                    (not (or (function-ctype-p type2) (eq function type2)))
1256                    (csubtypep type2 function)
1257                    (not (csubtypep function type2)))
1258               (and (function-ctype-p type2)
1259                    (not (or (function-ctype-p type1) (eq function type1)))
1260                    (csubtypep type1 function)
1261                    (not (csubtypep function type1)))))
1262         nil)
1263        (t
1264         (flet ((1way (x y)
1265                  (invoke-type-method :simple-intersection
1266                                      :complex-intersection
1267                                      x y
1268                                      :default :no-type-method-found)))
1269           (let ((xy (1way type1 type2)))
1270             (or (and (not (eql xy :no-type-method-found)) xy)
1271                 (let ((yx (1way type2 type1)))
1272                   (or (and (not (eql yx :no-type-method-found)) yx)
1273                       (cond ((and (eql xy :no-type-method-found)
1274                                   (eql yx :no-type-method-found))
1275                              *empty-type*)
1276                             (t
1277                              nil))))))))))
1278
1279
1280
1281(defun maybe-distribute-one-union (union-type types)
1282  (let* ((intersection (apply #'type-intersection types))
1283         (union (mapcar (lambda (x) (type-intersection x intersection))
1284                        (union-ctype-types union-type))))
1285    (if (notany (lambda (x)
1286                  (or (hairy-ctype-p x)
1287                      (intersection-ctype-p x)))
1288                union)
1289        union
1290        nil)))
1291
1292;;; Types-Intersect  --  Interface
1293;;;
1294;;;    The first value is true unless the types don't intersect.  The second
1295;;; value is true if the first value is definitely correct.  NIL is considered
1296;;; to intersect with any type.  If T is a subtype of either type, then we also
1297;;; return T, T.  This way we consider hairy types to intersect with T.
1298;;;
1299(defun types-intersect (type1 type2)
1300  (declare (type ctype type1 type2))
1301  (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
1302      (values t t)
1303      (let ((intersection2 (type-intersection2 type1 type2)))
1304        (cond ((not intersection2)
1305               (if (or (csubtypep *universal-type* type1)
1306                       (csubtypep *universal-type* type2))
1307                   (values t t)
1308                   (values t nil)))
1309              ((eq intersection2 *empty-type*) (values nil t))
1310              (t (values t t))))))
1311
1312;;; Type-Specifier  --  Interface
1313;;;
1314;;;    Return a Common Lisp type specifier corresponding to this type.
1315;;;
1316(defun type-specifier (type)
1317  (unless (ctype-p type)
1318    (setq type (require-type type 'ctype)))
1319  (locally 
1320      (declare (type ctype type))
1321    (funcall (type-class-unparse (ctype-class-info type)) type)))
1322
1323;;; VALUES-SPECIFIER-TYPE  --  Interface
1324;;;
1325;;;    Return the type structure corresponding to a type specifier.  We pick
1326;;; off Structure types as a special case.
1327;;;
1328
1329(defun values-specifier-type-internal (orig)
1330  (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes
1331     
1332      (let ((spec (type-expand orig)))
1333        (cond
1334         ((and (not (eq spec orig))
1335               (info-type-builtin spec)))
1336         ((eq (info-type-kind spec) :instance)
1337          (let* ((class-ctype (%class.ctype (find-class spec))))
1338            (or (class-ctype-translation class-ctype)
1339                class-ctype)))
1340         ((typep spec 'class)
1341          (let* ((class-ctype (%class.ctype spec)))
1342            (or (class-ctype-translation class-ctype)
1343                class-ctype)))
1344         ((let ((cell (find-builtin-cell spec nil)))
1345           (and cell (cdr cell))))
1346         (t
1347          (let* ((lspec (if (atom spec) (list spec) spec))
1348                 (fun (info-type-translator (car lspec))))
1349            (cond (fun (funcall fun lspec nil))
1350                  ((or (and (consp spec) (symbolp (car spec)))
1351                       (symbolp spec))
1352                   (when *type-system-initialized*
1353                     (signal 'parse-unknown-type :specifier spec))
1354                   ;;
1355                   ;; Inhibit caching...
1356                   nil)
1357                  (t
1358                   (error "Bad thing to be a type specifier: ~S." spec)))))))))
1359
1360(eval-when (:compile-toplevel :execute)
1361  (defconstant type-cache-size (ash 1 12))
1362  (defconstant type-cache-mask (1- type-cache-size)))
1363
1364;;; We can get in trouble if we try to cache certain kinds of ctypes,
1365;;; notably MEMBER types which refer to objects which might
1366;;; be stack-allocated or might be EQUAL without being EQL.
1367(defun cacheable-ctype-p (ctype)
1368  (case (%svref ctype 0)
1369    (member-ctype
1370     (dolist (m (member-ctype-members ctype) t)
1371       (when (or (typep m 'cons)
1372                 (typep m 'array))
1373         (return nil))))
1374    (union-ctype
1375     (every #'cacheable-ctype-p (union-ctype-types ctype)))
1376    (intersection-ctype
1377     (every #'cacheable-ctype-p (intersection-ctype-types ctype)))
1378    (array-ctype
1379     (cacheable-ctype-p (array-ctype-element-type ctype)))
1380    ((values-ctype function-ctype)
1381     (and (every #'cacheable-ctype-p (values-ctype-required ctype))
1382          (every #'cacheable-ctype-p (values-ctype-optional ctype))
1383          (let* ((rest (values-ctype-rest ctype)))
1384            (or (null rest) (cacheable-ctype-p rest)))
1385          (every #'(lambda (info)
1386                     (cacheable-ctype-p (key-info-type info)))
1387                 (values-ctype-keywords ctype))
1388          (or (not (eq (%svref ctype 0) 'function-ctype))
1389              (let* ((result (function-ctype-returns ctype)))
1390                (or (null result)
1391                    (cacheable-ctype-p result))))))
1392    (negation-ctype
1393     (cacheable-ctype-p (negation-ctype-type ctype)))
1394    (cons-ctype
1395     (and (cacheable-ctype-p (cons-ctype-car-ctype ctype))
1396          (cacheable-ctype-p (cons-ctype-cdr-ctype ctype))))
1397    ;; Anything else ?  Simple things (numbers, classes) can't lose.
1398    (t t)))
1399               
1400     
1401   
1402
1403(defun hash-type-specifier (spec)
1404  (logand (sxhash spec) type-cache-mask))
1405
1406(let* ((type-cache-specs (make-array type-cache-size))
1407       (type-cache-ctypes (make-array type-cache-size))
1408       (probes 0)
1409       (hits 0)
1410       (ncleared 0)
1411       (locked nil))
1412 
1413  (defun clear-type-cache ()
1414    (%init-misc 0 type-cache-specs)
1415    (%init-misc 0 type-cache-ctypes)
1416    (incf ncleared)
1417    nil)
1418
1419  (defun values-specifier-type (spec)
1420    (if (typep spec 'class)
1421      (let* ((class-ctype (%class.ctype spec)))
1422        (or (class-ctype-translation class-ctype) class-ctype))
1423      (if locked
1424        (or (values-specifier-type-internal spec)
1425            (make-unknown-ctype :specifier spec))
1426        (unwind-protect
1427          (progn
1428            (setq locked t)
1429            (if (or (symbolp spec)
1430                    (and (consp spec) (symbolp (car spec))))
1431              (let* ((idx (hash-type-specifier spec)))
1432                (incf probes)
1433                (if (equal (svref type-cache-specs idx) spec)
1434                  (progn
1435                    (incf hits)
1436                    (svref type-cache-ctypes idx))
1437                  (let* ((ctype (values-specifier-type-internal spec)))
1438                    (if ctype
1439                      (progn
1440                        (when (cacheable-ctype-p ctype)
1441                          (setf (svref type-cache-specs idx) (copy-tree spec)       ; in case it was stack-consed
1442                                (svref type-cache-ctypes idx) ctype))
1443                        ctype)
1444                      (make-unknown-ctype :specifier spec)))))
1445              (values-specifier-type-internal spec)))
1446          (setq locked nil)))))
1447 
1448  (defun type-cache-hit-rate ()
1449    (values hits probes))
1450 
1451  (defun type-cache-locked-p ()
1452    locked)
1453
1454  (defun lock-type-cache ()
1455    (setq locked t)))
1456
1457                   
1458
1459 
1460
1461;;; SPECIFIER-TYPE  --  Interface
1462;;;
1463;;;    Like VALUES-SPECIFIER-TYPE, except that we guarantee to never return a
1464;;; VALUES type.
1465;;;
1466(defun specifier-type (x)
1467  (let ((res (values-specifier-type x)))
1468    (when (values-ctype-p res)
1469      (signal-program-error "VALUES type illegal in this context:~%  ~S" x))
1470    res))
1471
1472(defun single-value-specifier-type (x)
1473  (let ((res (specifier-type x)))
1474    (if (eq res *wild-type*)
1475        *universal-type*
1476        res)))
1477
1478(defun modified-numeric-type (base
1479                              &key
1480                              (class      (numeric-ctype-class      base))
1481                              (format     (numeric-ctype-format     base))
1482                              (complexp   (numeric-ctype-complexp   base))
1483                              (low        (numeric-ctype-low        base))
1484                              (high       (numeric-ctype-high       base))
1485                              (enumerable (ctype-enumerable base)))
1486  (make-numeric-ctype :class class
1487                     :format format
1488                     :complexp complexp
1489                     :low low
1490                     :high high
1491                     :enumerable enumerable))
1492
1493;;; Precompute-Types  --  Interface
1494;;;
1495;;;    Take a list of type specifiers, compute the translation and define it as
1496;;; a builtin type.
1497;;;
1498 
1499(defun precompute-types (specs)
1500  (dolist (spec specs)
1501    (let ((res (specifier-type spec)))
1502      (when (numeric-ctype-p res)
1503        (let ((pred (make-numeric-ctype-predicate res)))
1504          (when pred (setf (numeric-ctype-predicate res) pred))))
1505      (unless (unknown-ctype-p res)
1506          (setf (info-type-builtin spec) res)
1507          (setf (info-type-kind spec) :primitive)))))
1508
1509;;;; Builtin types.
1510
1511;;; The NAMED-TYPE is used to represent *, T and NIL.  These types must be
1512;;; super or sub types of all types, not just classes and * & NIL aren't
1513;;; classes anyway, so it wouldn't make much sense to make them built-in
1514;;; classes.
1515;;;
1516
1517(defun define-named-ctype (name)
1518  (let* ((ctype (%istruct 'named-ctype
1519                          (type-class-or-lose 'named)
1520                          nil
1521                          name)))
1522    (setf (info-type-kind name) :builtin
1523          (info-type-builtin name) ctype)))
1524
1525
1526(defvar *wild-type* (define-named-ctype '*))
1527(defvar *empty-type* (define-named-ctype nil))
1528(defvar *universal-type* (define-named-ctype t))
1529
1530(defun named-ctype-p (x)
1531  (istruct-typep x 'named-ctype))
1532
1533(setf (type-predicate 'named-ctype) 'named-ctype-p)
1534
1535(define-type-method (named :simple-=) (type1 type2)
1536  (values (eq type1 type2) t))
1537
1538(define-type-method (named :complex-=) (type1 type2)
1539  (cond
1540    ((and (eq type2 *empty-type*)
1541          (intersection-ctype-p type1)
1542          ;; not allowed to be unsure on these... FIXME: keep the list
1543          ;; of CL types that are intersection types once and only
1544          ;; once.
1545          (not (or (type= type1 (specifier-type 'ratio))
1546                   (type= type1 (specifier-type 'keyword)))))
1547     ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
1548     ;; STREAM) can get here.  In general, we can't really tell
1549     ;; whether these are equal to NIL or not, so
1550     (values nil nil))
1551    ((type-might-contain-other-types-p type1)
1552     (invoke-complex-=-other-method type1 type2))
1553    (t (values nil t))))
1554
1555
1556(define-type-method (named :simple-subtypep) (type1 type2)
1557  (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
1558
1559(define-type-method (named :complex-subtypep-arg1) (type1 type2)
1560  (cond ((eq type1 *empty-type*)
1561         t)
1562        (;; When TYPE2 might be the universal type in disguise
1563         (type-might-contain-other-types-p type2)
1564         ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
1565         ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
1566         ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
1567         ;; HAIRY-TYPEs as we used to. Instead we deal with the
1568         ;; problem (where at least part of the problem is cases like
1569         ;;   (SUBTYPEP T '(SATISFIES FOO))
1570         ;; or
1571         ;;   (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
1572         ;; where the second type is a hairy type like SATISFIES, or
1573         ;; is a compound type which might contain a hairy type) by
1574         ;; returning uncertainty.
1575         (values nil nil))
1576        (t
1577         ;; By elimination, TYPE1 is the universal type.
1578         (assert (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
1579         ;; This case would have been picked off by the SIMPLE-SUBTYPEP
1580         ;; method, and so shouldn't appear here.
1581         (assert (not (eq type2 *universal-type*)))
1582         ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
1583         ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
1584         (values nil t))))
1585
1586
1587(define-type-method (named :complex-subtypep-arg2) (type1 type2)
1588  (assert (not (eq type2 *wild-type*))) ; * isn't really a type.
1589  (cond ((eq type2 *universal-type*)
1590         (values t t))
1591        ((type-might-contain-other-types-p type1)
1592         ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
1593         ;; disguise.  So we'd better delegate.
1594         (invoke-complex-subtypep-arg1-method type1 type2))
1595        (t
1596         ;; FIXME: This seems to rely on there only being 2 or 3
1597         ;; NAMED-TYPE values, and the exclusion of various
1598         ;; possibilities above. It would be good to explain it and/or
1599         ;; rewrite it so that it's clearer.
1600         (values (not (eq type2 *empty-type*)) t))))
1601
1602
1603(define-type-method (named :complex-intersection) (type1 type2)
1604  (hierarchical-intersection2 type1 type2))
1605
1606(define-type-method (named :unparse) (x)
1607  (named-ctype-name x))
1608
1609
1610;;;; Hairy and unknown types:
1611
1612;;; The Hairy-Type represents anything too wierd to be described
1613;;; reasonably or to be useful, such as SATISFIES.  We just remember
1614;;; the original type spec.
1615;;;
1616
1617(defun make-hairy-ctype (&key specifier (enumerable t))
1618  (%istruct 'hairy-ctype
1619            (type-class-or-lose 'hairy)
1620            enumerable
1621            specifier))
1622
1623(defun hairy-ctype-p (x)
1624  (istruct-typep x 'hairy-ctype))
1625
1626(setf (type-predicate 'hairy-ctype) 'hairy-ctype-p)
1627
1628(define-type-method (hairy :unparse) (x) (hairy-ctype-specifier x))
1629
1630(define-type-method (hairy :simple-subtypep) (type1 type2)
1631  (let ((hairy-spec1 (hairy-ctype-specifier type1))
1632        (hairy-spec2 (hairy-ctype-specifier type2)))
1633    (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
1634           (values t t))
1635          (t
1636           (values nil nil)))))
1637
1638(define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
1639  (invoke-complex-subtypep-arg1-method type1 type2))
1640
1641(define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
1642  (declare (ignore type1 type2))
1643  (values nil nil))
1644
1645(define-type-method (hairy :complex-=) (type1 type2)
1646  (if (and (unknown-ctype-p type2)
1647           (let* ((specifier2 (unknown-ctype-specifier type2))
1648                  (name2 (if (consp specifier2)
1649                           (car specifier2)
1650                           specifier2)))
1651             (info-type-kind name2)))
1652      (let ((type2 (specifier-type (unknown-ctype-specifier type2))))
1653        (if (unknown-ctype-p type2)
1654            (values nil nil)
1655            (type= type1 type2)))
1656  (values nil nil)))
1657
1658(define-type-method (hairy :simple-intersection :complex-intersection)
1659                    (type1 type2)
1660  (if (type= type1 type2)
1661    type1
1662    nil))
1663
1664
1665(define-type-method (hairy :simple-union) 
1666    (type1 type2)
1667  (if (type= type1 type2)
1668      type1
1669      nil))
1670
1671(define-type-method (hairy :simple-=) (type1 type2)
1672  (if (equal-but-no-car-recursion (hairy-ctype-specifier type1)
1673                                  (hairy-ctype-specifier type2))
1674      (values t t)
1675      (values nil nil)))
1676
1677
1678
1679(def-type-translator satisfies (&whole x fun)
1680  (unless (symbolp fun)
1681    (report-bad-arg fun 'symbol))
1682  (make-hairy-ctype :specifier x))
1683
1684
1685;;; Negation Ctypes
1686(defun make-negation-ctype (&key type (enumerable t))
1687  (%istruct 'negation-ctype
1688            (type-class-or-lose 'negation)
1689            enumerable
1690            type))
1691
1692(defun negation-ctype-p (x)
1693  (istruct-typep x 'negation-ctype))
1694
1695(setf (type-predicate 'negation-ctype) 'negation-ctype-p)
1696
1697
1698(define-type-method (negation :unparse) (x)
1699  `(not ,(type-specifier (negation-ctype-type x))))
1700
1701(define-type-method (negation :simple-subtypep) (type1 type2)
1702  (csubtypep (negation-ctype-type type2) (negation-ctype-type type1)))
1703
1704(define-type-method (negation :complex-subtypep-arg2) (type1 type2)
1705  (let* ((complement-type2 (negation-ctype-type type2))
1706         (intersection2 (type-intersection type1 complement-type2)))
1707    (if intersection2
1708        ;; FIXME: if uncertain, maybe try arg1?
1709        (type= intersection2 *empty-type*)
1710        (invoke-complex-subtypep-arg1-method type1 type2))))
1711
1712(define-type-method (negation :complex-subtypep-arg1) (type1 type2)
1713  (block nil
1714    ;; (Several logical truths in this block are true as long as
1715    ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
1716    ;; case with b=T where we actually reach this type method, but
1717    ;; we'll test for and exclude this case anyway, since future
1718    ;; maintenance might make it possible for it to end up in this
1719    ;; code.)
1720    (multiple-value-bind (equal certain)
1721        (type= type2 *universal-type*)
1722      (unless certain
1723        (return (values nil nil)))
1724      (when equal
1725        (return (values t t))))
1726    (let ((complement-type1 (negation-ctype-type type1)))
1727      ;; Do the special cases first, in order to give us a chance if
1728      ;; subtype/supertype relationships are hairy.
1729      (multiple-value-bind (equal certain) 
1730          (type= complement-type1 type2)
1731        ;; If a = b, ~a is not a subtype of b (unless b=T, which was
1732        ;; excluded above).
1733        (unless certain
1734          (return (values nil nil)))
1735        (when equal
1736          (return (values nil t))))
1737      ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
1738      ;; two built-in atomic type specifiers never be uncertain. This
1739      ;; is hard to do cleanly for the built-in types whose
1740      ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
1741      ;; we can do it with this hack, which uses our global knowledge
1742      ;; that our implementation of the type system uses disjoint
1743      ;; implementation types to represent disjoint sets (except when
1744      ;; types are contained in other types).  (This is a KLUDGE
1745      ;; because it's fragile. Various changes in internal
1746      ;; representation in the type system could make it start
1747      ;; confidently returning incorrect results.) -- WHN 2002-03-08
1748      (unless (or (type-might-contain-other-types-p complement-type1)
1749                  (type-might-contain-other-types-p type2))
1750        ;; Because of the way our types which don't contain other
1751        ;; types are disjoint subsets of the space of possible values,
1752        ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
1753        ;; is not T, as checked above).
1754        (return (values nil t)))
1755      ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
1756      ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
1757      ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
1758      ;; But a CSUBTYPEP relationship might still hold:
1759      (multiple-value-bind (equal certain)
1760          (csubtypep complement-type1 type2)
1761        ;; If a is a subtype of b, ~a is not a subtype of b (unless
1762        ;; b=T, which was excluded above).
1763        (unless certain
1764          (return (values nil nil)))
1765        (when equal
1766          (return (values nil t))))
1767      (multiple-value-bind (equal certain)
1768          (csubtypep type2 complement-type1)
1769        ;; If b is a subtype of a, ~a is not a subtype of b.  (FIXME:
1770        ;; That's not true if a=T. Do we know at this point that a is
1771        ;; not T?)
1772        (unless certain
1773          (return (values nil nil)))
1774        (when equal
1775          (return (values nil t))))
1776      ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
1777      ;; KLUDGE case above: Other cases here would rely on being able
1778      ;; to catch all possible cases, which the fragility of this type
1779      ;; system doesn't inspire me; for instance, if a is type= to ~b,
1780      ;; then we want T, T; if this is not the case and the types are
1781      ;; disjoint (have an intersection of *empty-type*) then we want
1782      ;; NIL, T; else if the union of a and b is the *universal-type*
1783      ;; then we want T, T. So currently we still claim to be unsure
1784      ;; about e.g. (subtypep '(not fixnum) 'single-float).
1785      ;;
1786      ;; OTOH we might still get here:
1787      (values nil nil))))
1788
1789(define-type-method (negation :complex-=) (type1 type2)
1790  ;; (NOT FOO) isn't equivalent to anything that's not a negation
1791  ;; type, except possibly a type that might contain it in disguise.
1792  (declare (ignore type2))
1793  (if (type-might-contain-other-types-p type1)
1794      (values nil nil)
1795      (values nil t)))
1796
1797(define-type-method (negation :simple-intersection) (type1 type2)
1798  (let ((not1 (negation-ctype-type type1))
1799        (not2 (negation-ctype-type type2)))
1800    (cond
1801      ((csubtypep not1 not2) type2)
1802      ((csubtypep not2 not1) type1)
1803      ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
1804      ;; method, below?  The clause would read
1805      ;;
1806      ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
1807      ;;
1808      ;; but with proper canonicalization of negation types, there's
1809      ;; no way of constructing two negation types with union of their
1810      ;; negations being the universal type.
1811      (t
1812       nil))))
1813
1814(define-type-method (negation :complex-intersection) (type1 type2)
1815  (cond
1816    ((csubtypep type1 (negation-ctype-type type2)) *empty-type*)
1817    ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*)
1818     type1)
1819    (t nil)))
1820
1821(define-type-method (negation :simple-union) (type1 type2)
1822  (let ((not1 (negation-ctype-type type1))
1823        (not2 (negation-ctype-type type2)))
1824    (cond
1825      ((csubtypep not1 not2) type1)
1826      ((csubtypep not2 not1) type2)
1827      ((eq (type-intersection not1 not2) *empty-type*)
1828       *universal-type*)
1829      (t nil))))
1830
1831(define-type-method (negation :complex-union) (type1 type2)
1832  (cond
1833    ((csubtypep (negation-ctype-type type2) type1) *universal-type*)
1834    ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*)
1835     type2)
1836    (t nil)))
1837
1838(define-type-method (negation :simple-=) (type1 type2)
1839  (type= (negation-ctype-type type1) (negation-ctype-type type2)))
1840
1841(def-type-translator not (typespec)
1842  (let* ((not-type (specifier-type typespec))
1843         (spec (type-specifier not-type)))
1844    (cond
1845      ;; canonicalize (NOT (NOT FOO))
1846      ((and (listp spec) (eq (car spec) 'not))
1847       (specifier-type (cadr spec)))
1848      ;; canonicalize (NOT NIL) and (NOT T)
1849      ((eq not-type *empty-type*) *universal-type*)
1850      ((eq not-type *universal-type*) *empty-type*)
1851      ((and (numeric-ctype-p not-type)
1852            (null (numeric-ctype-low not-type))
1853            (null (numeric-ctype-high not-type)))
1854       (make-negation-ctype :type not-type))
1855      ((numeric-ctype-p not-type)
1856       (type-union
1857        (make-negation-ctype
1858         :type (modified-numeric-type not-type :low nil :high nil))
1859        (cond
1860          ((null (numeric-ctype-low not-type))
1861           (modified-numeric-type
1862            not-type
1863            :low (let ((h (numeric-ctype-high not-type)))
1864                   (if (consp h) (car h) (list h)))
1865            :high nil))
1866          ((null (numeric-ctype-high not-type))
1867           (modified-numeric-type
1868            not-type
1869            :low nil
1870            :high (let ((l (numeric-ctype-low not-type)))
1871                    (if (consp l) (car l) (list l)))))
1872          (t (type-union
1873              (modified-numeric-type
1874               not-type
1875               :low nil
1876               :high (let ((l (numeric-ctype-low not-type)))
1877                       (if (consp l) (car l) (list l))))
1878              (modified-numeric-type
1879               not-type
1880               :low (let ((h (numeric-ctype-high not-type)))
1881                      (if (consp h) (car h) (list h)))
1882               :high nil))))))
1883      ((intersection-ctype-p not-type)
1884       (apply #'type-union
1885              (mapcar #'(lambda (x)
1886                          (specifier-type `(not ,(type-specifier x))))
1887                      (intersection-ctype-types not-type))))
1888      ((union-ctype-p not-type)
1889       (apply #'type-intersection
1890              (mapcar #'(lambda (x)
1891                          (specifier-type `(not ,(type-specifier x))))
1892                      (union-ctype-types not-type))))
1893      ((member-ctype-p not-type)
1894       (let ((members (member-ctype-members not-type)))
1895         (if (some #'floatp members)
1896           (let (floats)
1897             (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)))
1898               (when (member (car pair) members)
1899                 (assert (not (member (cdr pair) members)))
1900                 (push (cdr pair) floats)
1901                 (setf members (remove (car pair) members)))
1902               (when (member (cdr pair) members)
1903                 (assert (not (member (car pair) members)))
1904                 (push (car pair) floats)
1905                 (setf members (remove (cdr pair) members))))
1906             (apply #'type-intersection
1907                    (if (null members)
1908                      *universal-type*
1909                      (make-negation-ctype
1910                       :type (make-member-ctype :members members)))
1911                    (mapcar
1912                     (lambda (x)
1913                       (let ((type (ctype-of x)))
1914                         (type-union
1915                          (make-negation-ctype
1916                           :type (modified-numeric-type type
1917                                                          :low nil :high nil))
1918                            (modified-numeric-type type
1919                                                   :low nil :high (list x))
1920                            (make-member-ctype :members (list x))
1921                            (modified-numeric-type type
1922                                                   :low (list x) :high nil))))
1923                     floats)))
1924             (make-negation-ctype :type not-type))))
1925      ((and (cons-ctype-p not-type)
1926            (eq (cons-ctype-car-ctype not-type) *universal-type*)
1927            (eq (cons-ctype-cdr-ctype not-type) *universal-type*))
1928       (make-negation-ctype :type not-type))
1929      ((cons-ctype-p not-type)
1930       (type-union
1931        (make-negation-ctype :type (specifier-type 'cons))
1932        (cond
1933          ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*))
1934                (not (eq (cons-ctype-cdr-ctype not-type) *universal-type*)))
1935           (type-union
1936            (make-cons-ctype
1937             (specifier-type `(not ,(type-specifier
1938                                     (cons-ctype-car-ctype not-type))))
1939             *universal-type*)
1940            (make-cons-ctype
1941             *universal-type*
1942             (specifier-type `(not ,(type-specifier
1943                                     (cons-ctype-cdr-ctype not-type)))))))
1944          ((not (eq (cons-ctype-car-ctype not-type) *universal-type*))
1945           (make-cons-ctype
1946            (specifier-type `(not ,(type-specifier
1947                                    (cons-ctype-car-ctype not-type))))
1948            *universal-type*))
1949          ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))
1950           (make-cons-ctype
1951            *universal-type*
1952            (specifier-type `(not ,(type-specifier
1953                                    (cons-ctype-cdr-ctype not-type))))))
1954          (t (error "Weird CONS type ~S" not-type)))))
1955      (t (make-negation-ctype :type not-type)))))
1956
1957
1958;;;; Numeric types.
1959
1960;;; A list of all the float formats, in order of decreasing precision.
1961;;;
1962(eval-when (:compile-toplevel :load-toplevel :execute)
1963  (defconstant float-formats
1964    '(long-float double-float single-float short-float)))
1965
1966;;; The type of a float format.
1967;;;
1968(deftype float-format () `(member ,@float-formats))
1969
1970(defun type-bound-number (x)
1971  (if (consp x)
1972      (destructuring-bind (result) x result)
1973      x))
1974
1975(defun make-numeric-ctype (&key class 
1976                                format
1977                                (complexp :real)
1978                                low
1979                                high
1980                                enumerable
1981                                predicate)
1982  ;; if interval is empty
1983  (if (and low
1984           high
1985           (if (or (consp low) (consp high)) ; if either bound is exclusive
1986             (>= (type-bound-number low) (type-bound-number high))
1987             (> low high)))
1988    *empty-type*
1989    (multiple-value-bind (canonical-low canonical-high)
1990        (case class
1991          (integer
1992           ;; INTEGER types always have their LOW and HIGH bounds
1993           ;; represented as inclusive, not exclusive values.
1994           (values (if (consp low)
1995                     (1+ (type-bound-number low))
1996                     low)
1997                   (if (consp high)
1998                     (1- (type-bound-number high))
1999                     high)))
2000          (t 
2001           ;; no canonicalization necessary
2002           (values low high)))
2003      (when (and (eq class 'rational)
2004                 (integerp canonical-low)
2005                 (integerp canonical-high)
2006                 (= canonical-low canonical-high))
2007        (setf class 'integer))
2008      (%istruct 'numeric-ctype
2009                (type-class-or-lose 'number)
2010                enumerable
2011                class
2012                format
2013                complexp
2014                canonical-low
2015                canonical-high
2016                predicate))))
2017   
2018
2019(defun make-numeric-ctype-predicate (ctype)
2020  (let ((class (numeric-ctype-class ctype))
2021        (lo (numeric-ctype-low ctype))
2022        (hi (numeric-ctype-high ctype)))
2023    (if (eq class 'integer)
2024      (if (and hi
2025               lo
2026               (<= hi target::target-most-positive-fixnum)
2027               (>= lo target::target-most-negative-fixnum))     
2028        #'(lambda (n)
2029            (and (fixnump n)
2030                 (locally (declare (fixnum n hi lo))
2031                   (and (%i>= n lo)
2032                        (%i<= n hi)))))))))
2033
2034(defun numeric-ctype-p (x)
2035  (istruct-typep x 'numeric-ctype))
2036
2037(setf (type-predicate 'numeric-ctype) 'numeric-ctype-p)
2038
2039(define-type-method (number :simple-=) (type1 type2)
2040  (values
2041   (and (eq (numeric-ctype-class type1) (numeric-ctype-class type2))
2042        (eq (numeric-ctype-format type1) (numeric-ctype-format type2))
2043        (eq (numeric-ctype-complexp type1) (numeric-ctype-complexp type2))
2044        (equalp (numeric-ctype-low type1) (numeric-ctype-low type2))
2045        (equalp (numeric-ctype-high type1) (numeric-ctype-high type2)))
2046   t))
2047
2048(define-type-method (number :unparse) (type)
2049  (let* ((complexp (numeric-ctype-complexp type))
2050         (low (numeric-ctype-low type))
2051         (high (numeric-ctype-high type))
2052         (base (case (numeric-ctype-class type)
2053                 (integer 'integer)
2054                 (rational 'rational)
2055                 (float (or (numeric-ctype-format type) 'float))
2056                 (t 'real))))
2057    (let ((base+bounds
2058           (cond ((and (eq base 'integer) high low)
2059                  (let ((high-count (logcount high))
2060                        (high-length (integer-length high)))
2061                    (cond ((= low 0)
2062                           (cond ((= high 0) '(integer 0 0))
2063                                 ((= high 1) 'bit)
2064                                 ((and (= high-count high-length)
2065                                       (plusp high-length))
2066                                  `(unsigned-byte ,high-length))
2067                                 (t
2068                                  `(mod ,(1+ high)))))
2069                          ((and (= low target::target-most-negative-fixnum)
2070                                (= high target::target-most-positive-fixnum))
2071                           'fixnum)
2072                          ((and (= low (lognot high))
2073                                (= high-count high-length)
2074                                (> high-count 0))
2075                           `(signed-byte ,(1+ high-length)))
2076                          (t
2077                           `(integer ,low ,high)))))
2078                 (high `(,base ,(or low '*) ,high))
2079                 (low
2080                  (if (and (eq base 'integer) (= low 0))
2081                      'unsigned-byte
2082                      `(,base ,low)))
2083                 (t base))))
2084      (ecase complexp
2085        (:real
2086         base+bounds)
2087        (:complex
2088         (if (eq base+bounds 'real)
2089             'complex
2090             `(complex ,base+bounds)))
2091        ((nil)
2092         (assert (eq base+bounds 'real))
2093         'number)))))
2094
2095;;; Numeric-Bound-Test  --  Internal
2096;;;
2097;;;    Return true if X is "less than or equal" to Y, taking open bounds into
2098;;; consideration.  Closed is the predicate used to test the bound on a closed
2099;;; interval (e.g. <=), and Open is the predicate used on open bounds (e.g. <).
2100;;; Y is considered to be the outside bound, in the sense that if it is
2101;;; infinite (NIL), then the test suceeds, whereas if X is infinite, then the
2102;;; test fails (unless Y is also infinite).
2103;;;
2104;;;    This is for comparing bounds of the same kind, e.g. upper and upper.
2105;;; Use Numeric-Bound-Test* for different kinds of bounds.
2106;;;
2107(defmacro numeric-bound-test (x y closed open)
2108  `(cond ((not ,y) t)
2109           ((not ,x) nil)
2110           ((consp ,x)
2111            (if (consp ,y)
2112              (,closed (car ,x) (car ,y))
2113              (,closed (car ,x) ,y)))
2114           (t
2115            (if (consp ,y)
2116              (,open ,x (car ,y))
2117              (,closed ,x ,y)))))
2118
2119;;; Numeric-Bound-Test*  --  Internal
2120;;;
2121;;;    Used to compare upper and lower bounds.  This is different from the
2122;;; same-bound case:
2123;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we return true
2124;;;    if *either* arg is NIL.
2125;;; -- an open inner bound is "greater" and also squeezes the interval, causing
2126;;;    us to use the Open test for those cases as well.
2127;;;
2128(defmacro numeric-bound-test* (x y closed open)
2129  `(cond ((not ,y) t)
2130         ((not ,x) t)
2131         ((consp ,x)
2132          (if (consp ,y)
2133              (,open (car ,x) (car ,y))
2134              (,open (car ,x) ,y)))
2135         (t
2136          (if (consp ,y)
2137              (,open ,x (car ,y))
2138              (,closed ,x ,y)))))
2139
2140;;; Numeric-Bound-Max  --  Internal
2141;;;
2142;;;    Return whichever of the numeric bounds X and Y is "maximal" according to
2143;;; the predicates Closed (e.g. >=) and Open (e.g. >).  This is only meaningful
2144;;; for maximizing like bounds, i.e. upper and upper.  If Max-P is true, then
2145;;; we return NIL if X or Y is NIL, otherwise we return the other arg.
2146;;;
2147(defmacro numeric-bound-max (x y closed open max-p)
2148  (once-only ((n-x x)
2149              (n-y y))
2150    `(cond
2151      ((not ,n-x) ,(if max-p nil n-y))
2152      ((not ,n-y) ,(if max-p nil n-x))
2153      ((consp ,n-x)
2154       (if (consp ,n-y)
2155         (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
2156         (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
2157      (t
2158       (if (consp ,n-y)
2159         (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
2160         (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
2161
2162
2163(define-type-method (number :simple-subtypep) (type1 type2)
2164  (let ((class1 (numeric-ctype-class type1))
2165          (class2 (numeric-ctype-class type2))
2166          (complexp2 (numeric-ctype-complexp type2))
2167          (format2 (numeric-ctype-format type2))
2168          (low1 (numeric-ctype-low type1))
2169          (high1 (numeric-ctype-high type1))
2170          (low2 (numeric-ctype-low type2))
2171          (high2 (numeric-ctype-high type2)))
2172    ;;
2173    ;; If one is complex and the other isn't, they are disjoint.
2174    (cond ((not (or (eq (numeric-ctype-complexp type1) complexp2)
2175                        (null complexp2)))
2176             (values nil t))
2177            ;;
2178            ;; If the classes are specified and different, the types are
2179            ;; disjoint unless type2 is rational and type1 is integer.
2180            ((not (or (eq class1 class2) (null class2)
2181                        (and (eq class1 'integer) (eq class2 'rational))))
2182             (values nil t))
2183            ;;
2184            ;; If the float formats are specified and different, the types
2185            ;; are disjoint.
2186            ((not (or (eq (numeric-ctype-format type1) format2)
2187                        (null format2)))
2188             (values nil t))
2189            ;;
2190            ;; Check the bounds.
2191            ((and (numeric-bound-test low1 low2 >= >)
2192                    (numeric-bound-test high1 high2 <= <))
2193             (values t t))
2194            (t
2195             (values nil t)))))
2196
2197;(define-superclasses number (generic-number))
2198
2199;;; NUMERIC-TYPES-ADJACENT  --  Internal
2200;;;
2201;;;    If the high bound of Low is adjacent to the low bound of High, then
2202;;; return T, otherwise NIL.
2203;;;
2204(defun numeric-types-adjacent (low high)
2205  (let ((low-bound (numeric-ctype-high low))
2206        (high-bound (numeric-ctype-low high)))
2207    (cond ((not (and low-bound high-bound)) nil)
2208            ((consp low-bound)
2209             (eql (car low-bound) high-bound))
2210            ((consp high-bound)
2211             (eql (car high-bound) low-bound))
2212            ((and (eq (numeric-ctype-class low) 'integer)
2213                    (eq (numeric-ctype-class high) 'integer))
2214             (eql (1+ low-bound) high-bound))
2215            (t
2216             nil))))
2217
2218;;;
2219;;; Return a numeric type that is a supertype for both type1 and type2.
2220;;;
2221(define-type-method (number :simple-union) (type1 type2)
2222  (declare (type numeric-ctype type1 type2))
2223  (cond ((csubtypep type1 type2) type2)
2224        ((csubtypep type2 type1) type1)
2225        (t
2226         (let ((class1 (numeric-ctype-class type1))
2227               (format1 (numeric-ctype-format type1))
2228               (complexp1 (numeric-ctype-complexp type1))
2229               (class2 (numeric-ctype-class type2))
2230               (format2 (numeric-ctype-format type2))
2231               (complexp2 (numeric-ctype-complexp type2)))
2232           (cond
2233             ((and (eq class1 class2)
2234                   (eq format1 format2)
2235                   (eq complexp1 complexp2)
2236                   (or (numeric-types-intersect type1 type2)
2237                       (numeric-types-adjacent type1 type2)
2238                       (numeric-types-adjacent type2 type1)))
2239              (make-numeric-ctype
2240               :class class1
2241               :format format1
2242               :complexp complexp1
2243               :low (numeric-bound-max (numeric-ctype-low type1)
2244                                       (numeric-ctype-low type2)
2245                                       <= < t)
2246               :high (numeric-bound-max (numeric-ctype-high type1)
2247                                        (numeric-ctype-high type2)
2248                                        >= > t)))
2249             ;; FIXME: These two clauses are almost identical, and the
2250             ;; consequents are in fact identical in every respect.
2251             ((and (eq class1 'rational)
2252                   (eq class2 'integer)
2253                   (eq format1 format2)
2254                   (eq complexp1 complexp2)
2255                   (integerp (numeric-ctype-low type2))
2256                   (integerp (numeric-ctype-high type2))
2257                   (= (numeric-ctype-low type2) (numeric-ctype-high type2))
2258                   (or (numeric-types-adjacent type1 type2)
2259                       (numeric-types-adjacent type2 type1)))
2260              (make-numeric-ctype
2261               :class 'rational
2262               :format format1
2263               :complexp complexp1
2264               :low (numeric-bound-max (numeric-ctype-low type1)
2265                                       (numeric-ctype-low type2)
2266                                       <= < t)
2267               :high (numeric-bound-max (numeric-ctype-high type1)
2268                                        (numeric-ctype-high type2)
2269                                        >= > t)))
2270             ((and (eq class1 'integer)
2271                   (eq class2 'rational)
2272                   (eq format1 format2)
2273                   (eq complexp1 complexp2)
2274                   (integerp (numeric-ctype-low type1))
2275                   (integerp (numeric-ctype-high type1))
2276                   (= (numeric-ctype-low type1) (numeric-ctype-high type1))
2277                   (or (numeric-types-adjacent type1 type2)
2278                       (numeric-types-adjacent type2 type1)))
2279              (make-numeric-ctype
2280               :class 'rational
2281               :format format1
2282               :complexp complexp1
2283               :low (numeric-bound-max (numeric-ctype-low type1)
2284                                       (numeric-ctype-low type2)
2285                                       <= < t)
2286               :high (numeric-bound-max (numeric-ctype-high type1)
2287                                        (numeric-ctype-high type2)
2288                                        >= > t)))
2289             (t nil))))))
2290
2291(setf (info-type-kind 'number) :primitive
2292      (info-type-builtin 'number) (make-numeric-ctype :complexp nil))
2293
2294(def-type-translator complex (&optional spec)
2295  (if (eq spec '*)
2296      (make-numeric-ctype :complexp :complex)
2297      (labels ((not-numeric ()
2298                 (error "Component type for Complex is not numeric: ~S." spec))
2299               (not-real ()
2300                 (error "Component type for Complex is not a subtype of real: ~S." spec))
2301               (complex1 (component-type)
2302                 (unless (numeric-ctype-p component-type)
2303                   (not-numeric))
2304                 (when (eq (numeric-ctype-complexp component-type) :complex)
2305                   (not-real))
2306                 (let ((res (copy-uvector component-type)))
2307                   (setf (numeric-ctype-complexp res) :complex)
2308                   (setf (numeric-ctype-predicate res) nil) ; <<
2309                   res))
2310               (do-complex (ctype)
2311                 (cond
2312                   ((eq ctype *empty-type*) *empty-type*)
2313                   ((eq ctype *universal-type*) (not-real))
2314                   ((numeric-ctype-p ctype) (complex1 ctype))
2315                   ((union-ctype-p ctype)
2316                    (apply #'type-union
2317                           (mapcar #'do-complex (union-ctype-types ctype))))
2318                   ((member-ctype-p ctype)
2319                    (apply #'type-union
2320                           (mapcar (lambda (x) (do-complex (ctype-of x)))
2321                                   (member-ctype-members ctype))))
2322                   ((and (intersection-ctype-p ctype)
2323                         ;; just enough to handle simple types like RATIO.
2324                         (let ((numbers (remove-if-not
2325                                         #'numeric-ctype-p
2326                                         (intersection-ctype-types ctype))))
2327                           (and (car numbers)
2328                                (null (cdr numbers))
2329                                (eq (numeric-ctype-complexp (car numbers)) :real)
2330                                (complex1 (car numbers))))))
2331                   (t                   ; punt on harder stuff for now
2332                    (not-real)))))
2333        (let ((ctype (specifier-type spec)))
2334          (do-complex ctype)))))
2335
2336;;; Check-Bound  --  Internal
2337;;;
2338;;;    Check that X is a well-formed numeric bound of the specified Type.
2339;;; If X is *, return NIL, otherwise return the bound.
2340;;;
2341(defmacro check-bound (x type)
2342  `(cond ((eq ,x '*) nil)
2343           ((or (typep ,x ',type)
2344                (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x))))
2345            ,x)
2346           (t
2347            (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x))))
2348
2349(def-type-translator integer (&optional low high)
2350  (let* ((l (check-bound low integer))
2351         (lb (if (consp l) (1+ (car l)) l))
2352         (h (check-bound high integer))
2353         (hb (if (consp h) (1- (car h)) h)))
2354    (if (and hb lb (< hb lb))
2355      *empty-type*
2356      (make-numeric-ctype :class 'integer  :complexp :real
2357                          :enumerable (not (null (and l h)))
2358                          :low lb
2359                          :high hb))))
2360
2361(deftype mod (n)
2362  (unless (and (integerp n) (> n 0))
2363    (error "Bad N specified for MOD type specifier: ~S." n))
2364  `(integer 0 ,(1- n)))
2365
2366
2367(defmacro def-bounded-type (type class format)
2368  `(def-type-translator ,type (&optional low high)
2369     (let ((lb (check-bound low ,type))
2370             (hb (check-bound high ,type)))
2371       (unless (numeric-bound-test* lb hb <= <)
2372           (error "Lower bound ~S is not less than upper bound ~S." low high))
2373       (make-numeric-ctype :class ',class :format ',format :low lb :high hb))))
2374
2375(def-bounded-type rational rational nil)
2376
2377(defun coerce-bound (bound type inner-coerce-bound-fun)
2378  (declare (type function inner-coerce-bound-fun))
2379  (cond ((eql bound '*)
2380         bound)
2381        ((consp bound)
2382         (destructuring-bind (inner-bound) bound
2383           (list (funcall inner-coerce-bound-fun inner-bound type))))
2384        (t
2385         (funcall inner-coerce-bound-fun bound type))))
2386
2387(defun inner-coerce-real-bound (bound type)
2388  (ecase type
2389    (rational (rationalize bound))
2390    (float (if (floatp bound)
2391               bound
2392               ;; Coerce to the widest float format available, to
2393               ;; avoid unnecessary loss of precision:
2394               (coerce bound 'long-float)))))
2395
2396(defun coerced-real-bound (bound type)
2397  (coerce-bound bound type #'inner-coerce-real-bound))
2398
2399(defun coerced-float-bound (bound type)
2400  (coerce-bound bound type #'coerce))
2401
2402(def-type-translator real (&optional (low '*) (high '*))
2403  (specifier-type `(or (float ,(coerced-real-bound  low 'float)
2404                              ,(coerced-real-bound high 'float))
2405                       (rational ,(coerced-real-bound  low 'rational)
2406                                 ,(coerced-real-bound high 'rational)))))
2407
2408(def-type-translator float (&optional (low '*) (high '*))
2409  (specifier-type 
2410   `(or (single-float ,(coerced-float-bound  low 'single-float)
2411                      ,(coerced-float-bound high 'single-float))
2412        (double-float ,(coerced-float-bound  low 'double-float)
2413                      ,(coerced-float-bound high 'double-float)))))
2414
2415(def-bounded-type float float nil)
2416(def-bounded-type real nil nil)
2417
2418(defmacro define-float-format (f)
2419  `(def-bounded-type ,f float ,f))
2420
2421(define-float-format short-float)
2422(define-float-format single-float)
2423(define-float-format double-float)
2424(define-float-format long-float)
2425
2426(defun numeric-types-intersect (type1 type2)
2427  (declare (type numeric-ctype type1 type2))
2428  (let* ((class1 (numeric-ctype-class type1))
2429         (class2 (numeric-ctype-class type2))
2430         (complexp1 (numeric-ctype-complexp type1))
2431         (complexp2 (numeric-ctype-complexp type2))
2432         (format1 (numeric-ctype-format type1))
2433         (format2 (numeric-ctype-format type2))
2434         (low1 (numeric-ctype-low type1))
2435         (high1 (numeric-ctype-high type1))
2436         (low2 (numeric-ctype-low type2))
2437         (high2 (numeric-ctype-high type2)))
2438    ;;
2439    ;; If one is complex and the other isn't, then they are disjoint.
2440    (cond ((not (or (eq complexp1 complexp2)
2441                    (null complexp1) (null complexp2)))
2442           nil)
2443          ;;
2444          ;; If either type is a float, then the other must either be specified
2445          ;; to be a float or unspecified.  Otherwise, they are disjoint.
2446          ((and (eq class1 'float) (not (member class2 '(float nil)))) nil)
2447          ((and (eq class2 'float) (not (member class1 '(float nil)))) nil)
2448          ;;
2449          ;; If the float formats are specified and different, the types
2450          ;; are disjoint.
2451          ((not (or (eq format1 format2) (null format1) (null format2)))
2452           nil)
2453          (t
2454           ;;
2455           ;; Check the bounds.  This is a bit odd because we must always have
2456           ;; the outer bound of the interval as the second arg.
2457           (if (numeric-bound-test high1 high2 <= <)
2458             (or (and (numeric-bound-test low1 low2 >= >)
2459                      (numeric-bound-test* low1 high2 <= <))
2460                 (and (numeric-bound-test low2 low1 >= >)
2461                      (numeric-bound-test* low2 high1 <= <)))
2462             (or (and (numeric-bound-test* low2 high1 <= <)
2463                      (numeric-bound-test low2 low1 >= >))
2464                 (and (numeric-bound-test high2 high1 <= <)
2465                      (numeric-bound-test* high2 low1 >= >))))))))
2466
2467;;; Round-Numeric-Bound  --  Internal
2468;;;
2469;;;    Take the numeric bound X and convert it into something that can be used
2470;;; as a bound in a numeric type with the specified Class and Format.  If up-p
2471;;; is true, then we round up as needed, otherwise we round down.  Up-p true
2472;;; implies that X is a lower bound, i.e. (N) > N.
2473;;;
2474;;; This is used by Numeric-Type-Intersection to mash the bound into the
2475;;; appropriate type number.  X may only be a float when Class is Float.
2476;;;
2477;;; ### Note: it is possible for the coercion to a float to overflow or
2478;;; underflow.  This happens when the bound doesn't fit in the specified
2479;;; format.  In this case, we should really return the appropriate
2480;;; {Most | Least}-{Positive | Negative}-XXX-Float float of desired format.
2481;;; But these conditions aren't currently signalled in any useful way.
2482;;;
2483;;; Also, when converting an open rational bound into a float we should
2484;;; probably convert it to a closed bound of the closest float in the specified
2485;;; format.  In general, open float bounds are fucked.
2486;;;
2487(defun round-numeric-bound (x class format up-p)
2488  (if x
2489    (let ((cx (if (consp x) (car x) x)))
2490        (ecase class
2491          ((nil rational) x)
2492          (integer
2493           (if (and (consp x) (integerp cx))
2494             (if up-p (1+ cx) (1- cx))
2495             (if up-p (ceiling cx) (floor cx))))
2496          (float
2497           (let ((res (if format (coerce cx format) (float cx))))
2498             (if (consp x) (list res) res)))))
2499    nil))
2500
2501;;; Number :Simple-Intersection type method  --  Internal
2502;;;
2503;;;    Handle the case of Type-Intersection on two numeric types.  We use
2504;;; Types-Intersect to throw out the case of types with no intersection.  If an
2505;;; attribute in Type1 is unspecified, then we use Type2's attribute, which
2506;;; must be at least as restrictive.  If the types intersect, then the only
2507;;; attributes that can be specified and different are the class and the
2508;;; bounds.
2509;;;
2510;;;    When the class differs, we use the more restrictive class.  The only
2511;;; interesting case is rational/integer, since rational includes integer.
2512;;;
2513;;;    We make the result lower (upper) bound the maximum (minimum) of the
2514;;; argument lower (upper) bounds.  We convert the bounds into the
2515;;; appropriate numeric type before maximizing.  This avoids possible confusion
2516;;; due to mixed-type comparisons (but I think the result is the same).
2517;;;
2518(define-type-method (number :simple-intersection) (type1 type2)
2519  (declare (type numeric-type type1 type2))
2520  (if (numeric-types-intersect type1 type2)
2521    (let* ((class1 (numeric-ctype-class type1))
2522           (class2 (numeric-ctype-class type2))
2523           (class (ecase class1
2524                    ((nil) class2)
2525                    ((integer float) class1)
2526                    (rational (if (eq class2 'integer) 'integer 'rational))))
2527           (format (or (numeric-ctype-format type1)
2528                       (numeric-ctype-format type2))))
2529      (make-numeric-ctype
2530       :class class
2531       :format format
2532       :complexp (or (numeric-ctype-complexp type1)
2533                     (numeric-ctype-complexp type2))
2534       :low (numeric-bound-max
2535             (round-numeric-bound (numeric-ctype-low type1)
2536                                  class format t)
2537             (round-numeric-bound (numeric-ctype-low type2)
2538                                  class format t)
2539             > >= nil)
2540       :high (numeric-bound-max
2541              (round-numeric-bound (numeric-ctype-high type1)
2542                                   class format nil)
2543              (round-numeric-bound (numeric-ctype-high type2)
2544                                   class format nil)
2545              < <= nil)))
2546    *empty-type*))
2547
2548;;; Float-Format-Max  --  Interface
2549;;;
2550;;;    Given two float formats, return the one with more precision.  If either
2551;;; one is null, return NIL.
2552;;;
2553(defun float-format-max (f1 f2)
2554  (when (and f1 f2)
2555    (dolist (f float-formats (error "Bad float format: ~S." f1))
2556      (when (or (eq f f1) (eq f f2))
2557          (return f)))))
2558
2559
2560;;; Numeric-Contagion  --  Interface
2561;;;
2562;;;    Return the result of an operation on Type1 and Type2 according to the
2563;;; rules of numeric contagion.  This is always NUMBER, some float format
2564;;; (possibly complex) or RATIONAL.  Due to rational canonicalization, there
2565;;; isn't much we can do here with integers or rational complex numbers.
2566;;;
2567;;;    If either argument is not a Numeric-Type, then return NUMBER.  This is
2568;;; useful mainly for allowing types that are technically numbers, but not a
2569;;; Numeric-Type.
2570;;;
2571(defun numeric-contagion (type1 type2)
2572  (if (and (numeric-ctype-p type1) (numeric-ctype-p type2))
2573    (let ((class1 (numeric-ctype-class type1))
2574            (class2 (numeric-ctype-class type2))
2575            (format1 (numeric-ctype-format type1))
2576            (format2 (numeric-ctype-format type2))
2577            (complexp1 (numeric-ctype-complexp type1))
2578            (complexp2 (numeric-ctype-complexp type2)))
2579        (cond ((or (null complexp1)
2580                   (null complexp2))
2581               (specifier-type 'number))
2582              ((eq class1 'float)
2583               (make-numeric-ctype
2584                  :class 'float
2585                  :format (ecase class2
2586                              (float (float-format-max format1 format2))
2587                              ((integer rational) format1)
2588                              ((nil)
2589                               ;; A double-float with any real number is a
2590                               ;; double-float.
2591                               (if (eq format1 'double-float)
2592                                 'double-float
2593                                 nil)))
2594                  :complexp (if (or (eq complexp1 :complex)
2595                                    (eq complexp2 :complex))
2596                              :complex
2597                              :real)))
2598              ((eq class2 'float) (numeric-contagion type2 type1))
2599              ((and (eq complexp1 :real) (eq complexp2 :real))
2600               (make-numeric-ctype
2601                  :class (and class1 class2 'rational)
2602                  :complexp :real))
2603              (t
2604               (specifier-type 'number))))
2605    (specifier-type 'number)))
2606
2607
2608
2609
2610;;;; Array types:
2611
2612;;; The Array-Type is used to represent all array types, including things such
2613;;; as SIMPLE-STRING.
2614;;;
2615
2616(defun make-array-ctype (&key
2617                         (dimensions '*)
2618                         (complexp '*)
2619                         element-type
2620                         (specialized-element-type *wild-type*))
2621  (%istruct 'array-ctype
2622            (type-class-or-lose 'array)
2623            nil
2624            dimensions
2625            complexp
2626            element-type
2627            specialized-element-type
2628            (unless (eq specialized-element-type *wild-type*)
2629              (ctype-subtype specialized-element-type))))
2630
2631(defun array-ctype-p (x) (istruct-typep x 'array-ctype))
2632(setf (type-predicate 'array-ctype) 'array-ctype-p)
2633
2634;;; Specialized-Element-Type-Maybe  --  Internal
2635;;;
2636;;;      What this does depends on the setting of the
2637;;; *use-implementation-types* switch.  If true, return the specialized element
2638;;; type, otherwise return the original element type.
2639;;;
2640(defun specialized-element-type-maybe (type)
2641  (declare (type array-ctype type))
2642  (if *use-implementation-types*
2643    (array-ctype-specialized-element-type type)
2644    (array-ctype-element-type type)))
2645
2646(define-type-method (array :simple-=) (type1 type2)
2647  (if (or (unknown-ctype-p (array-ctype-element-type type1))
2648          (unknown-ctype-p (array-ctype-element-type type2)))
2649    (multiple-value-bind (equalp certainp)
2650        (type= (array-ctype-element-type type1)
2651               (array-ctype-element-type type2))
2652      (assert (not (and (not equalp) certainp)))
2653      (values equalp certainp))
2654    (values (and (equal (array-ctype-dimensions type1)
2655                        (array-ctype-dimensions type2))
2656                 (eq (array-ctype-complexp type1)
2657                     (array-ctype-complexp type2))
2658                 (type= (specialized-element-type-maybe type1)
2659                        (specialized-element-type-maybe type2)))
2660            t)))
2661
2662(define-type-method (array :unparse) (type)
2663  (let ((dims (array-ctype-dimensions type))
2664          (eltype (type-specifier (array-ctype-element-type type)))
2665          (complexp (array-ctype-complexp type)))
2666    (cond ((eq dims '*)
2667             (if (eq eltype '*)
2668               (if complexp 'array 'simple-array)
2669               (if complexp `(array ,eltype) `(simple-array ,eltype))))
2670            ((= (length dims) 1) 
2671             (if complexp
2672               (if (eq (car dims) '*)
2673                   (case eltype
2674                     (bit 'bit-vector)
2675                     ((character base-char) 'base-string)
2676                     (* 'vector)
2677                     (t `(vector ,eltype)))
2678                   (case eltype
2679                     (bit `(bit-vector ,(car dims)))
2680                     ((character base-char) `(base-string ,(car dims)))
2681                     (t `(vector ,eltype ,(car dims)))))
2682               (if (eq (car dims) '*)
2683                   (case eltype
2684                     (bit 'simple-bit-vector)
2685                     ((base-char character) 'simple-base-string)
2686                     ((t) 'simple-vector)
2687                     (t `(simple-array ,eltype (*))))
2688                   (case eltype
2689                     (bit `(simple-bit-vector ,(car dims)))
2690                     ((base-char character) `(simple-base-string ,(car dims)))
2691                     ((t) `(simple-vector ,(car dims)))
2692                     (t `(simple-array ,eltype ,dims))))))
2693            (t
2694             (if complexp
2695               `(array ,eltype ,dims)
2696               `(simple-array ,eltype ,dims))))))
2697
2698(define-type-method (array :simple-subtypep) (type1 type2)
2699  (let ((dims1 (array-ctype-dimensions type1))
2700        (dims2 (array-ctype-dimensions type2))
2701        (complexp2 (array-ctype-complexp type2)))
2702    (cond (;; not subtypep unless dimensions are compatible
2703           (not (or (eq dims2 '*)
2704                    (and (not (eq dims1 '*))
2705                         (= (length (the list dims1))
2706                            (length (the list dims2)))
2707                         (every (lambda (x y)
2708                                  (or (eq y '*) (eql x y)))
2709                                (the list dims1)
2710                                (the list dims2)))))
2711           (values nil t))
2712          ;; not subtypep unless complexness is compatible
2713          ((not (or (eq complexp2 :maybe)
2714                    (eq (array-ctype-complexp type1) complexp2)))
2715           (values nil t))
2716          ;; Since we didn't fail any of the tests above, we win
2717          ;; if the TYPE2 element type is wild.
2718          ((eq (array-ctype-element-type type2) *wild-type*)
2719           (values t t))
2720          (;; Since we didn't match any of the special cases above, we
2721           ;; can't give a good answer unless both the element types
2722           ;; have been defined.
2723           (or (unknown-ctype-p (array-ctype-element-type type1))
2724               (unknown-ctype-p (array-ctype-element-type type2)))
2725           (values nil nil))
2726          (;; Otherwise, the subtype relationship holds iff the
2727           ;; types are equal, and they're equal iff the specialized
2728           ;; element types are identical.
2729           t
2730           (values (type= (specialized-element-type-maybe type1)
2731                          (specialized-element-type-maybe type2))
2732                   t)))))
2733
2734; (define-superclasses array (string string) (vector vector) (array))
2735
2736
2737(defun array-types-intersect (type1 type2)
2738  (declare (type array-ctype type1 type2))
2739  (let ((dims1 (array-ctype-dimensions type1))
2740        (dims2 (array-ctype-dimensions type2))
2741        (complexp1 (array-ctype-complexp type1))
2742        (complexp2 (array-ctype-complexp type2)))
2743    ;; See whether dimensions are compatible.
2744    (cond ((not (or (eq dims1 '*) (eq dims2 '*)
2745                    (and (= (length dims1) (length dims2))
2746                         (every (lambda (x y)
2747                                  (or (eq x '*) (eq y '*) (= x y)))
2748                                dims1 dims2))))
2749           (values nil t))
2750          ;; See whether complexpness is compatible.
2751          ((not (or (eq complexp1 :maybe)
2752                    (eq complexp2 :maybe)
2753                    (eq complexp1 complexp2)))
2754           (values nil t))
2755          ((or (eq (array-ctype-specialized-element-type type1) *wild-type*)
2756               (eq (array-ctype-specialized-element-type type2) *wild-type*)
2757               (type= (specialized-element-type-maybe type1)
2758                      (specialized-element-type-maybe type2)))
2759           (values t t))
2760          (t
2761           (values nil t)))))
2762
2763(define-type-method (array :simple-intersection) (type1 type2)
2764  (declare (type array-ctype type1 type2))
2765  (if (array-types-intersect type1 type2)
2766    (let ((dims1 (array-ctype-dimensions type1))
2767          (dims2 (array-ctype-dimensions type2))
2768          (complexp1 (array-ctype-complexp type1))
2769          (complexp2 (array-ctype-complexp type2))
2770          (eltype1 (array-ctype-element-type type1))
2771          (eltype2 (array-ctype-element-type type2)))
2772      (specialize-array-type
2773       (make-array-ctype
2774        :dimensions (cond ((eq dims1 '*) dims2)
2775                          ((eq dims2 '*) dims1)
2776                          (t
2777                           (mapcar #'(lambda (x y) (if (eq x '*) y x))
2778                                   dims1 dims2)))
2779        :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
2780        :element-type (cond
2781                        ((eq eltype1 *wild-type*) eltype2)
2782                        ((eq eltype2 *wild-type*) eltype1)
2783                        (t (type-intersection eltype1 eltype2))))))
2784      *empty-type*))
2785
2786;;; Check-Array-Dimensions  --  Internal
2787;;;
2788;;;    Check a supplied dimension list to determine if it is legal.
2789;;;
2790(defun check-array-dimensions (dims)
2791  (typecase dims
2792    ((member *) dims)
2793    (integer
2794     (when (minusp dims)
2795       (signal-program-error "Arrays can't have a negative number of dimensions: ~D." dims))
2796     (when (>= dims array-rank-limit)
2797       (signal-program-error "Array type has too many dimensions: ~S." dims))
2798     (make-list dims :initial-element '*))
2799    (list
2800     (when (>= (length dims) array-rank-limit)
2801       (signal-program-error "Array type has too many dimensions: ~S." dims))
2802     (dolist (dim dims)
2803       (unless (eq dim '*)
2804           (unless (and (integerp dim)
2805                          (>= dim 0) (< dim array-dimension-limit))
2806             (signal-program-error "Bad dimension in array type: ~S." dim))))
2807     dims)
2808    (t
2809     (signal-program-error "Array dimensions is not a list, integer or *:~%  ~S"
2810                           dims))))
2811
2812(def-type-translator array (&optional element-type dimensions)
2813  (specialize-array-type
2814   (make-array-ctype :dimensions (check-array-dimensions dimensions)
2815                     :complexp :maybe
2816                     :element-type (specifier-type element-type))))
2817
2818(def-type-translator simple-array (&optional element-type dimensions)
2819  (specialize-array-type
2820   (make-array-ctype :dimensions (check-array-dimensions dimensions)
2821                         :element-type (specifier-type element-type)
2822                         :complexp nil)))
2823
2824;;; Order matters here.
2825(defparameter specialized-array-element-types
2826  '(nil bit (unsigned-byte 8) (signed-byte 8) (unsigned-byte 16)
2827    (signed-byte 16) (unsigned-byte 32) #+32-bit-target fixnum (signed-byte 32)
2828    #+64-bit-target (unsigned-byte 64)
2829    #+64-bit-target fixnum
2830    #+64-bit-target (signed-byte 64)
2831    character  short-float double-float))
2832
2833(defun specialize-array-type (type)
2834  (let* ((eltype (array-ctype-element-type type))
2835         (specialized-type (if (eq eltype *wild-type*)
2836                             *wild-type*
2837                             (dolist (stype-name specialized-array-element-types
2838                                      *universal-type*)
2839                               (let ((stype (specifier-type stype-name)))
2840                                 (when (csubtypep eltype stype)
2841                                   (return stype)))))))
2842   
2843    (setf (array-ctype-specialized-element-type type) specialized-type
2844          (array-ctype-typecode type) (unless (eq specialized-type *wild-type*)
2845                                        (ctype-subtype specialized-type)))
2846    type))
2847
2848
2849;;;; Member types.
2850
2851;;; The Member-Type represents uses of the MEMBER type specifier.  We bother
2852;;; with this at this level because MEMBER types are fairly important and union
2853;;; and intersection are well defined.
2854
2855(defun %make-member-ctype (members)
2856  (%istruct 'member-ctype
2857            (type-class-or-lose 'member)
2858            t
2859            members))
2860
2861(defun make-member-ctype (&key members)
2862  (let* ((singlep (subsetp '(-0.0f0 0.0f0) members))
2863         (doublep (subsetp '(-0.0d0 0.0d0) members))
2864         (union-types
2865          (if singlep
2866            (if doublep
2867              (list *ctype-of-single-float-0* *ctype-of-double-float-0*)
2868              (list *ctype-of-single-float-0*))
2869            (if doublep
2870              (list *ctype-of-double-float-0*)))))
2871    (if union-types
2872      (progn
2873        (if singlep
2874          (setq members (set-difference '(-0.0f0 0.0f0) members)))
2875        (if doublep
2876          (setq members (set-difference '(-0.d00 0.0d0) members)))
2877        (make-union-ctype (if (null members)
2878                            union-types
2879                            (cons (%make-member-ctype members) union-types))))
2880      (%make-member-ctype members))))
2881       
2882
2883(defun member-ctype-p (x) (istruct-typep x 'member-ctype))
2884(setf (type-predicate 'member-ctype) 'member-ctype-p)
2885
2886(define-type-method (member :unparse) (type)
2887  (if (type= type (specifier-type 'standard-char))
2888    'standard-char
2889    (let ((members (member-ctype-members type)))
2890      (if (equal members '(nil))
2891        'null
2892        `(member ,@members)))))
2893
2894(define-type-method (member :simple-subtypep) (type1 type2)
2895  (values (subsetp (member-ctype-members type1) (member-ctype-members type2))
2896            t))
2897
2898
2899(define-type-method (member :complex-subtypep-arg1) (type1 type2)
2900  (every/type (swapped-args-fun #'ctypep)
2901              type2
2902              (member-ctype-members type1)))
2903
2904;;; We punt if the odd type is enumerable and intersects with the member type.
2905;;; If not enumerable, then it is definitely not a subtype of the member type.
2906;;;
2907(define-type-method (member :complex-subtypep-arg2) (type1 type2)
2908  (cond ((not (ctype-enumerable type1)) (values nil t))
2909          ((types-intersect type1 type2)
2910           (invoke-complex-subtypep-arg1-method type1 type2))
2911          (t
2912           (values nil t))))
2913
2914(define-type-method (member :simple-intersection) (type1 type2)
2915  (let ((mem1 (member-ctype-members type1))
2916        (mem2 (member-ctype-members type2)))
2917    (values (cond ((subsetp mem1 mem2) type1)
2918                  ((subsetp mem2 mem1) type2)
2919                  (t
2920                   (let ((res (intersection mem1 mem2)))
2921                     (if res
2922                       (make-member-ctype :members res)
2923                       *empty-type*))))
2924            t)))
2925
2926(define-type-method (member :complex-intersection) (type1 type2)
2927  (block PUNT
2928    (collect ((members))
2929      (let ((mem2 (member-ctype-members type2)))
2930        (dolist (member mem2)
2931          (multiple-value-bind (val win) (ctypep member type1)
2932            (unless win
2933              (return-from punt nil))
2934            (when val (members member))))
2935        (cond ((subsetp mem2 (members)) type2)
2936              ((null (members)) *empty-type*)
2937              (t
2938               (make-member-ctype :members (members))))))))
2939
2940;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
2941;;; type, and the member/union interaction is handled by the union type
2942;;; method.
2943(define-type-method (member :simple-union) (type1 type2)
2944  (let ((mem1 (member-ctype-members type1))
2945        (mem2 (member-ctype-members type2)))
2946    (cond ((subsetp mem1 mem2) type2)
2947          ((subsetp mem2 mem1) type1)
2948          (t
2949           (make-member-ctype :members (union mem1 mem2))))))
2950
2951
2952(define-type-method (member :simple-=) (type1 type2)
2953  (let ((mem1 (member-ctype-members type1))
2954        (mem2 (member-ctype-members type2)))
2955    (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
2956            t)))
2957
2958(define-type-method (member :complex-=) (type1 type2)
2959  (if (ctype-enumerable type1)
2960    (multiple-value-bind (val win)
2961                               (csubtypep type2 type1)
2962        (if (or val (not win))
2963        (values nil nil)
2964        (values nil t)))
2965    (values nil t)))
2966
2967(def-type-translator member (&rest members)
2968  (if members
2969    (collect ((non-numbers) (numbers))
2970      (dolist (m (remove-duplicates members))
2971        (if (and (numberp m)
2972                 (not (and (floatp m) (zerop m))))
2973          (numbers (ctype-of m))
2974          (non-numbers m)))
2975      (apply #'type-union
2976             (if (non-numbers)
2977               (make-member-ctype :members (non-numbers))
2978               *empty-type*)
2979             (numbers)))
2980    *empty-type*))
2981
2982
2983
2984;;;; Union types:
2985
2986;;; The Union-Type represents uses of the OR type specifier which can't be
2987;;; canonicalized to something simpler.  Canonical form:
2988;;;
2989;;; 1] There is never more than one Member-Type component.
2990;;; 2] There are never any Union-Type components.
2991;;;
2992
2993(defun make-union-ctype (types)
2994  (declare (list types))
2995  (%istruct 'union-ctype
2996            (type-class-or-lose 'union)
2997            (every #'(lambda (x) (ctype-enumerable x)) types)
2998            types))
2999
3000(defun union-ctype-p (x) (istruct-typep x 'union-ctype))
3001(setf (type-predicate 'union-ctype) 'union-ctype-p)
3002
3003
3004;;;    If List, then return that, otherwise the OR of the component types.
3005;;;
3006(define-type-method (union :unparse) (type)
3007  (declare (type ctype type))
3008    (cond
3009      ((type= type (specifier-type 'list)) 'list)
3010      ((type= type (specifier-type 'float)) 'float)
3011      ((type= type (specifier-type 'real)) 'real)
3012      ((type= type (specifier-type 'sequence)) 'sequence)
3013      ((type= type (specifier-type 'bignum)) 'bignum)
3014      (t `(or ,@(mapcar #'type-specifier (union-ctype-types type))))))
3015
3016
3017
3018(define-type-method (union :simple-=) (type1 type2)
3019  (multiple-value-bind (subtype certain?)
3020      (csubtypep type1 type2)
3021    (if subtype
3022      (csubtypep type2 type1)
3023      (if certain?
3024        (values nil t)
3025        (multiple-value-bind (subtype certain?)
3026            (csubtypep type2 type1)
3027          (declare (ignore subtype))
3028          (values nil certain?))))))
3029
3030
3031(define-type-method (union :complex-=) (type1 type2)
3032  (declare (ignore type1))
3033  (if (some #'type-might-contain-other-types-p 
3034            (union-ctype-types type2))
3035    (values nil nil)
3036    (values nil t)))
3037
3038
3039(defun union-simple-subtypep (type1 type2)
3040  (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
3041              type2
3042              (union-ctype-types type1)))
3043
3044(define-type-method (union :simple-subtypep) (type1 type2)
3045  (union-simple-subtypep type1 type2))
3046
3047(defun union-complex-subtypep-arg1 (type1 type2)
3048  (every/type (swapped-args-fun #'csubtypep)
3049              type2
3050              (union-ctype-types type1)))
3051
3052(define-type-method (union :complex-subtypep-arg1) (type1 type2)
3053  (union-complex-subtypep-arg1 type1 type2))
3054
3055(defun union-complex-subtypep-arg2 (type1 type2)
3056  (multiple-value-bind (sub-value sub-certain?)
3057      (progn
3058        (assert (union-ctype-p type2))
3059        (assert (not (union-ctype-p type1)))
3060        (type= type1
3061               (apply #'type-union
3062                      (mapcar (lambda (x) (type-intersection type1 x))
3063                              (union-ctype-types type2)))))
3064    (if sub-certain?
3065      (values sub-value sub-certain?)
3066      (invoke-complex-subtypep-arg1-method type1 type2))))
3067
3068(define-type-method (union :complex-subtypep-arg2) (type1 type2)
3069  (union-complex-subtypep-arg2 type1 type2))
3070
3071(define-type-method (union :simple-intersection :complex-intersection)
3072    (type1 type2)
3073  (assert (union-ctype-p type2))
3074  (cond ((and (union-ctype-p type1)
3075              (union-simple-subtypep type1 type2)) type1)
3076        ((and (union-ctype-p type1)
3077              (union-simple-subtypep type2 type1)) type2)
3078        ((and (not (union-ctype-p type1))
3079              (union-complex-subtypep-arg2 type1 type2))
3080         type1)
3081        ((and (not (union-ctype-p type1))
3082              (union-complex-subtypep-arg1 type2 type1))
3083         type2)
3084        (t 
3085         (let ((accumulator *empty-type*))
3086           (dolist (t2 (union-ctype-types type2) accumulator)
3087             (setf accumulator
3088                   (type-union accumulator
3089                               (type-intersection type1 t2))))))))
3090
3091
3092
3093(def-type-translator or (&rest type-specifiers)
3094  (apply #'type-union
3095         (mapcar #'specifier-type type-specifiers)))
3096
3097
3098;;; Intersection types
3099(defun make-intersection-ctype (enumerable types)
3100  (%istruct 'intersection-ctype
3101            (type-class-or-lose 'intersection)
3102            enumerable
3103            types))
3104
3105(defun intersection-ctype-p (x)
3106  (istruct-typep x 'intersection-ctype))
3107(setf (type-predicate 'intersection-ctype) 'intersection-ctype-p)
3108
3109(define-type-method (intersection :unparse) (type)
3110  (declare (type ctype type))
3111  (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
3112      `(and ,@(mapcar #'type-specifier (intersection-ctype-types type)))))
3113
3114;;; shared machinery for type equality: true if every type in the set
3115;;; TYPES1 matches a type in the set TYPES2 and vice versa
3116(defun type=-set (types1 types2)
3117  (flet (;; true if every type in the set X matches a type in the set Y
3118         (type<=-set (x y)
3119           (declare (type list x y))
3120           (every (lambda (xelement)
3121                    (position xelement y :test #'type=))
3122                  x)))
3123    (values (and (type<=-set types1 types2)
3124                 (type<=-set types2 types1))
3125            t)))
3126
3127(define-type-method (intersection :simple-=) (type1 type2)
3128  (type=-set (intersection-ctype-types type1)
3129             (intersection-ctype-types type2)))
3130
3131(defun %intersection-complex-subtypep-arg1 (type1 type2)
3132  (type= type1 (type-intersection type1 type2)))
3133
3134(defun %intersection-simple-subtypep (type1 type2)
3135  (every/type #'%intersection-complex-subtypep-arg1
3136              type1
3137              (intersection-ctype-types type2)))
3138
3139(define-type-method (intersection :simple-subtypep) (type1 type2)
3140  (%intersection-simple-subtypep type1 type2))
3141 
3142(define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
3143  (%intersection-complex-subtypep-arg1 type1 type2))
3144
3145(defun %intersection-complex-subtypep-arg2 (type1 type2)
3146  (every/type #'csubtypep type1 (intersection-ctype-types type2)))
3147
3148(define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
3149  (%intersection-complex-subtypep-arg2 type1 type2))
3150
3151(define-type-method (intersection :simple-union :complex-union)
3152    (type1 type2)
3153  (assert (intersection-ctype-p type2))
3154  (cond ((and (intersection-ctype-p type1)
3155              (%intersection-simple-subtypep type1 type2)) type2)
3156        ((and (intersection-ctype-p type1)
3157              (%intersection-simple-subtypep type2 type1)) type1)
3158        ((and (not (intersection-ctype-p type1))
3159              (%intersection-complex-subtypep-arg2 type1 type2))
3160         type2)
3161        ((and (not (intersection-ctype-p type1))
3162              (%intersection-complex-subtypep-arg1 type2 type1))
3163         type1)
3164        ((and (csubtypep type2 (specifier-type 'ratio))
3165              (numeric-ctype-p type1)
3166              (csubtypep type1 (specifier-type 'integer))
3167              (csubtypep type2
3168                         (make-numeric-ctype
3169                          :class 'rational
3170                          :complexp nil
3171                          :low (if (null (numeric-ctype-low type1))
3172                                 nil
3173                                 (list (1- (numeric-ctype-low type1))))
3174                          :high (if (null (numeric-ctype-high type1))
3175                                  nil
3176                                  (list (1+ (numeric-ctype-high type1)))))))
3177         (type-union type1
3178                     (apply #'type-intersection
3179                            (remove (specifier-type '(not integer))
3180                                    (intersection-ctype-types type2)
3181                                    :test #'type=))))
3182        (t
3183         (let ((accumulator *universal-type*))
3184           (do ((t2s (intersection-ctype-types type2) (cdr t2s)))
3185               ((null t2s) accumulator)
3186             (let ((union (type-union type1 (car t2s))))
3187               (when (union-ctype-p union)
3188                 (if (and (eq accumulator *universal-type*)
3189                          (null (cdr t2s)))
3190                     (return union)
3191                     (return nil)))
3192               (setf accumulator
3193                     (type-intersection accumulator union))))))))
3194
3195(def-type-translator and (&rest type-specifiers)
3196  (apply #'type-intersection
3197         (mapcar #'specifier-type
3198                 type-specifiers)))
3199
3200;;; cons-ctype
3201(defun wild-ctype-to-universal-ctype (c)
3202  (if (type= c *wild-type*)
3203    *universal-type*
3204    c))
3205
3206(defun make-cons-ctype (car-ctype-value cdr-ctype-value)
3207  (if (or (eq car-ctype-value *empty-type*)
3208          (eq cdr-ctype-value *empty-type*))
3209    *empty-type*
3210    (%istruct 'cons-ctype
3211              (type-class-or-lose 'cons)
3212              nil
3213              (wild-ctype-to-universal-ctype car-ctype-value)
3214              (wild-ctype-to-universal-ctype cdr-ctype-value))))
3215
3216(defun cons-ctype-p (x)
3217  (istruct-typep x 'cons-ctype))
3218
3219(setf (type-predicate 'cons-ctype) 'cons-ctype-p)
3220 
3221(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
3222  (make-cons-ctype (specifier-type car-type-spec)
3223                   (specifier-type cdr-type-spec)))
3224
3225(define-type-method (cons :unparse) (type)
3226  (let* ((car-spec (type-specifier (cons-ctype-car-ctype type)))
3227         (cdr-spec (type-specifier (cons-ctype-cdr-ctype type))))
3228    (if (and (member car-spec '(t *))
3229             (member cdr-spec '(t *)))
3230      'cons
3231      `(cons ,car-spec ,cdr-spec))))
3232
3233(define-type-method (cons :simple-=) (type1 type2)
3234  (declare (cons-ctype type1 type2))
3235  (and (type= (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2))
3236       (type= (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2))))
3237
3238(define-type-method (cons :simple-subtypep) (type1 type2)
3239  (declare (cons-ctype type1 type2))
3240  (multiple-value-bind (val-car win-car)
3241      (csubtypep (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2))
3242    (multiple-value-bind (val-cdr win-cdr)
3243        (csubtypep (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2))
3244      (if (and val-car val-cdr)
3245        (values t (and win-car win-cdr))
3246        (values nil (or win-car win-cdr))))))
3247
3248(define-type-method (cons :simple-union) (type1 type2)
3249  (declare (type cons-ctype type1 type2))
3250  (let ((car-type1 (cons-ctype-car-ctype type1))
3251        (car-type2 (cons-ctype-car-ctype type2))
3252        (cdr-type1 (cons-ctype-cdr-ctype type1))
3253        (cdr-type2 (cons-ctype-cdr-ctype type2))
3254        (car-not1)
3255        (car-not2))
3256    (macrolet ((frob-car (car1 car2 cdr1 cdr2
3257                          &optional (not1 nil not1p))
3258                 `(type-union
3259                   (make-cons-ctype ,car1 (type-union ,cdr1 ,cdr2))
3260                   (make-cons-ctype
3261                    (type-intersection
3262                     ,car2
3263                     ,(if not1p
3264                          not1
3265                          `(specifier-type
3266                            `(not ,(type-specifier ,car1))))) 
3267                    ,cdr2))))
3268      (cond ((type= car-type1 car-type2)
3269             (make-cons-ctype car-type1
3270                              (type-union cdr-type1 cdr-type2)))
3271            ((type= cdr-type1 cdr-type2)
3272             (make-cons-ctype (type-union car-type1 car-type2)
3273                              cdr-type1))
3274            ((csubtypep car-type1 car-type2)
3275             (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
3276            ((csubtypep car-type2 car-type1)
3277             (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
3278            ;; more general case of the above, but harder to compute
3279            ((progn
3280               (setf car-not1 (specifier-type
3281                               `(not ,(type-specifier car-type1))))
3282               (not (csubtypep car-type2 car-not1)))
3283             (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
3284            ((progn
3285               (setf car-not2 (specifier-type
3286                               `(not ,(type-specifier car-type2))))
3287               (not (csubtypep car-type1 car-not2)))
3288             (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))))))
3289           
3290(define-type-method (cons :simple-intersection) (type1 type2)
3291  (declare (type cons-type type1 type2))
3292  (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1)
3293                                      (cons-ctype-car-ctype type2)))
3294        (cdr-int2 (type-intersection2 (cons-ctype-cdr-ctype type1)
3295                                      (cons-ctype-cdr-ctype type2))))
3296    (cond ((and car-int2 cdr-int2)
3297           (make-cons-ctype car-int2 cdr-int2))
3298          (car-int2
3299           (make-cons-ctype car-int2
3300                            (type-intersection (cons-ctype-cdr-ctype type1)
3301                                               (cons-ctype-cdr-ctype type2))))
3302          (cdr-int2
3303           (make-cons-ctype (type-intersection (cons-ctype-car-ctype type1)
3304                                               (cons-ctype-car-ctype type2))
3305                            cdr-int2)))))
3306
3307
3308;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined).
3309;;; We make this distinction since we don't want to complain about types that
3310;;; are hairy but defined.
3311;;;
3312
3313(defun make-unknown-ctype (&key specifier (enumerable t))
3314  (%istruct 'unknown-ctype
3315            (type-class-or-lose 'hairy)
3316            enumerable
3317            specifier))
3318
3319(defun unknown-ctype-p (x)
3320  (istruct-typep x 'unknown-ctype))
3321
3322(setf (type-predicate 'unknown-ctype) 'unknown-ctype-p)
3323
3324
3325
3326
3327
3328;;;; foreign-type types
3329
3330
3331(defun %make-foreign-ctype (foreign-type)
3332  (%istruct 'foreign-ctype
3333            (type-class-or-lose 'foreign)
3334            nil
3335            foreign-type))
3336
3337(defun foreign-ctype-p (x) (istruct-typep x 'foreign-ctype))
3338(setf (type-predicate 'foreign-ctype) 'foreign-ctype-p)
3339
3340(define-type-method (foreign :unparse) (type)
3341  `(foreign ,(unparse-foreign-type (foreign-ctype-foreign-type type))))
3342
3343(define-type-method (foreign :simple-subtypep) (type1 type2)
3344  (values (foreign-subtype-p (foreign-ctype-foreign-type type1)
3345                                   (foreign-ctype-foreign-type type2))
3346            t))
3347
3348;(define-superclasses foreign (foreign-value))
3349
3350(define-type-method (foreign :simple-=) (type1 type2)
3351  (let ((foreign-type-1 (foreign-ctype-foreign-type type1))
3352          (foreign-type-2 (foreign-ctype-foreign-type type2)))
3353    (values (or (eq foreign-type-1 foreign-type-2)
3354                    (foreign-type-= foreign-type-1 foreign-type-2))
3355              t)))
3356
3357(def-type-translator foreign (&optional (foreign-type nil))
3358  (typecase foreign-type
3359    (null
3360     (make-foreign-ctype))
3361    (foreign-type
3362     (make-foreign-ctype foreign-type))
3363    (t
3364     (make-foreign-ctype (parse-foreign-type foreign-type)))))
3365
3366(defun make-foreign-ctype (&optional foreign-type)
3367  (if foreign-type
3368      (let ((lisp-rep-type (compute-lisp-rep-type foreign-type)))
3369        (if lisp-rep-type
3370            (specifier-type lisp-rep-type)
3371            (%make-foreign-ctype foreign-type)))
3372      *universal-type*))
3373
3374
3375;;; CLASS-CTYPES are supposed to help integrate CLOS and the CMU type system.
3376;;; They mostly just contain a backpointer to the CLOS class; the CPL is then
3377;;;  used to resolve type relationships.
3378
3379(defun class-ctype-p (x) (istruct-typep x 'class-ctype))
3380(setf (type-predicate 'class-ctype) 'class-ctype-p)
3381
3382(defun args-ctype-p (x) (and (eql (typecode x) target::subtag-istruct)
3383                             (member (%svref x 0)
3384                                     '(args-ctype values-ctype function-ctype))))
3385
3386(defun function-ctype-p (x) (istruct-typep x 'function-ctype))
3387(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
3388
3389(setf (type-predicate 'args-ctype) 'args-ctype-p
3390      (type-predicate 'function-ctype) 'function-ctype-p
3391      (type-predicate 'values-ctype) 'values-ctype-p)
3392
3393
3394;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two
3395;;; classes are equal, since there are EQ checks in those operations.
3396;;;
3397(define-type-method (class :simple-=) (type1 type2)
3398  (assert (not (eq type1 type2)))
3399  (values nil t))
3400
3401(define-type-method (class :simple-subtypep) (type1 type2)
3402  (assert (not (eq type1 type2)))
3403  (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1)))
3404         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
3405    (if (and class1 class2)
3406      (if (memq class2 (class-direct-superclasses class1))
3407        (values t t)
3408        (if (class-has-a-forward-referenced-superclass-p class1)
3409          (values nil nil)
3410          (let ((supers (%inited-class-cpl class1)))
3411            (if (memq class2 supers)
3412              (values t t)
3413              (values nil t)))))
3414      (values nil t))))
3415
3416(defun find-class-intersection (c1 c2)
3417  (labels ((walk-subclasses (class f)
3418             (dolist (sub (class-direct-subclasses class))
3419               (walk-subclasses sub f))
3420             (funcall f class)))
3421    (let* ((intersection nil))
3422      (walk-subclasses c1 #'(lambda (c)
3423                              (when (subclassp c c2)
3424                                (pushnew (%class.ctype c) intersection))))
3425      (when intersection
3426        (%type-union intersection)))))
3427
3428(define-type-method (class :simple-intersection) (type1 type2)
3429  (assert (not (eq type1 type2)))
3430  (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1)))
3431         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
3432    (if (and class1 class2)
3433      (cond ((subclassp class1 class2)
3434             type1)
3435            ((subclassp class2 class1)
3436             type2)
3437            ;;; In the STANDARD-CLASS case where neither's
3438            ;;; a subclass of the other, there may be
3439            ;;; one or mor classes that're a subclass of both.  We
3440            ;;; -could- try to find all such classes, but
3441            ;;; punt instead.
3442            (t (or (find-class-intersection class1 class2)
3443                 *empty-type*)))
3444      nil)))
3445
3446(define-type-method (class :complex-subtypep-arg2) (type1 class2)
3447  (if (and (intersection-ctype-p type1)
3448           (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1))
3449      (values nil nil)
3450      (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
3451
3452(define-type-method (class :complex-subtypep-arg1) (type1 type2)
3453  (if (and (function-ctype-p type2)
3454           (eq type1 (specifier-type 'function))
3455           (function-ctype-wild-args type2)
3456           (eq *wild-type* (function-ctype-returns type2)))
3457      (values t t)
3458      (values nil t)))
3459
3460(define-type-method (class :unparse) (type)
3461  (class-name (class-ctype-class type)))
3462
3463
3464;;; TYPE-DIFFERENCE  --  Interface
3465;;;
3466;;;    Return the type that describes all objects that are in X but not in Y.
3467;;; If we can't determine this type, then return NIL.
3468;;;
3469;;;    For now, we only are clever dealing with union and member types.  If
3470;;; either type is not a union type, then we pretend that it is a union of just
3471;;; one type.  What we do is remove from X all the types that are a subtype any
3472;;; type in Y.  If any type in X intersects with a type in Y but is not a
3473;;; subtype, then we give up.
3474;;;
3475;;;    We must also special-case any member type that appears in the union.  We
3476;;; remove from X's members all objects that are TYPEP to Y.  If Y has any
3477;;; members, we must be careful that none of those members are CTYPEP to any
3478;;; of Y's non-member types.  We give up in this case, since to compute that
3479;;; difference we would have to break the type from X into some collection of
3480;;; types that represents the type without that particular element.  This seems
3481;;; too hairy to be worthwhile, given its low utility.
3482;;;
3483(defun type-difference (x y)
3484  (let ((x-types (if (union-ctype-p x) (union-ctype-types x) (list x)))
3485        (y-types (if (union-ctype-p y) (union-ctype-types y) (list y))))
3486    (collect ((res))
3487      (dolist (x-type x-types)
3488        (if (member-ctype-p x-type)
3489            (collect ((members))
3490              (dolist (mem (member-ctype-members x-type))
3491                (multiple-value-bind (val win) (ctypep mem y)
3492                  (unless win (return-from type-difference nil))
3493                  (unless val
3494                    (members mem))))
3495              (when (members)
3496                (res (make-member-ctype :members (members)))))
3497            (dolist (y-type y-types (res x-type))
3498              (multiple-value-bind (val win) (csubtypep x-type y-type)
3499                (unless win (return-from type-difference nil))
3500                (when val (return))
3501                (when (types-intersect x-type y-type)
3502                  (return-from type-difference nil))))))
3503      (let ((y-mem (find-if #'member-ctype-p y-types)))
3504        (when y-mem
3505          (let ((members (member-ctype-members y-mem)))
3506            (dolist (x-type x-types)
3507              (unless (member-ctype-p x-type)
3508                (dolist (member members)
3509                  (multiple-value-bind (val win) (ctypep member x-type)
3510                    (when (or (not win) val)
3511                      (return-from type-difference nil)))))))))
3512      (apply #'type-union (res)))))
3513
3514;;; CTypep  --  Interface
3515;;;
3516;;;    If Type is a type that we can do a compile-time test on, then return the
3517;;; whether the object is of that type as the first value and second value
3518;;; true.  Otherwise return NIL, NIL.
3519;;;
3520;;; We give up on unknown types, pick off FUNCTION and UNION types.  For
3521;;; structure types, we require that the type be defined in both the current
3522;;; and compiler environments, and that the INCLUDES be the same.
3523;;;
3524(defun ctypep (obj type)
3525  (declare (type ctype type))
3526  (etypecase type
3527    ((or numeric-ctype named-ctype member-ctype array-ctype cons-ctype)
3528     (values (%typep obj type) t))
3529    (class-ctype
3530     (values (not (null (class-typep  obj (class-ctype-class type)))) t)
3531)
3532    (union-ctype
3533     (any/type #'ctypep obj (union-ctype-types type)))
3534    (intersection-ctype
3535     (every/type #'ctypep obj (intersection-ctype-types type)))
3536    (function-ctype
3537     (values (functionp obj) t))
3538    (unknown-ctype
3539     (values nil nil))
3540    (foreign-ctype
3541     (values (foreign-typep obj (foreign-ctype-foreign-type type)) t))
3542    (negation-ctype
3543     (multiple-value-bind (res win)
3544         (ctypep obj (negation-ctype-type type))
3545       (if win
3546           (values (not res) t)
3547           (values nil nil))))
3548    (hairy-ctype
3549     ;; Now the tricky stuff.
3550     (let* ((hairy-spec (hairy-ctype-specifier type))
3551            (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
3552       (ecase symbol
3553         (and                           ; how would this get there ?
3554          (if (atom hairy-spec)
3555            (values t t)
3556            (dolist (spec (cdr hairy-spec) (values t t))
3557              (multiple-value-bind (res win)
3558                  (ctypep obj (specifier-type spec))
3559                (unless win (return (values nil nil)))
3560                (unless res (return (values nil t)))))))
3561           (not                         ; how would this get there ?
3562            (multiple-value-bind
3563              (res win)
3564                (ctypep obj (specifier-type (cadr hairy-spec)))
3565              (if win
3566                (values (not res) t)
3567                (values nil nil))))
3568           (satisfies
3569            (let ((fun (second hairy-spec)))
3570              (cond ((and (symbolp fun) (fboundp fun))
3571                     (values (not (null (ignore-errors (funcall fun obj)))) t))
3572                    (t
3573                     (values nil nil))))))))))
3574
3575;;; %TYPEP -- internal.
3576;;;
3577;;; The actual typep engine.  The compiler only generates calls to this
3578;;; function when it can't figure out anything more intelligent to do.
3579;;;
3580; lose 1 function call -MAYBE
3581(defun %typep (object specifier)
3582  (%%typep object
3583           (if (typep specifier 'ctype)
3584             specifier
3585             (specifier-type specifier))))
3586
3587(eval-when (:compile-toplevel)
3588  (declaim (inline numeric-%%typep
3589                   array-%%typep
3590                   member-%%typep
3591                   cons-%%typep)))
3592
3593(defun numeric-%%typep (object type)
3594  (let ((pred (numeric-ctype-predicate type)))
3595    (if pred
3596      (funcall pred object)
3597      (and (numberp object)
3598           (let ((num (if (complexp object) (realpart object) object)))
3599             (ecase (numeric-ctype-class type)
3600               (integer (integerp num))
3601               (rational (rationalp num))
3602               (float
3603                (ecase (numeric-ctype-format type)
3604                  (single-float (typep num 'single-float))
3605                  (double-float (typep num 'double-float))
3606                  ((nil) (floatp num))))
3607               ((nil) t)))
3608           (flet ((bound-test (val)
3609                    (let ((low (numeric-ctype-low type))
3610                          (high (numeric-ctype-high type)))
3611                      (and (cond ((null low) t)
3612                                 ((listp low) (> val (car low)))
3613                                 (t (>= val low)))
3614                           (cond ((null high) t)
3615                                 ((listp high) (< val (car high)))
3616                                 (t (<= val high)))))))
3617             (ecase (numeric-ctype-complexp type)
3618               ((nil) t)
3619               (:complex
3620                (and (complexp object)
3621                     (bound-test (realpart object))
3622                     (bound-test (imagpart object))))
3623               (:real
3624                (and (not (complexp object))
3625                     (bound-test object)))))))))
3626
3627(defun array-%%typep (object type)
3628  (let* ((typecode (typecode object)))
3629    (declare (type (unsigned-byte 8) typecode))
3630    (and (>= typecode target::subtag-arrayH)
3631         (ecase (array-ctype-complexp type)
3632           ((t) (not (simple-array-p object)))
3633           ((nil) (simple-array-p object))
3634           ((* :maybe) t))
3635         (let* ((ctype-dimensions (array-ctype-dimensions type)))
3636           (or (eq ctype-dimensions '*)
3637               (if (eql typecode target::subtag-arrayH)
3638                   (let* ((rank (%svref object target::arrayH.rank-cell)))
3639                     (declare (fixnum rank))
3640                     (and (eql rank (length ctype-dimensions))
3641                          (do* ((i 0 (1+ i))
3642                                (dim target::arrayH.dim0-cell (1+ dim))
3643                                (want (array-ctype-dimensions type) (cdr want))
3644                                (got (%svref object dim) (%svref object dim)))
3645                               ((eql i rank) t)
3646                            (unless (or (eq (car want) '*)
3647                                        (eql (car want) (the fixnum got)))
3648                              (return nil)))))
3649                   (and (null (cdr ctype-dimensions))
3650                        (eql (car ctype-dimensions) (array-total-size object))))))
3651         (or (eq (array-ctype-element-type type) *wild-type*)
3652             (eql (array-ctype-typecode type)
3653                  (if (> typecode target::subtag-vectorH)
3654                      typecode
3655                      (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell)))))
3656             (type= (array-ctype-specialized-element-type type)
3657                    (specifier-type (array-element-type object)))))))
3658
3659
3660(defun member-%%typep (object type)
3661  (not (null (member object (member-ctype-members type)))))
3662
3663(defun cons-%%typep (object type) 
3664  (and (consp object)
3665       (%%typep (car object) (cons-ctype-car-ctype type))
3666       (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) 
3667
3668
3669(defun %%typep (object type)
3670  ;(if (not (typep type 'ctype))(setq type (specifier-type type)))
3671  (locally (declare (type ctype type))
3672    (etypecase type
3673      (named-ctype
3674       (ecase (named-ctype-name type)
3675         ((* t) t)
3676         ((nil) nil)))
3677      (numeric-ctype
3678       (numeric-%%typep object type))
3679      (array-ctype
3680       (array-%%typep object type))
3681      (member-ctype
3682       (member-%%typep object type))
3683      (class-ctype
3684       (not (null (class-typep object (class-ctype-class type)))))
3685      (union-ctype
3686       (dolist (type (union-ctype-types type))
3687         (when (%%typep object type)
3688           (return t))))
3689      (intersection-ctype
3690       (dolist (type (intersection-ctype-types type) t)
3691         (unless (%%typep object type) (return nil))))
3692      (cons-ctype
3693       (cons-%%typep object type))
3694      (unknown-ctype
3695       ;; Parse it again to make sure it's really undefined.
3696       (let ((reparse (specifier-type (unknown-ctype-specifier type))))
3697         (if (typep reparse 'unknown-ctype)
3698           (error "Unknown type specifier: ~S"
3699                  (unknown-ctype-specifier reparse))
3700           (%%typep object reparse))))
3701      (negation-ctype
3702       (not (%%typep object (negation-ctype-type type))))
3703      (hairy-ctype
3704       ;; Now the tricky stuff.
3705       (let* ((hairy-spec (hairy-ctype-specifier type))
3706              (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
3707         (ecase symbol
3708           (and
3709            (or (atom hairy-spec)
3710                (dolist (spec (cdr hairy-spec) t)
3711                  (unless (%%typep object (specifier-type spec))
3712                    (return nil)))))
3713           (not
3714            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
3715              (error "Invalid type specifier: ~S" hairy-spec))
3716            (not (%%typep object (specifier-type (cadr hairy-spec)))))
3717           (satisfies
3718            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
3719              (error "Invalid type specifier: ~S" hairy-spec))
3720            (let ((fn (cadr hairy-spec)))
3721              (if (funcall (typecase fn
3722                             (function fn)
3723                             (symbol (symbol-function fn))
3724                             (t
3725                              (coerce fn 'function)))
3726                           object)
3727                t
3728                nil))))))
3729      #|
3730    (foreign-ctype
3731     (foreign-typep object (foreign-ctype-foreign-type type)))
3732|#
3733      (function-ctype
3734       (error "Function types are not a legal argument to TYPEP:~%  ~S"
3735              (type-specifier type))))))
3736
3737
3738;;; Ctype-Of  --  Interface
3739;;;
3740;;;    Like Type-Of, only returns a Type structure instead of a type
3741;;; specifier.  We try to return the type most useful for type checking, rather
3742;;; than trying to come up with the one that the user might find most
3743;;; informative.
3744;;;
3745
3746(defun float-format-name (x)
3747  (declare (float x))
3748  (etypecase x
3749    (single-float "SINGLE-FLOAT")
3750    (double-float "DOUBLE-FLOAT")))
3751
3752(defun ctype-of-number (x)
3753  (let ((num (if (complexp x) (realpart x) x)))
3754    (multiple-value-bind (complexp low high)
3755        (if (complexp x)
3756            (let ((imag (imagpart x)))
3757              (values :complex (min num imag) (max num imag)))
3758            (values :real num num))
3759      (make-numeric-ctype :class (etypecase num
3760                                   (integer (if (complexp x)
3761                                                (if (integerp (imagpart x))
3762                                                    'integer
3763                                                    'rational)
3764                                                'integer))
3765                                   (rational 'rational)
3766                                   (float 'float))
3767                          :format (and (floatp num)
3768                                       (if (typep num 'double-float)
3769                                         'double-float
3770                                         'single-float))
3771                          :complexp complexp
3772                          :low low
3773                          :high high))))
3774
3775(defun ctype-of (x)
3776  (typecase x
3777    (function (specifier-type 'function)) ; GFs ..
3778    (symbol
3779     (make-member-ctype :members (list x)))
3780    (number (ctype-of-number x))
3781    (array
3782     (let ((etype (specifier-type (array-element-type x))))
3783       (make-array-ctype :dimensions (array-dimensions x)
3784                         :complexp (not (typep x 'simple-array))
3785                         :element-type etype
3786                         :specialized-element-type etype)))
3787    (t
3788     (%class.ctype (class-of x)))))
3789
3790(defvar *ctype-of-double-float-0* (ctype-of 0.0d0))
3791(defvar *ctype-of-single-float-0* (ctype-of 0.0f0))
3792
3793
3794
3795
3796; These DEFTYPES should only happen while initializing.
3797
3798(progn
3799(let-globally ((*type-system-initialized* nil))
3800
3801
3802(deftype bit () '(integer 0 1))
3803
3804(deftype eql (val) `(member ,val))
3805
3806(deftype signed-byte (&optional s)
3807  (cond ((eq s '*) 'integer)
3808          ((and (integerp s) (> s 0))
3809           (let ((bound (ash 1 (1- s))))
3810             `(integer ,(- bound) ,(1- bound))))
3811          (t
3812           (signal-program-error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
3813 
3814(deftype unsigned-byte (&optional s)
3815  (cond ((eq s '*) '(integer 0))
3816        ((and (integerp s) (> s 0))
3817         `(integer 0 ,(1- (ash 1 s))))
3818        (t
3819         (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
3820
3821(deftype vector (&optional element-type size)
3822  `(array ,element-type (,size)))
3823
3824(deftype simple-vector (&optional size)
3825  `(simple-array t (,size)))
3826
3827(deftype base-string (&optional size)
3828  `(array base-char (,size)))
3829(deftype simple-base-string (&optional size)
3830  `(simple-array base-char (,size)))
3831
3832
3833
3834(deftype string (&optional size)
3835  `(array character (,size)))
3836
3837(deftype simple-string (&optional size)
3838  `(simple-array character (,size)))
3839
3840(deftype extended-string (&optional size)
3841  (declare (ignore size))
3842  'nil)
3843
3844(deftype simple-extended-string (&optional size)
3845  (declare (ignore size))
3846  'nil)
3847
3848(deftype bit-vector (&optional size)
3849  `(array bit (,size)))
3850
3851(deftype simple-bit-vector (&optional size)
3852  `(simple-array bit (,size)))
3853
3854; TYPE-OF sometimes returns random symbols that aren't really type specifiers.
3855
3856(deftype simple-unsigned-word-vector (&optional size)
3857  `(simple-array (unsigned-byte 16) (,size)))
3858
3859(deftype simple-unsigned-byte-vector (&optional size)
3860  `(simple-array (unsigned-byte 8) (,size)))
3861
3862(deftype simple-unsigned-long-vector (&optional size)
3863  `(simple-array (unsigned-byte 32) (,size)))
3864
3865(deftype simple-signed-word-vector (&optional size)
3866  `(simple-array (signed-byte 16) (,size)))
3867
3868(deftype simple-signed-byte-vector (&optional size)
3869  `(simple-array (signed-byte 8) (,size)))
3870
3871(deftype simple-signed-long-vector (&optional size)
3872  `(simple-array (signed-byte 32) (,size)))
3873
3874(deftype simple-double-float-vector (&optional size)
3875  `(simple-array double-float (,size)))
3876
3877(deftype simple-short-float-vector (&optional size)
3878  `(simple-array short-float (,size)))
3879
3880(deftype unsigned-word-vector (&optional size)
3881  `(vector (unsigned-byte 16) ,size))
3882
3883(deftype single-float-vector (&optional size)
3884  `(vector short-float ,size))
3885
3886(deftype unsigned-byte-vector (&optional size)
3887  `(vector (unsigned-byte 8) ,size))
3888
3889(deftype unsigned-long-vector (&optional size)
3890  `(vector (unsigned-byte 32) ,size))
3891
3892(deftype long-float-vector (&optional size)
3893  `(vector double-float ,size))
3894
3895(deftype long-vector (&optional size)
3896  `(vector (signed-byte 32) ,size))
3897
3898(deftype double-float-vector (&optional size)
3899  `(vector double-float ,size))
3900
3901(deftype byte-vector (&optional size)
3902  `(vector (signed-byte 8) ,size))
3903
3904(deftype general-vector (&optional size)
3905  `(vector t ,size))
3906
3907(deftype word-vector (&optional size)
3908  `(vector (signed-byte 16) ,size))
3909
3910(deftype short-float-vector (&optional size)
3911  `(vector single-float ,size))
3912
3913(deftype simple-1d-array (&optional size)
3914  `(simple-array * (,size)))
3915
3916(deftype simple-long-vector (&optional size)
3917  `(simple-array (signed-byte 32) (,size)))
3918
3919(deftype simple-word-vector (&optional size)
3920  `(simple-array (signed-byte 16) (,size)))
3921
3922(deftype simple-short-float-vector (&optional size)
3923  `(simple-array single-float (,size)))
3924
3925(deftype simple-byte-vector (&optional size)
3926  `(simple-array (signed-byte 8) (,size)))
3927
3928(deftype simple-double-float-vector (&optional size)
3929  `(simple-array double-float (,size)))
3930
3931(deftype simple-single-float-vector (&optional size)
3932  `(simple-array single-float (,size)))
3933
3934(deftype simple-fixnum-vector (&optional size)
3935  `(simple-array fixnum (,size)))
3936
3937#+64-bit-target
3938(deftype simple-doubleword-vector (&optional size)
3939  `(simple-array (signed-byte 64) (,size)))
3940
3941#+64-bit-target
3942(deftype simple-unsigned-doubleword-vector (&optional size)
3943  `(simple-array (unsigned-byte 64) (,size)))
3944
3945
3946(deftype short-float (&optional low high)
3947  `(single-float ,low ,high))
3948
3949(deftype long-float (&optional low high)
3950  `(double-float ,low ,high))
3951
3952;;; As empty a type as you're likely to find ...
3953(deftype extended-char ()
3954  "Type of CHARACTERs that aren't BASE-CHARs."
3955  nil)
3956)
3957
3958
3959(let* ((builtin-translations 
3960        `((array . array)
3961          (simple-array . simple-array)
3962          (cons . cons)
3963          (vector . vector)
3964          (null . (member nil))
3965          (list . (or cons null))
3966          (sequence . (or list vector))
3967          (simple-vector . simple-vector)
3968          (bit-vector . bit-vector)
3969          (simple-bit-vector . simple-bit-vector)
3970          (simple-string . simple-string)
3971          (simple-base-string . simple-base-string)
3972          (string . string)
3973          (base-string . base-string)
3974          (real . real)
3975          (complex . complex)
3976          (float . float)
3977          (double-float . double-float)
3978          (long-float . double-float)
3979          (single-float . single-float)
3980          (short-float . single-float)
3981
3982          (rational . rational)
3983          (integer . integer)
3984          (ratio . (and rational (not integer)))
3985          (fixnum . (integer ,target::target-most-negative-fixnum
3986                     ,target::target-most-positive-fixnum))
3987          (bignum . (or (integer * (,target::target-most-negative-fixnum))
3988                         (integer (,target::target-most-positive-fixnum) *)))
3989         
3990          )))
3991  (dolist (spec builtin-translations)
3992    (setf (info-type-kind (car spec)) :primitive
3993          (info-type-builtin (car spec)) (specifier-type (cdr spec)))))
3994
3995
3996
3997
3998
3999       
4000(precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000)
4001                    #-cross-compiling
4002                    (mod #x100000000)
4003                    (unsigned-byte 1) 
4004                    (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
4005                    (unsigned-byte 64)
4006                    (signed-byte 8) (signed-byte 16) (signed-byte 32)
4007                    (signed-byte 64)
4008                    (or function symbol)
4009                    ))
4010
4011
4012(precompute-types *cl-types*)
4013
4014;;; Treat CHARACTER and BASE-CHAR as equivalent.
4015(setf (info-type-builtin 'character) (info-type-builtin 'base-char))
4016;;; And EXTENDED-CHAR as empty.
4017(setf (info-type-builtin 'extended-char) *empty-type*)
4018
4019(defparameter *null-type* (specifier-type 'null))
4020
4021
4022(flet ((set-builtin-class-type-translation (thing)
4023         (let* ((class-name (if (atom thing) thing (car thing)))
4024                (spec (if (atom thing) thing (cadr thing)))
4025                (spectype (specifier-type spec)))
4026           (setf (class-ctype-translation
4027                  (%class.ctype (find-class class-name))) spectype))))
4028  (mapc #'set-builtin-class-type-translation
4029        '(
4030          ;; Root Of All Evil
4031          t
4032          ;; Numbers:
4033          number real ratio complex rational fixnum
4034          ;;  Integers:
4035          signed-byte  unsigned-byte bit bignum integer
4036          ;;  Floats
4037           float  double-float single-float
4038          ;; Arrays
4039          array
4040          ;;  Simple Arrays
4041          simple-array
4042          ;;  Vectors
4043          vector string base-string bit-vector
4044          unsigned-byte-vector unsigned-word-vector unsigned-long-vector
4045          byte-vector word-vector long-vector
4046          single-float-vector double-float-vector
4047          general-vector
4048          fixnum-vector
4049          #+64-bit-target
4050          doubleword-vector
4051          #+64-bit-target
4052          unsigned-doubleword-vector
4053          ;;   Simple 1-Dimensional Arrays
4054          simple-1d-array  simple-string simple-base-string simple-bit-vector
4055          simple-unsigned-byte-vector
4056          simple-unsigned-long-vector
4057          simple-unsigned-word-vector
4058          simple-byte-vector
4059          simple-word-vector
4060          simple-long-vector 
4061          simple-single-float-vector 
4062          simple-double-float-vector
4063          simple-vector
4064          simple-fixnum-vector
4065          #+64-bit-target
4066          simple-doubleword-vector
4067          #+64-bit-target
4068          simple-unsigned-doubleword-vector
4069          ;; Sequence types
4070          sequence list  cons null
4071         
4072 )
4073                                                         
4074        ))
4075)
4076;(setq *type-system-initialized* t)
4077
4078
4079
4080
4081; These deftypes help the CMUCL compiler; the type system doesn't depend on them.
4082
4083;;; Since OpenMCL's DEFTYPE tries to globally define the type
4084;;; at compile-time as well as load- and execute time, hide
4085;;; the definition of these "built-in" types.  (It'd be cleaner
4086;;; to make DEFTYPE do something saner at compile-time.)
4087(let* ()                                ; make the following be non-toplevel
4088(deftype boolean () '(member t nil))
4089
4090(deftype atom () '(not cons))
4091;;;
4092;;; A type specifier.
4093(deftype type-specifier () '(or list symbol class))
4094;;;
4095;;; An index into an array.   Also used for sequence index.
4096(deftype index () `(integer 0 (,array-dimension-limit)))
4097;;;
4098;;; Array rank, total size...
4099(deftype array-rank () `(integer 0 (,array-rank-limit)))
4100(deftype array-total-size () `(integer 0 (,array-total-size-limit)))
4101;;;
4102;;; Some thing legal in an evaluated context.
4103(deftype form () t)
4104;;;
4105;;; Maclisp compatibility...
4106(deftype stringlike () '(or string symbol))
4107(deftype stringable () '(or string symbol character))
4108;;;
4109;;; Save a little typing...
4110(deftype truth () '(member t))
4111;;;
4112;;; A thing legal in places where we want the name of a file.
4113(deftype filename () '(or string pathname))
4114;;;
4115;;; A legal arg to pathname functions.
4116(deftype pathnamelike () '(or string pathname stream))
4117;;;
4118;;; A thing returned by the irrational functions.  We assume that they never
4119;;; compute a rational result.
4120(deftype irrational () '(or float (complex float)))
4121;;;
4122;;; Character components:
4123(deftype char-code () `(integer 0 (,char-code-limit)))
4124;;;
4125;;; A consed sequence result.  If a vector, is a simple array.
4126(deftype consed-sequence () '(or list (simple-array * (*))))
4127;;;
4128;;; The :end arg to a sequence...
4129(deftype sequence-end () '(or null index))
4130;;;
4131;;; A valid argument to a stream function...
4132(deftype streamlike () '(or stream (member nil t)))
4133;;;
4134;;; A thing that can be passed to funcall & friends.
4135(deftype callable () '(or function symbol))
4136
4137;;; Until we decide if and how to wedge this into the type system, make it
4138;;; equivalent to t.
4139;;;
4140(deftype void () t)
4141;;;
4142;;; An index into an integer.
4143(deftype bit-index () `(integer 0 ,target::target-most-positive-fixnum))
4144;;;
4145;;; Offset argument to Ash (a signed bit index).
4146(deftype ash-index () 'fixnum)
4147
4148;;; Not sure how to do this without SATISFIES.
4149(deftype setf-function-name () `(satisfies setf-function-name-p))
4150
4151;;; Better than nothing, arguably.
4152(deftype function-name () `(or symbol setf-function-name))
4153
4154)                                       ; end of LET* sleaze
4155
4156(defun array-or-union-ctype-element-type (ctype)
4157  (if (typep ctype 'array-ctype)
4158    (type-specifier (array-ctype-element-type ctype))
4159    (if (typep ctype 'union-ctype)
4160      `(or ,@(mapcar #'array-or-union-ctype-element-type 
4161                     (union-ctype-types ctype))))))
4162
4163
4164(defvar *simple-predicate-function-prototype*
4165  #'(lambda (thing)
4166      (%%typep thing #.(specifier-type t))))
4167
4168(defun make-simple-type-predicate (function datum)
4169  #+ppc-target
4170  (gvector :function
4171           (uvref *simple-predicate-function-prototype* 0)
4172           datum
4173           function
4174           nil
4175           (dpb 1 $lfbits-numreq 0))
4176  #+x86-target
4177  (%clone-x86-function
4178   *simple-predicate-function-prototype*
4179   datum
4180   function
4181   nil
4182   (dpb 1 $lfbits-numreq 0)))
4183
4184(defun check-ctypep (thing ctype)
4185  (multiple-value-bind (win sure) (ctypep thing ctype)
4186    (or win (not sure))))
4187
4188
4189(defun generate-predicate-for-ctype (ctype)
4190  (typecase ctype
4191    (numeric-ctype
4192     (or (numeric-ctype-predicate ctype)
4193         (make-simple-type-predicate 'numeric-%%typep ctype)))
4194    (array-ctype
4195     (make-simple-type-predicate 'array-%%typep ctype))
4196    (member-ctype
4197     (make-simple-type-predicate 'member-%%typep ctype))
4198    (named-ctype
4199     (case (named-ctype-name ctype)
4200       ((* t) #'true)
4201       (t #'false)))
4202    (cons-ctype
4203     (make-simple-type-predicate 'cons-%%typep ctype))
4204    (function-ctype
4205     #'functionp)
4206    (class-ctype
4207     (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t)))
4208    (t
4209     (make-simple-type-predicate 'check-ctypep ctype))))
4210   
4211       
4212
4213   
4214
4215;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful
4216;;; type predicate, if we can.
4217(defmethod shared-initialize :after ((spec effective-slot-definition)
4218                                     slot-names
4219                                     &key 
4220                                     &allow-other-keys)
4221  (declare (ignore slot-names))
4222  (let* ((type (slot-definition-type spec)))
4223    (setf (slot-value spec 'type-predicate)
4224          (or (and (typep type 'symbol)
4225                   (not (eq type 't))
4226                   (type-predicate type))
4227              (handler-case
4228                  (let* ((ctype (specifier-type type)))
4229                    (unless (eq ctype *universal-type*)
4230                      (generate-predicate-for-ctype ctype)))
4231                (parse-unknown-type (c)
4232                   (declare (ignore c))
4233                   #'(lambda (value)
4234                       ;; If the type's now known, install a new predicate.
4235                       (let* ((nowctype (specifier-type type)))
4236                         (unless (typep nowctype 'unknown-ctype)
4237                           (setf (slot-value spec 'type-predicate)
4238                                 (generate-predicate-for-ctype nowctype)))
4239                         (multiple-value-bind (win sure)
4240                             (ctypep value nowctype)
4241                           (or (not sure) win))))))))))
4242
Note: See TracBrowser for help on using the repository browser.