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

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

NORMALIZE-TYPE: call NORMALIZE-TYPE recursively on the element type of an ARRAY
or SIMPLE-ARRAY compound type specifier.

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