source: trunk/j/src/org/armedbear/lisp/subtypep.lisp @ 4082

Last change on this file since 4082 was 4082, checked in by piso, 20 years ago

NORMALIZE-TYPE: DEFTYPE support.
File size: 10.7 KB
Line 
1;;; subtypep.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: subtypep.lisp,v 1.15 2003-09-27 17:31:58 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from GCL.
21
22(in-package "SYSTEM")
23
24(defparameter *known-types* (make-hash-table))
25
26(dolist (i '((ARITHMETIC-ERROR ERROR)
27             (ARRAY)
28             (BASE-STRING SIMPLE-STRING)
29             (BIGNUM INTEGER)
30             (BIT INTEGER)
31             (BIT-VECTOR VECTOR)
32             (BOOLEAN SYMBOL)
33             (BUILT-IN-CLASS CLASS)
34             (CELL-ERROR ERROR)
35             (CHARACTER)
36             (CLASS STANDARD-OBJECT)
37             (COMPILED-FUNCTION FUNCTION)
38             (COMPLEX NUMBER)
39             (CONDITION)
40             (CONS LIST)
41             (CONTROL-ERROR ERROR)
42             (DIVISION-BY-ZERO ARITHMETIC-ERROR)
43             (END-OF-FILE STREAM-ERROR)
44             (ERROR SERIOUS-CONDITION)
45             (EXTENDED-CHAR CHARACTER NIL)
46             (FILE-ERROR ERROR)
47             (FIXNUM INTEGER)
48             (FLOAT REAL)
49             (FLOATING-POINT-INEXACT ARITHMETIC-ERROR)
50             (FLOATING-POINT-INVALID-OPERATION ARITHMETIC-ERROR)
51             (FLOATING-POINT-OVERFLOW ARITHMETIC-ERROR)
52             (FLOATING-POINT-UNDERFLOW ARITHMETIC-ERROR)
53             (FUNCTION)
54             (GENERIC-FUNCTION FUNCTION)
55             (HASH-TABLE)
56             (INTEGER RATIONAL)
57             (KEYWORD SYMBOL)
58             (LIST SEQUENCE)
59             (NULL SYMBOL LIST)
60             (NUMBER)
61             (PACKAGE)
62             (PACKAGE-ERROR ERROR)
63             (PARSE-ERROR ERROR)
64             (PATHNAME)
65             (PRINT-NOT-READABLE ERROR)
66             (PROGRAM-ERROR ERROR)
67             (RANDOM-STATE)
68             (RATIO RATIONAL)
69             (RATIONAL REAL)
70             (READER-ERROR PARSE-ERROR STREAM-ERROR)
71             (READTABLE)
72             (REAL NUMBER)
73             (RESTART)
74             (SERIOUS-CONDITION CONDITION)
75             (SIMPLE-ARRAY ARRAY)
76             (SIMPLE-BASE-STRING SIMPLE-STRING BASE-STRING)
77             (SIMPLE-BIT-VECTOR BIT-VECTOR SIMPLE-ARRAY)
78             (SIMPLE-CONDITION CONDITION)
79             (SIMPLE-ERROR SIMPLE-CONDITION ERROR)
80             (SIMPLE-STRING STRING SIMPLE-ARRAY)
81             (SIMPLE-TYPE-ERROR SIMPLE-CONDITION TYPE-ERROR)
82             (SIMPLE-VECTOR VECTOR SIMPLE-ARRAY)
83             (SIMPLE-WARNING SIMPLE-CONDITION WARNING)
84             (STANDARD-CHAR CHARACTER)
85             (STANDARD-CLASS CLASS)
86             (STANDARD-GENERIC-FUNCTION GENERIC-FUNCTION)
87             (STANDARD-OBJECT)
88             (STORAGE-CONDITION SERIOUS-CONDITION)
89             (STREAM)
90             (STREAM-ERROR ERROR)
91             (STRING VECTOR)
92             (STRUCTURE-CLASS CLASS STANDARD-OBJECT)
93             (STYLE-WARNING WARNING)
94             (SYMBOL)
95             (TWO-WAY-STREAM STREAM)
96             (TYPE-ERROR ERROR)
97             (UNBOUND-SLOT CELL-ERROR)
98             (UNBOUND-VARIABLE CELL-ERROR)
99             (UNDEFINED-FUNCTION CELL-ERROR)
100             (VECTOR ARRAY SEQUENCE)
101             (WARNING CONDITION)
102             ))
103  (setf (gethash (car i) *known-types*) (cdr i)))
104
105(defun supertypes (type)
106  (values (gethash type *known-types*)))
107
108(defun known-type-p (type)
109  (multiple-value-bind (value present-p) (gethash type *known-types*)
110    present-p))
111
112(defun normalize-type (type)
113  (let (tp i)
114    (loop
115      (if (consp type)
116          (setq tp (car type) i (cdr type))
117          (setq tp type i nil))
118      (if (and (symbolp tp) (get tp 'deftype-definition))
119          (setq type (apply (get tp 'deftype-definition) i))
120          (return)))
121    (case tp
122      ((ARRAY SIMPLE-ARRAY)
123       (when (and i (eq (car i) nil))
124         (if (eq tp 'simple-array)
125             (setq tp 'simple-string)
126             (setq tp 'string))
127         (when (cadr i)
128           (if (consp (cadr i))
129               (setq i (cadr i))
130               (setq i (list (cadr i)))))))
131      (BASE-CHAR
132       (setq tp 'character))
133      (FIXNUM
134       (setq tp 'integer i '(#.most-negative-fixnum #.most-positive-fixnum)))
135      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
136       (setq tp 'float)))
137    (cons tp i)))
138
139(defun sub-interval-p (i1 i2)
140  (let (low1 high1 low2 high2)
141    (if (null i1)
142        (setq low1 '* high1 '*)
143        (if (null (cdr i1))
144            (setq low1 (car i1) high1 '*)
145            (setq low1 (car i1) high1 (cadr i1))))
146    (if (null i2)
147        (setq low2 '* high2 '*)
148        (if (null (cdr i2))
149            (setq low2 (car i2) high2 '*)
150            (setq low2 (car i2) high2 (cadr i2))))
151    (when (and (consp low1) (integerp (car low1)))
152      (setq low1 (1+ (car low1))))
153    (when (and (consp low2) (integerp (car low2)))
154      (setq low2 (1+ (car low2))))
155    (when (and (consp high1) (integerp (car high1)))
156      (setq high1 (1- (car high1))))
157    (when (and (consp high2) (integerp (car high2)))
158      (setq high2 (1- (car high2))))
159    (cond ((eq low1 '*)
160     (unless (eq low2 '*)
161             (return-from sub-interval-p nil)))
162          ((eq low2 '*))
163    ((consp low1)
164     (if (consp low2)
165         (when (< (car low1) (car low2))
166         (return-from sub-interval-p nil))
167         (when (< (car low1) low2)
168         (return-from sub-interval-p nil))))
169    ((if (consp low2)
170         (when (<= low1 (car low2))
171         (return-from sub-interval-p nil))
172         (when (< low1 low2)
173         (return-from sub-interval-p nil)))))
174    (cond ((eq high1 '*)
175     (unless (eq high2 '*)
176             (return-from sub-interval-p nil)))
177          ((eq high2 '*))
178    ((consp high1)
179     (if (consp high2)
180         (when (> (car high1) (car high2))
181         (return-from sub-interval-p nil))
182         (when (> (car high1) high2)
183         (return-from sub-interval-p nil))))
184    ((if (consp high2)
185         (when (>= high1 (car high2))
186         (return-from sub-interval-p nil))
187         (when (> high1 high2)
188         (return-from sub-interval-p nil)))))
189    (return-from sub-interval-p t)))
190
191(defun simple-subtypep (type1 type2)
192  (when (and (symbolp type1) (symbolp type2) (known-type-p type1))
193    ;; type1 is a known type. type1 can only be a subtype of type2 if type2 is
194    ;; also a known type.
195    (return-from simple-subtypep (if (memq type2 (supertypes type1))
196                                     t
197                                     (dolist (supertype (supertypes type1))
198                                       (when (simple-subtypep supertype type2)
199                                         (return (values t)))))))
200  (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
201        (c2 (if (classp type2) type2 (find-class type2 nil))))
202    (when (and c1 c2)
203      (return-from simple-subtypep
204                   (if (memq c2 (class-precedence-list c1)) t nil))))
205  nil)
206
207(defun subtypep (type1 type2)
208  (when (or (null type1) (eq type2 t))
209    (return-from subtypep (values t t)))
210  (setq type1 (normalize-type type1)
211        type2 (normalize-type type2))
212  (when (equal type1 type2)
213    (return-from subtypep (values t t)))
214  (let ((t1 (car type1))
215        (t2 (car type2))
216        (i1 (cdr type1))
217        (i2 (cdr type2)))
218    (when (eq t2 'atom)
219      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
220                                  ((known-type-p t1) (values t t))
221                                  (t (values nil nil)))))
222    (cond  ((eq t1 'or)
223            (dolist (tt i1)
224              (multiple-value-bind (tv flag) (subtypep tt type2)
225                (unless tv (return-from subtypep (values tv flag)))))
226            (return-from subtypep (values t t)))
227           ((eq t1 'and)
228            (dolist (tt i1)
229              (let ((tv (subtypep tt type2)))
230                (when tv (return-from subtypep (values t t)))))
231            (return-from subtypep (values nil nil)))
232           ((eq t2 'or)
233            (dolist (tt i2)
234              (let ((tv (subtypep type1 tt)))
235                (when tv (return-from subtypep (values t t)))))
236            (return-from subtypep (values nil nil)))
237           ((eq t2 'and)
238            (dolist (tt i2)
239              (multiple-value-bind (tv flag) (subtypep type1 tt)
240                (unless tv (return-from subtypep (values tv flag)))))
241            (return-from subtypep (values t t)))
242           ((null (or i1 i2))
243            (return-from subtypep (values (simple-subtypep t1 t2) t)))
244           ((eq t2 'sequence)
245            (cond ((memq t1 '(null cons list))
246                   (values t t))
247                  ((memq t1 '(array simple-array))
248                   (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
249                       (values t t)
250                       (values nil t)))
251                  (t (values nil (known-type-p t1)))))
252           ((eq t2 'simple-string)
253            (if (memq t1 '(simple-string simple-base-string))
254                (if (or (null i2) (eq (car i2) '*))
255                    (values t t)
256                    (values nil t))
257                (values nil (known-type-p t2))))
258           (t
259            (cond ((eq t1 'float)
260                   (if (memq t2 '(float real number))
261                       (values (sub-interval-p i1 i2) t)
262                       (values nil (known-type-p t2))))
263                  ((eq t1 'integer)
264                   (if (memq t2 '(integer rational real number))
265                       (values (sub-interval-p i1 i2) t)
266                       (values nil (known-type-p t2))))
267                  ((eq t1 'rational)
268                   (if (memq t2 '(rational real number))
269                       (values (sub-interval-p i1 i2) t)
270                       (values nil (known-type-p t2))))
271                  ((eq t1 'real)
272                   (if (memq t2 '(real number))
273                       (values (sub-interval-p i1 i2) t)
274                       (values nil (known-type-p t2))))
275                  ((memq t1 '(string simple-string base-string
276                              simple-base-string))
277                   (cond ((eq t2 'string)
278                          (if (or (null i2) (eq (car i2) '*))
279                              (values t t)
280                              (values nil t)))
281                         (t
282                          (values nil (known-type-p t2)))))
283                  (t
284                   (values nil nil)))))))
Note: See TracBrowser for help on using the repository browser.