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

Last change on this file since 8759 was 8759, checked in by piso, 17 years ago

(typep "foo" '(simple-string *)) => T

File size: 5.4 KB
Line 
1;;; typep.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: typep.lisp,v 1.23 2005-03-12 18:36:06 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(defun simple-array-p (object)
25  (and (arrayp object)
26       (not (array-has-fill-pointer-p object))
27       (multiple-value-bind (displaced-to offset) (array-displacement object)
28         (and (null displaced-to) (zerop offset)))))
29
30(defun in-interval-p (x interval)
31  (let (low high)
32    (if (endp interval)
33        (setq low '* high '*)
34        (if (endp (cdr interval))
35            (setq low (car interval) high '*)
36            (setq low (car interval) high (cadr interval))))
37    (cond ((eq low '*))
38          ((consp low)
39           (when (<= x (car low)) (return-from in-interval-p nil)))
40          ((when (< x low) (return-from in-interval-p nil))))
41    (cond ((eq high '*))
42          ((consp high)
43           (when (>= x (car high)) (return-from in-interval-p nil)))
44          ((when (> x high) (return-from in-interval-p nil))))
45    (return-from in-interval-p t)))
46
47(defun match-dimensions (dim pat)
48  (if (null dim)
49      (null pat)
50      (and (or (eq (car pat) '*)
51         (eql (car dim) (car pat)))
52     (match-dimensions (cdr dim) (cdr pat)))))
53
54(defun %typep (object type)
55  (when (atom type)
56    (unless (and (symbolp type) (get type 'deftype-definition))
57      (return-from %typep (simple-typep object type))))
58  (setf type (normalize-type type))
59  (when (atom type)
60    (return-from %typep (simple-typep object type)))
61  (let ((tp (car type))
62        (i (cdr type)))
63    (case tp
64      (AND
65       (dolist (type i)
66         (unless (%typep object type)
67           (return-from %typep nil)))
68       t)
69      (OR
70       (dolist (type i)
71         (when (%typep object type)
72           (return-from %typep t)))
73       nil)
74      (NOT (not (%typep object (car i))))
75      (MEMBER (member object i))
76      (CONS
77       (and (consp object)
78            (or (null (car i)) (eq (car i) '*) (%typep (car object) (car i)))
79            (or (null (cadr i)) (eq (cadr i) '*) (%typep (cdr object) (cadr i)))))
80      (FLOAT
81       (and (floatp object) (in-interval-p object i)))
82      (INTEGER
83       (and (integerp object) (in-interval-p object i)))
84      (RATIONAL
85       (and (rationalp 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      (SIMPLE-BIT-VECTOR
94       (and (simple-bit-vector-p object)
95            (or (endp i) (match-dimensions (array-dimensions object) i))))
96      (BIT-VECTOR
97       (and (bit-vector-p object)
98            (or (endp i) (match-dimensions (array-dimensions object) i))))
99      (SIMPLE-STRING
100       (and (simple-string-p object)
101            (or (null i)
102                (eq (car i) '*)
103                (eql (car i) (length object)))))
104      (STRING
105       (and (stringp object)
106            (or (null i)
107                (eq (car i) '*)
108                (eql (car i) (length object)))))
109      (SIMPLE-VECTOR
110       (and (simple-vector-p object)
111            (or (endp i) (eq (car i) '*)
112                (= (length object) (car i)))))
113      (VECTOR
114       (and (vectorp object)
115            (or (endp i)
116                (eq (car i) '*)
117                (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))
118                (and (stringp object) (%subtypep (car i) 'character))
119                (equal (array-element-type object) (car i)))
120            (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
121      (SIMPLE-ARRAY
122       (and (simple-array-p object)
123            (or (endp i) (eq (car i) '*)
124                (equal (array-element-type object) (upgraded-array-element-type (car i))))
125            (or (endp (cdr i)) (eq (cadr i) '*)
126                (if (listp (cadr i))
127                    (match-dimensions (array-dimensions object) (cadr i))
128                    (eql (array-rank object) (cadr i))))))
129      (ARRAY
130       (and (arrayp object)
131            (or (null i) (eq (car i) '*)
132                (equal (array-element-type object) (upgraded-array-element-type (car i))))
133            (or (null (cdr i)) (eq (cadr i) '*)
134                (if (listp (cadr i))
135                    (match-dimensions (array-dimensions object) (cadr i))
136                    (eql (array-rank object) (cadr i))))))
137      (EQL
138       (eql object (car i)))
139      (SATISFIES
140       (funcall (car i) object))
141      (NIL-VECTOR
142       (and (simple-typep object 'nil-vector)
143            (or (null i)
144                (eql (car i) (length object)))))
145      (t
146       nil))))
147
148(defun typep (object type &optional environment)
149  (%typep object type))
Note: See TracBrowser for help on using the repository browser.