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

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

SINGLE-FLOAT support.

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