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

Last change on this file since 11297 was 11297, checked in by ehuelsmann, 12 years ago

Set Id keyword for expansion.

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