1 | ;;; typep.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: typep.lisp 15569 2022-03-19 12:50:18Z mevenson $ |
---|
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 | ;;; As a special exception, the copyright holders of this library give you |
---|
21 | ;;; permission to link this library with independent modules to produce an |
---|
22 | ;;; executable, regardless of the license terms of these independent |
---|
23 | ;;; modules, and to copy and distribute the resulting executable under |
---|
24 | ;;; terms of your choice, provided that you also meet, for each linked |
---|
25 | ;;; independent module, the terms and conditions of the license of that |
---|
26 | ;;; module. An independent module is a module which is not derived from |
---|
27 | ;;; or based on this library. If you modify this library, you may extend |
---|
28 | ;;; this exception to your version of the library, but you are not |
---|
29 | ;;; obligated to do so. If you do not wish to do so, delete this |
---|
30 | ;;; exception statement from your version. |
---|
31 | |
---|
32 | (in-package #:system) |
---|
33 | |
---|
34 | (defun simple-array-p (object) |
---|
35 | (and (arrayp object) |
---|
36 | (not (array-has-fill-pointer-p object)) |
---|
37 | (multiple-value-bind (displaced-to offset) (array-displacement object) |
---|
38 | (and (null displaced-to) (zerop offset))))) |
---|
39 | |
---|
40 | (defun in-interval-p (x interval) |
---|
41 | (if (endp interval) |
---|
42 | t |
---|
43 | (let ((low (%car interval)) |
---|
44 | (high (if (endp (%cdr interval)) '* (%cadr interval)))) |
---|
45 | (cond ((eq low '*)) |
---|
46 | ((consp low) |
---|
47 | (when (<= x (%car low)) |
---|
48 | (return-from in-interval-p nil))) |
---|
49 | ((when (< x low) |
---|
50 | (return-from in-interval-p nil)))) |
---|
51 | (cond ((eq high '*)) |
---|
52 | ((consp high) |
---|
53 | (when (>= x (%car high)) |
---|
54 | (return-from in-interval-p nil))) |
---|
55 | ((when (> x high) |
---|
56 | (return-from in-interval-p nil)))) |
---|
57 | t))) |
---|
58 | |
---|
59 | (defun match-dimensions (dim pat) |
---|
60 | (if (null dim) |
---|
61 | (null pat) |
---|
62 | (and (or (eq (car pat) '*) |
---|
63 | (eql (car dim) (car pat))) |
---|
64 | (match-dimensions (cdr dim) (cdr pat))))) |
---|
65 | |
---|
66 | (defun %typep (object type) |
---|
67 | (when (atom type) |
---|
68 | (when (eq type 'values) |
---|
69 | (error 'simple-error |
---|
70 | :format-control "The symbol ~S is not valid as a type specifier." |
---|
71 | :format-arguments (list type))) |
---|
72 | (unless (and (symbolp type) (get type 'deftype-definition)) |
---|
73 | (return-from %typep (simple-typep object type)))) |
---|
74 | (setf type (normalize-type type)) |
---|
75 | (when (atom type) |
---|
76 | (return-from %typep (simple-typep object type))) |
---|
77 | (let ((tp (%car type)) |
---|
78 | (i (%cdr type))) |
---|
79 | (case tp |
---|
80 | (INTEGER |
---|
81 | (and (integerp object) (in-interval-p object i))) |
---|
82 | (RATIONAL |
---|
83 | (and (rationalp object) (in-interval-p object i))) |
---|
84 | ((FLOAT SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT LONG-FLOAT) |
---|
85 | (and (floatp object) (in-interval-p object i))) |
---|
86 | (REAL |
---|
87 | (and (realp object) (in-interval-p object i))) |
---|
88 | (COMPLEX |
---|
89 | (and (complexp object) |
---|
90 | (or (null i) |
---|
91 | (and (typep (realpart object) i) |
---|
92 | (typep (imagpart object) i))))) |
---|
93 | (CONS |
---|
94 | (and (consp object) |
---|
95 | (or (null (car i)) (eq (car i) '*) (%typep (%car object) (car i))) |
---|
96 | (or (null (cadr i)) (eq (cadr i) '*) (%typep (%cdr object) (cadr i))))) |
---|
97 | (SIMPLE-BIT-VECTOR |
---|
98 | (and (simple-bit-vector-p object) |
---|
99 | (or (endp i) |
---|
100 | (eq (%car i) '*) |
---|
101 | (eql (%car i) (array-dimension object 0))))) |
---|
102 | (BIT-VECTOR |
---|
103 | (and (bit-vector-p object) |
---|
104 | (or (endp i) |
---|
105 | (eq (%car i) '*) |
---|
106 | (eql (%car i) (array-dimension object 0))))) |
---|
107 | (SIMPLE-STRING |
---|
108 | (and (simple-string-p object) |
---|
109 | (or (endp i) |
---|
110 | (eq (%car i) '*) |
---|
111 | (eql (%car i) (array-dimension object 0))))) |
---|
112 | (STRING |
---|
113 | (and (stringp object) |
---|
114 | (or (endp i) |
---|
115 | (eq (%car i) '*) |
---|
116 | (eql (%car i) (array-dimension object 0))))) |
---|
117 | (SIMPLE-VECTOR |
---|
118 | (and (simple-vector-p object) |
---|
119 | (or (endp i) |
---|
120 | (eq (%car i) '*) |
---|
121 | (eql (%car i) (array-dimension object 0))))) |
---|
122 | (VECTOR |
---|
123 | (and (vectorp object) |
---|
124 | (or (endp i) |
---|
125 | (eq (%car i) '*) |
---|
126 | (and (eq (%car i) t) (not (stringp object)) (not (bit-vector-p object))) |
---|
127 | (and (stringp object) (%subtypep (%car i) 'character)) |
---|
128 | (equal (array-element-type object) (%car i))) |
---|
129 | (or (endp (cdr i)) |
---|
130 | (eq (%cadr i) '*) |
---|
131 | (eql (%cadr i) (array-dimension object 0))))) |
---|
132 | (SIMPLE-ARRAY |
---|
133 | (and (simple-array-p object) |
---|
134 | (or (endp i) |
---|
135 | (eq (%car i) '*) |
---|
136 | (equal (array-element-type object) (upgraded-array-element-type (%car i)))) |
---|
137 | (or (endp (cdr i)) |
---|
138 | (eq (%cadr i) '*) |
---|
139 | (if (listp (%cadr i)) |
---|
140 | (match-dimensions (array-dimensions object) (%cadr i)) |
---|
141 | (eql (array-rank object) (%cadr i)))))) |
---|
142 | (ARRAY |
---|
143 | (and (arrayp object) |
---|
144 | (or (endp i) |
---|
145 | (eq (%car i) '*) |
---|
146 | (equal (array-element-type object) (upgraded-array-element-type (%car i)))) |
---|
147 | (or (endp (cdr i)) |
---|
148 | (eq (%cadr i) '*) |
---|
149 | (if (listp (%cadr i)) |
---|
150 | (match-dimensions (array-dimensions object) (%cadr i)) |
---|
151 | (eql (array-rank object) (%cadr i)))))) |
---|
152 | (AND |
---|
153 | (dolist (type i) |
---|
154 | (unless (%typep object type) |
---|
155 | (return-from %typep nil))) |
---|
156 | t) |
---|
157 | (OR |
---|
158 | (dolist (type i) |
---|
159 | (when (%typep object type) |
---|
160 | (return-from %typep t))) |
---|
161 | nil) |
---|
162 | (NOT |
---|
163 | (not (%typep object (car i)))) |
---|
164 | (MEMBER |
---|
165 | (member object i)) |
---|
166 | (EQL |
---|
167 | (eql object (car i))) |
---|
168 | (SATISFIES |
---|
169 | (unless (symbolp (car i)) |
---|
170 | (error 'simple-type-error |
---|
171 | :datum (car i) |
---|
172 | :expected-type 'symbol |
---|
173 | :format-control "The SATISFIES predicate name is not a symbol: ~S" |
---|
174 | :format-arguments (list (car i)))) |
---|
175 | (funcall (car i) object)) |
---|
176 | (NIL-VECTOR |
---|
177 | (and (simple-typep object 'nil-vector) |
---|
178 | (or (endp i) |
---|
179 | (eql (%car i) (length object))))) |
---|
180 | (MOD |
---|
181 | (and (integerp object) |
---|
182 | (or (zerop object) |
---|
183 | (and (plusp object) |
---|
184 | (< object (second type)))))) |
---|
185 | ((FUNCTION VALUES) |
---|
186 | (error 'simple-error |
---|
187 | :format-control "~S types are not a legal argument to TYPEP: ~S" |
---|
188 | :format-arguments (list tp type))) |
---|
189 | (t |
---|
190 | nil)))) |
---|
191 | |
---|
192 | (defun typep (object type &optional environment) |
---|
193 | (declare (ignore environment)) |
---|
194 | (%typep object type)) |
---|