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

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

Conditions.
File size: 8.8 KB
Line 
1;;; subtypep.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: subtypep.lisp,v 1.9 2003-09-19 15:14:56 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 STANDARD-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 simple-subtypep (type1 type2)
136  (assert (symbolp type1))
137  (assert (symbolp type2))
138  (if (memq type2 (supertypes type1))
139      t
140      (dolist (supertype (supertypes type1))
141        (when (simple-subtypep supertype type2)
142          (return t)))))
143
144(defun sub-interval-p (i1 i2)
145  (let (low1 high1 low2 high2)
146    (if (null i1)
147        (setq low1 '* high1 '*)
148        (if (null (cdr i1))
149            (setq low1 (car i1) high1 '*)
150            (setq low1 (car i1) high1 (cadr i1))))
151    (if (null i2)
152        (setq low2 '* high2 '*)
153        (if (null (cdr i2))
154            (setq low2 (car i2) high2 '*)
155            (setq low2 (car i2) high2 (cadr i2))))
156    (when (and (consp low1) (integerp (car low1)))
157      (setq low1 (1+ (car low1))))
158    (when (and (consp low2) (integerp (car low2)))
159      (setq low2 (1+ (car low2))))
160    (when (and (consp high1) (integerp (car high1)))
161      (setq high1 (1- (car high1))))
162    (when (and (consp high2) (integerp (car high2)))
163      (setq high2 (1- (car high2))))
164    (cond ((eq low1 '*)
165     (unless (eq low2 '*)
166             (return-from sub-interval-p nil)))
167          ((eq low2 '*))
168    ((consp low1)
169     (if (consp low2)
170         (when (< (car low1) (car low2))
171         (return-from sub-interval-p nil))
172         (when (< (car low1) low2)
173         (return-from sub-interval-p nil))))
174    ((if (consp low2)
175         (when (<= low1 (car low2))
176         (return-from sub-interval-p nil))
177         (when (< low1 low2)
178         (return-from sub-interval-p nil)))))
179    (cond ((eq high1 '*)
180     (unless (eq high2 '*)
181             (return-from sub-interval-p nil)))
182          ((eq high2 '*))
183    ((consp high1)
184     (if (consp high2)
185         (when (> (car high1) (car high2))
186         (return-from sub-interval-p nil))
187         (when (> (car high1) high2)
188         (return-from sub-interval-p nil))))
189    ((if (consp high2)
190         (when (>= high1 (car high2))
191         (return-from sub-interval-p nil))
192         (when (> high1 high2)
193         (return-from sub-interval-p nil)))))
194    (return-from sub-interval-p t)))
195
196(defun subtypep (type1 type2)
197  (when (or (null type1) (eq type2 t))
198    (return-from subtypep (values t t)))
199  (setq type1 (normalize-type type1)
200        type2 (normalize-type type2))
201  (when (equal type1 type2)
202    (return-from subtypep (values t t)))
203  (let ((t1 (car type1))
204        (t2 (car type2))
205        (i1 (cdr type1))
206        (i2 (cdr type2)))
207    (when (eq t2 'atom)
208      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
209                                  ((known-type-p t1) (values t t))
210                                  (t (values nil nil)))))
211    (unless (or i1 i2)
212      (return-from subtypep (values (simple-subtypep t1 t2) t)))
213    (cond ((eq t2 'sequence)
214           (values (simple-subtypep t2 t2) t))
215          ((eq t2 'simple-string)
216           (if (memq t1 '(simple-string simple-base-string))
217               (if (or (null i2) (eq (car i2) '*))
218                   (values t t)
219                   (values nil t))
220               (values nil (known-type-p t2))))
221          (t
222           (cond ((eq t1 'float)
223                  (if (memq t2 '(float real number))
224                      (values (sub-interval-p i1 i2) t)
225                      (values nil (known-type-p t2))))
226                 ((eq t1 'integer)
227                  (if (memq t2 '(integer rational real number))
228                      (values (sub-interval-p i1 i2) t)
229                      (values nil (known-type-p t2))))
230                 ((eq t1 'rational)
231                  (if (memq t2 '(rational real number))
232                      (values (sub-interval-p i1 i2) t)
233                      (values nil (known-type-p t2))))
234                 ((eq t1 'real)
235                  (if (memq t2 '(real number))
236                      (values (sub-interval-p i1 i2) t)
237                      (values nil (known-type-p t2))))
238                 ((memq t1 '(string simple-string base-string
239                             simple-base-string))
240                  (cond ((eq t2 'string)
241                         (if (or (null i2) (eq (car i2) '*))
242                             (values t t)
243                             (values nil t)))
244                        (t
245                         (values nil (known-type-p t2)))))
246                 (t
247                  (values nil nil)))))))
Note: See TracBrowser for help on using the repository browser.