source: trunk/j/src/org/armedbear/lisp/early-defuns.lisp @ 9266

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

REQUIRE-TYPE

File size: 8.3 KB
Line 
1;;; early-defuns.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: early-defuns.lisp,v 1.28 2005-05-12 08:14:43 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(export 'require-type)
23
24(defun require-type (arg type)
25  (if (typep arg type)
26      arg
27      (error 'simple-type-error
28             :datum arg
29             :expected-type type)))
30
31(defun normalize-type (type)
32  (cond ((symbolp type)
33         (case type
34           (BIT
35            (return-from normalize-type '(integer 0 1)))
36           (CONS
37            (return-from normalize-type '(cons t t)))
38           (FIXNUM
39            (return-from normalize-type
40                         '(integer #.most-negative-fixnum #.most-positive-fixnum)))
41           (SIGNED-BYTE
42            (return-from normalize-type 'integer))
43           (UNSIGNED-BYTE
44            (return-from normalize-type '(integer 0 *)))
45           (BASE-CHAR
46            (return-from normalize-type 'character))
47           (SHORT-FLOAT
48            (return-from normalize-type 'single-float))
49           (LONG-FLOAT
50            (return-from normalize-type 'double-float))
51           (COMPLEX
52            (return-from normalize-type '(complex *)))
53           (ARRAY
54            (return-from normalize-type '(array * *)))
55           (SIMPLE-ARRAY
56            (return-from normalize-type '(simple-array * *)))
57           (VECTOR
58            (return-from normalize-type '(array * (*))))
59           (SIMPLE-VECTOR
60            (return-from normalize-type '(simple-array t (*))))
61           (BIT-VECTOR
62            (return-from normalize-type '(bit-vector *)))
63           (SIMPLE-BIT-VECTOR
64            (return-from normalize-type '(simple-bit-vector *)))
65           (BASE-STRING
66            (return-from normalize-type '(array base-char (*))))
67           (SIMPLE-BASE-STRING
68            (return-from normalize-type '(simple-array base-char (*))))
69           (STRING
70            (return-from normalize-type '(string *)))
71           (SIMPLE-STRING
72            (return-from normalize-type '(simple-string *)))
73           (t
74            (unless (get type 'deftype-definition)
75              (return-from normalize-type type)))))
76        ((classp type)
77         (when (eq (%class-name type) 'fixnum)
78           (return-from normalize-type
79                        '(integer #.most-negative-fixnum #.most-positive-fixnum))))
80        ((and (consp type)
81              (memq (%car type) '(and or not eql member satisfies mod values)))
82         (return-from normalize-type type)))
83  ;; Fall through...
84  (let (tp i)
85    (loop
86      (if (consp type)
87          (setf tp (%car type) i (%cdr type))
88          (setf tp type i nil))
89      (if (and (symbolp tp) (get tp 'deftype-definition))
90          (setf type (apply (get tp 'deftype-definition) i))
91          (return)))
92    (case tp
93      (CONS
94       (let* ((len (length i))
95              (car-typespec (if (> len 0) (car i) t))
96              (cdr-typespec (if (> len 1) (cadr i) t)))
97         (unless (and car-typespec cdr-typespec)
98           (return-from normalize-type nil))
99         (when (eq car-typespec '*)
100           (setf car-typespec t))
101         (when (eq cdr-typespec '*)
102           (setf cdr-typespec t))
103         (return-from normalize-type (cons tp (list car-typespec cdr-typespec)))))
104      (SIGNED-BYTE
105       (if (or (null i) (eq (car i) '*))
106           (return-from normalize-type 'integer)
107           (return-from normalize-type
108                        (list 'integer
109                              (- (expt 2 (1- (car i))))
110                              (1- (expt 2 (1- (car i))))))))
111      (UNSIGNED-BYTE
112       (if (or (null i) (eq (car i) '*))
113           (return-from normalize-type '(integer 0 *)))
114           (return-from normalize-type (list 'integer 0 (1- (expt 2 (car i))))))
115      ((ARRAY SIMPLE-ARRAY)
116       (unless i
117         (return-from normalize-type (list tp '* '*)))
118       (when (= (length i) 1)
119         (setf i (append i '(*))))
120       (setf (car i) (normalize-type (car i)))
121       (return-from normalize-type (cons tp i)))
122      (VECTOR
123       (case (length i)
124         (0
125          (return-from normalize-type '(array * (*))))
126         (1
127          (setf (car i) (normalize-type (car i)))
128          (return-from normalize-type (list 'array (car i) '(*))))
129         (2
130          (setf (car i) (normalize-type (car i)))
131          (return-from normalize-type (list 'array (car i) (list (cadr i)))))
132         (t
133          (error "Invalid type specifier ~S." type))))
134      (SIMPLE-VECTOR
135       (case (length i)
136         (0
137          (return-from normalize-type '(simple-array t (*))))
138         (1
139          (return-from normalize-type (list 'simple-array t (list (car i)))))
140         (t
141          (error "Invalid type specifier ~S." type))))
142      (BIT-VECTOR
143       (case (length i)
144         (0
145          (return-from normalize-type '(bit-vector *)))
146         (1
147          (return-from normalize-type (list 'bit-vector (car i))))
148         (t
149          (error "Invalid type specifier ~S." type))))
150      (SIMPLE-BIT-VECTOR
151       (case (length i)
152         (0
153          (return-from normalize-type '(simple-bit-vector *)))
154         (1
155          (return-from normalize-type (list 'simple-bit-vector (car i))))
156         (t
157          (error "Invalid type specifier ~S." type))))
158      (BASE-STRING
159       (if i
160           (return-from normalize-type (list 'array 'base-char (list (car i))))
161           (return-from normalize-type '(array base-char (*)))))
162      (SIMPLE-BASE-STRING
163       (if i
164           (return-from normalize-type (list 'simple-array 'base-char (list (car i))))
165           (return-from normalize-type '(simple-array base-char (*)))))
166      (SHORT-FLOAT
167       (setf tp 'single-float))
168      (LONG-FLOAT
169       (setf tp 'double-float))
170      (COMPLEX
171        (cond ((null i)
172               (setf i '(*)))
173              ((eq i 'short-float)
174               (setf i 'single-float))
175              ((eq i 'long-float)
176               (setf i 'double-float)))))
177    (if i (cons tp i) tp)))
178
179(defun caaaar (list) (car (car (car (car list)))))
180(defun caaadr (list) (car (car (car (cdr list)))))
181(defun caaddr (list) (car (car (cdr (cdr list)))))
182(defun cadddr (list) (car (cdr (cdr (cdr list)))))
183(defun cddddr (list) (cdr (cdr (cdr (cdr list)))))
184(defun cdaaar (list) (cdr (car (car (car list)))))
185(defun cddaar (list) (cdr (cdr (car (car list)))))
186(defun cdddar (list) (cdr (cdr (cdr (car list)))))
187(defun caadar (list) (car (car (cdr (car list)))))
188(defun cadaar (list) (car (cdr (car (car list)))))
189(defun cadadr (list) (car (cdr (car (cdr list)))))
190(defun caddar (list) (car (cdr (cdr (car list)))))
191(defun cdaadr (list) (cdr (car (car (cdr list)))))
192(defun cdadar (list) (cdr (car (cdr (car list)))))
193(defun cdaddr (list) (cdr (car (cdr (cdr list)))))
194(defun cddadr (list) (cdr (cdr (car (cdr list)))))
195
196;;; SOME, EVERY, NOTANY, NOTEVERY (from ECL)
197
198(defun some (predicate sequence &rest more-sequences)
199  (setq more-sequences (cons sequence more-sequences))
200  (do ((i 0 (1+ i))
201       (l (apply #'min (mapcar #'length more-sequences))))
202    ((>= i l) nil)
203    (let ((that-value
204           (apply predicate
205                  (mapcar #'(lambda (z) (elt z i)) more-sequences))))
206      (when that-value (return that-value)))))
207
208(defun every (predicate sequence &rest more-sequences)
209  (setq more-sequences (cons sequence more-sequences))
210  (do ((i 0 (1+ i))
211       (l (apply #'min (mapcar #'length more-sequences))))
212      ((>= i l) t)
213    (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
214      (return nil))))
215
216(defun notany (predicate sequence &rest more-sequences)
217  (not (apply #'some predicate sequence more-sequences)))
218
219(defun notevery (predicate sequence &rest more-sequences)
220  (not (apply #'every predicate sequence more-sequences)))
Note: See TracBrowser for help on using the repository browser.