source: trunk/j/src/org/armedbear/lisp/typep.lisp @ 9266

Last change on this file since 9266 was 9238, checked in by piso, 16 years ago

TYPEP: signal errors for invalid type specifiers per ANSI.

File size: 6.3 KB
Line 
1;;; typep.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: typep.lisp,v 1.29 2005-05-24 13:59:11 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(in-package #:system)
21
22(defun simple-array-p (object)
23  (and (arrayp object)
24       (not (array-has-fill-pointer-p object))
25       (multiple-value-bind (displaced-to offset) (array-displacement object)
26         (and (null displaced-to) (zerop offset)))))
27
28(defun in-interval-p (x interval)
29  (let (low high)
30    (if (endp interval)
31        (setq low '* high '*)
32        (if (endp (%cdr interval))
33            (setq low (%car interval) high '*)
34            (setq low (%car interval) high (%cadr interval))))
35    (cond ((eq low '*))
36          ((consp low)
37           (when (<= x (%car low))
38             (return-from in-interval-p nil)))
39          ((when (< x low)
40             (return-from in-interval-p nil))))
41    (cond ((eq high '*))
42          ((consp high)
43           (when (>= x (%car high))
44             (return-from in-interval-p nil)))
45          ((when (> x high)
46             (return-from in-interval-p nil))))
47    t))
48
49(defun match-dimensions (dim pat)
50  (if (null dim)
51      (null pat)
52      (and (or (eq (car pat) '*)
53         (eql (car dim) (car pat)))
54     (match-dimensions (cdr dim) (cdr pat)))))
55
56(defun %typep (object type)
57  (when (atom type)
58    (when (eq type 'values)
59      (error 'simple-error
60             :format-control "The symbol ~S is not valid as a type specifier."
61             :format-arguments (list type)))
62    (unless (and (symbolp type) (get type 'deftype-definition))
63      (return-from %typep (simple-typep object type))))
64  (setf type (normalize-type type))
65  (when (atom type)
66    (return-from %typep (simple-typep object type)))
67  (let ((tp (%car type))
68        (i (%cdr type)))
69    (case tp
70      (AND
71       (dolist (type i)
72         (unless (%typep object type)
73           (return-from %typep nil)))
74       t)
75      (OR
76       (dolist (type i)
77         (when (%typep object type)
78           (return-from %typep t)))
79       nil)
80      (NOT
81       (not (%typep object (car i))))
82      (MEMBER
83       (member object i))
84      (CONS
85       (and (consp object)
86            (or (null (car i)) (eq (car i) '*) (%typep (%car object) (car i)))
87            (or (null (cadr i)) (eq (cadr i) '*) (%typep (%cdr object) (cadr i)))))
88      (INTEGER
89       (and (integerp object) (in-interval-p object i)))
90      (RATIONAL
91       (and (rationalp object) (in-interval-p object i)))
92      ((FLOAT SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT LONG-FLOAT)
93       (and (floatp object) (in-interval-p object i)))
94      (REAL
95       (and (realp object) (in-interval-p object i)))
96      (COMPLEX
97       (and (complexp object)
98            (or (null i)
99                (and (typep (realpart object) i)
100                     (typep (imagpart object) i)))))
101      (SIMPLE-BIT-VECTOR
102       (and (simple-bit-vector-p object)
103            (or (endp i)
104                (eq (%car i) '*)
105                (eql (%car i) (array-dimension object 0)))))
106      (BIT-VECTOR
107       (and (bit-vector-p object)
108            (or (endp i)
109                (eq (%car i) '*)
110                (eql (%car i) (array-dimension object 0)))))
111      (SIMPLE-STRING
112       (and (simple-string-p object)
113            (or (endp i)
114                (eq (%car i) '*)
115                (eql (%car i) (array-dimension object 0)))))
116      (STRING
117       (and (stringp object)
118            (or (endp i)
119                (eq (%car i) '*)
120                (eql (%car i) (array-dimension object 0)))))
121      (SIMPLE-VECTOR
122       (and (simple-vector-p object)
123            (or (endp i)
124                (eq (%car i) '*)
125                (eql (%car i) (array-dimension object 0)))))
126      (VECTOR
127       (and (vectorp object)
128            (or (endp i)
129                (eq (%car i) '*)
130                (and (eq (%car i) t) (not (stringp object)) (not (bit-vector-p object)))
131                (and (stringp object) (%subtypep (%car i) 'character))
132                (equal (array-element-type object) (%car i)))
133            (or (endp (cdr i))
134                (eq (%cadr i) '*)
135                (eql (%cadr i) (array-dimension object 0)))))
136      (SIMPLE-ARRAY
137       (and (simple-array-p object)
138            (or (endp i)
139                (eq (%car i) '*)
140                (equal (array-element-type object) (upgraded-array-element-type (%car i))))
141            (or (endp (cdr i))
142                (eq (%cadr i) '*)
143                (if (listp (%cadr i))
144                    (match-dimensions (array-dimensions object) (%cadr i))
145                    (eql (array-rank object) (%cadr i))))))
146      (ARRAY
147       (and (arrayp object)
148            (or (endp i)
149                (eq (%car i) '*)
150                (equal (array-element-type object) (upgraded-array-element-type (%car i))))
151            (or (endp (cdr i))
152                (eq (%cadr i) '*)
153                (if (listp (%cadr i))
154                    (match-dimensions (array-dimensions object) (%cadr i))
155                    (eql (array-rank object) (%cadr i))))))
156      (EQL
157       (eql object (car i)))
158      (SATISFIES
159       (unless (symbolp (car i))
160         (error 'simple-type-error
161                :datum (car i)
162                :expected-type 'symbol
163                :format-control "The SATISFIES predicate name is not a symbol: ~S"
164                :format-arguments (list (car i))))
165       (funcall (car i) object))
166      (NIL-VECTOR
167       (and (simple-typep object 'nil-vector)
168            (or (endp i)
169                (eql (%car i) (length object)))))
170      ((FUNCTION VALUES)
171       (error 'simple-error
172              :format-control "~S types are not a legal argument to TYPEP: ~S"
173              :format-arguments (list tp type)))
174      (t
175       nil))))
176
177(defun typep (object type &optional environment)
178  (%typep object type))
Note: See TracBrowser for help on using the repository browser.