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

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.0 KB
RevLine 
[3740]1;;; typep.lisp
2;;;
[8772]3;;; Copyright (C) 2003-2005 Peter Graves
[11297]4;;; $Id: typep.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
[3740]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.
[11391]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.
[3740]31
[8978]32(in-package #:system)
[3740]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
[3828]40(defun in-interval-p (x interval)
[9351]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)))
[3828]58
[3740]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
[5747]66(defun %typep (object type)
[3740]67  (when (atom type)
[9238]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)))
[5138]72    (unless (and (symbolp type) (get type 'deftype-definition))
[5747]73      (return-from %typep (simple-typep object type))))
[5604]74  (setf type (normalize-type type))
75  (when (atom type)
[5747]76    (return-from %typep (simple-typep object type)))
[8978]77  (let ((tp (%car type))
78        (i (%cdr type)))
[3740]79    (case tp
[3828]80      (INTEGER
81       (and (integerp object) (in-interval-p object i)))
[4805]82      (RATIONAL
83       (and (rationalp object) (in-interval-p object i)))
[8978]84      ((FLOAT SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT LONG-FLOAT)
85       (and (floatp object) (in-interval-p object i)))
[4805]86      (REAL
87       (and (realp object) (in-interval-p object i)))
[5780]88      (COMPLEX
89       (and (complexp object)
90            (or (null i)
91                (and (typep (realpart object) i)
92                     (typep (imagpart object) i)))))
[9351]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)))))
[3740]97      (SIMPLE-BIT-VECTOR
98       (and (simple-bit-vector-p object)
[8772]99            (or (endp i)
[8978]100                (eq (%car i) '*)
101                (eql (%car i) (array-dimension object 0)))))
[3740]102      (BIT-VECTOR
103       (and (bit-vector-p object)
[8772]104            (or (endp i)
[8978]105                (eq (%car i) '*)
106                (eql (%car i) (array-dimension object 0)))))
[5800]107      (SIMPLE-STRING
108       (and (simple-string-p object)
[8772]109            (or (endp i)
[8978]110                (eq (%car i) '*)
111                (eql (%car i) (array-dimension object 0)))))
[5800]112      (STRING
113       (and (stringp object)
[8772]114            (or (endp i)
[8978]115                (eq (%car i) '*)
116                (eql (%car i) (array-dimension object 0)))))
[3740]117      (SIMPLE-VECTOR
118       (and (simple-vector-p object)
[8772]119            (or (endp i)
[8978]120                (eq (%car i) '*)
121                (eql (%car i) (array-dimension object 0)))))
[3740]122      (VECTOR
123       (and (vectorp object)
124            (or (endp i)
[8978]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)))
[8772]129            (or (endp (cdr i))
[8978]130                (eq (%cadr i) '*)
131                (eql (%cadr i) (array-dimension object 0)))))
[3740]132      (SIMPLE-ARRAY
133       (and (simple-array-p object)
[8978]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))))))
[3740]142      (ARRAY
143       (and (arrayp object)
[8978]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))))))
[9351]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))
[4801]166      (EQL
167       (eql object (car i)))
[4808]168      (SATISFIES
[9081]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))))
[4808]175       (funcall (car i) object))
[8016]176      (NIL-VECTOR
177       (and (simple-typep object 'nil-vector)
[8978]178            (or (endp i)
179                (eql (%car i) (length object)))))
[9238]180      ((FUNCTION VALUES)
181       (error 'simple-error
182              :format-control "~S types are not a legal argument to TYPEP: ~S"
183              :format-arguments (list tp type)))
[3740]184      (t
185       nil))))
[5747]186
187(defun typep (object type &optional environment)
[9426]188  (declare (ignore environment))
[5747]189  (%typep object type))
Note: See TracBrowser for help on using the repository browser.