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

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

Work in progress.
File size: 10.5 KB
Line 
1;;; subtypep.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: subtypep.lisp,v 1.14 2003-09-22 12:06:46 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    (if (consp type)
115        (setq tp (car type) i (cdr type))
116        (setq tp type i nil))
117    (case tp
118      ((ARRAY SIMPLE-ARRAY)
119       (when (and i (eq (car i) nil))
120         (if (eq tp 'simple-array)
121             (setq tp 'simple-string)
122             (setq tp 'string))
123         (when (cadr i)
124           (if (consp (cadr i))
125               (setq i (cadr i))
126               (setq i (list (cadr i)))))))
127      (BASE-CHAR
128       (setq tp 'character))
129      (FIXNUM
130       (setq tp 'integer i '(#.most-negative-fixnum #.most-positive-fixnum)))
131      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
132       (setq tp 'float)))
133    (cons tp i)))
134
135(defun sub-interval-p (i1 i2)
136  (let (low1 high1 low2 high2)
137    (if (null i1)
138        (setq low1 '* high1 '*)
139        (if (null (cdr i1))
140            (setq low1 (car i1) high1 '*)
141            (setq low1 (car i1) high1 (cadr i1))))
142    (if (null i2)
143        (setq low2 '* high2 '*)
144        (if (null (cdr i2))
145            (setq low2 (car i2) high2 '*)
146            (setq low2 (car i2) high2 (cadr i2))))
147    (when (and (consp low1) (integerp (car low1)))
148      (setq low1 (1+ (car low1))))
149    (when (and (consp low2) (integerp (car low2)))
150      (setq low2 (1+ (car low2))))
151    (when (and (consp high1) (integerp (car high1)))
152      (setq high1 (1- (car high1))))
153    (when (and (consp high2) (integerp (car high2)))
154      (setq high2 (1- (car high2))))
155    (cond ((eq low1 '*)
156     (unless (eq low2 '*)
157             (return-from sub-interval-p nil)))
158          ((eq low2 '*))
159    ((consp low1)
160     (if (consp low2)
161         (when (< (car low1) (car low2))
162         (return-from sub-interval-p nil))
163         (when (< (car low1) low2)
164         (return-from sub-interval-p nil))))
165    ((if (consp low2)
166         (when (<= low1 (car low2))
167         (return-from sub-interval-p nil))
168         (when (< low1 low2)
169         (return-from sub-interval-p nil)))))
170    (cond ((eq high1 '*)
171     (unless (eq high2 '*)
172             (return-from sub-interval-p nil)))
173          ((eq high2 '*))
174    ((consp high1)
175     (if (consp high2)
176         (when (> (car high1) (car high2))
177         (return-from sub-interval-p nil))
178         (when (> (car high1) high2)
179         (return-from sub-interval-p nil))))
180    ((if (consp high2)
181         (when (>= high1 (car high2))
182         (return-from sub-interval-p nil))
183         (when (> high1 high2)
184         (return-from sub-interval-p nil)))))
185    (return-from sub-interval-p t)))
186
187(defun simple-subtypep (type1 type2)
188  (when (and (symbolp type1) (symbolp type2) (known-type-p type1))
189    ;; type1 is a known type. type1 can only be a subtype of type2 if type2 is
190    ;; also a known type.
191    (return-from simple-subtypep (if (memq type2 (supertypes type1))
192                                     t
193                                     (dolist (supertype (supertypes type1))
194                                       (when (simple-subtypep supertype type2)
195                                         (return (values t)))))))
196  (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
197        (c2 (if (classp type2) type2 (find-class type2 nil))))
198    (when (and c1 c2)
199      (return-from simple-subtypep
200                   (if (memq c2 (class-precedence-list c1)) t nil))))
201  nil)
202
203(defun subtypep (type1 type2)
204  (when (or (null type1) (eq type2 t))
205    (return-from subtypep (values t t)))
206  (setq type1 (normalize-type type1)
207        type2 (normalize-type type2))
208  (when (equal type1 type2)
209    (return-from subtypep (values t t)))
210  (let ((t1 (car type1))
211        (t2 (car type2))
212        (i1 (cdr type1))
213        (i2 (cdr type2)))
214    (when (eq t2 'atom)
215      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
216                                  ((known-type-p t1) (values t t))
217                                  (t (values nil nil)))))
218    (cond  ((eq t1 'or)
219            (dolist (tt i1)
220              (multiple-value-bind (tv flag) (subtypep tt type2)
221                (unless tv (return-from subtypep (values tv flag)))))
222            (return-from subtypep (values t t)))
223           ((eq t1 'and)
224            (dolist (tt i1)
225              (let ((tv (subtypep tt type2)))
226                (when tv (return-from subtypep (values t t)))))
227            (return-from subtypep (values nil nil)))
228           ((eq t2 'or)
229            (dolist (tt i2)
230              (let ((tv (subtypep type1 tt)))
231                (when tv (return-from subtypep (values t t)))))
232            (return-from subtypep (values nil nil)))
233           ((eq t2 'and)
234            (dolist (tt i2)
235              (multiple-value-bind (tv flag) (subtypep type1 tt)
236                (unless tv (return-from subtypep (values tv flag)))))
237            (return-from subtypep (values t t)))
238           ((null (or i1 i2))
239            (return-from subtypep (values (simple-subtypep t1 t2) t)))
240           ((eq t2 'sequence)
241            (cond ((memq t1 '(null cons list))
242                   (values t t))
243                  ((memq t1 '(array simple-array))
244                   (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
245                       (values t t)
246                       (values nil t)))
247                  (t (values nil (known-type-p t1)))))
248           ((eq t2 'simple-string)
249            (if (memq t1 '(simple-string simple-base-string))
250                (if (or (null i2) (eq (car i2) '*))
251                    (values t t)
252                    (values nil t))
253                (values nil (known-type-p t2))))
254           (t
255            (cond ((eq t1 'float)
256                   (if (memq t2 '(float real number))
257                       (values (sub-interval-p i1 i2) t)
258                       (values nil (known-type-p t2))))
259                  ((eq t1 'integer)
260                   (if (memq t2 '(integer rational real number))
261                       (values (sub-interval-p i1 i2) t)
262                       (values nil (known-type-p t2))))
263                  ((eq t1 'rational)
264                   (if (memq t2 '(rational real number))
265                       (values (sub-interval-p i1 i2) t)
266                       (values nil (known-type-p t2))))
267                  ((eq t1 'real)
268                   (if (memq t2 '(real number))
269                       (values (sub-interval-p i1 i2) t)
270                       (values nil (known-type-p t2))))
271                  ((memq t1 '(string simple-string base-string
272                              simple-base-string))
273                   (cond ((eq t2 'string)
274                          (if (or (null i2) (eq (car i2) '*))
275                              (values t t)
276                              (values nil t)))
277                         (t
278                          (values nil (known-type-p t2)))))
279                  (t
280                   (values nil nil)))))))
Note: See TracBrowser for help on using the repository browser.