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

Last change on this file since 8489 was 8489, checked in by piso, 17 years ago

NORMALIZE-TYPE: work in progress.

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.19 2005-02-06 13:25:39 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       (return-from normalize-type (cons tp i)))
113      (VECTOR
114       (case (length i)
115         (0
116          (return-from normalize-type '(array * (*))))
117         (1
118          (return-from normalize-type (list 'array (car i) '(*))))
119         (2
120          (return-from normalize-type (list 'array (car i) (list (cadr i)))))
121         (t
122          (error "Invalid type specifier ~S." type))))
123      (SIMPLE-VECTOR
124       (case (length i)
125         (0
126          (return-from normalize-type '(simple-array t (*))))
127         (1
128          (return-from normalize-type (list 'simple-array t (list (car i)))))
129         (t
130          (error "Invalid type specifier ~S." type))))
131      (BIT-VECTOR
132       (case (length i)
133         (0
134          (return-from normalize-type '(bit-vector *)))
135         (1
136          (return-from normalize-type (list 'bit-vector (car i))))
137         (t
138          (error "Invalid type specifier ~S." type))))
139      (SIMPLE-BIT-VECTOR
140       (case (length i)
141         (0
142          (return-from normalize-type '(simple-bit-vector *)))
143         (1
144          (return-from normalize-type (list 'simple-bit-vector (car i))))
145         (t
146          (error "Invalid type specifier ~S." type))))
147      (BASE-STRING
148       (if i
149           (return-from normalize-type (list 'array 'base-char (list (car i))))
150           (return-from normalize-type '(array base-char (*)))))
151      (SIMPLE-BASE-STRING
152       (if i
153           (return-from normalize-type (list 'simple-array 'base-char (list (car i))))
154           (return-from normalize-type '(simple-array base-char (*)))))
155      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
156       (setf tp 'float))
157      (COMPLEX
158        (cond ((null i)
159               (setf i '(*)))
160              ((memq i '(short-float single-float double-float long-float))
161               (setf i 'float)))))
162    (if i (cons tp i) tp)))
163
164(defun caaaar (list) (car (car (car (car list)))))
165(defun caaadr (list) (car (car (car (cdr list)))))
166(defun caaddr (list) (car (car (cdr (cdr list)))))
167(defun cadddr (list) (car (cdr (cdr (cdr list)))))
168(defun cddddr (list) (cdr (cdr (cdr (cdr list)))))
169(defun cdaaar (list) (cdr (car (car (car list)))))
170(defun cddaar (list) (cdr (cdr (car (car list)))))
171(defun cdddar (list) (cdr (cdr (cdr (car list)))))
172(defun caadar (list) (car (car (cdr (car list)))))
173(defun cadaar (list) (car (cdr (car (car list)))))
174(defun cadadr (list) (car (cdr (car (cdr list)))))
175(defun caddar (list) (car (cdr (cdr (car list)))))
176(defun cdaadr (list) (cdr (car (car (cdr list)))))
177(defun cdadar (list) (cdr (car (cdr (car list)))))
178(defun cdaddr (list) (cdr (car (cdr (cdr list)))))
179(defun cddadr (list) (cdr (cdr (car (cdr list)))))
180
181;;; SOME, EVERY, NOTANY, NOTEVERY (from ECL)
182
183(defun some (predicate sequence &rest more-sequences)
184  (setq more-sequences (cons sequence more-sequences))
185  (do ((i 0 (1+ i))
186       (l (apply #'min (mapcar #'length more-sequences))))
187    ((>= i l) nil)
188    (let ((that-value
189           (apply predicate
190                  (mapcar #'(lambda (z) (elt z i)) more-sequences))))
191      (when that-value (return that-value)))))
192
193(defun every (predicate sequence &rest more-sequences)
194  (setq more-sequences (cons sequence more-sequences))
195  (do ((i 0 (1+ i))
196       (l (apply #'min (mapcar #'length more-sequences))))
197      ((>= i l) t)
198    (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
199      (return nil))))
200
201(defun notany (predicate sequence &rest more-sequences)
202  (not (apply #'some predicate sequence more-sequences)))
203
204(defun notevery (predicate sequence &rest more-sequences)
205  (not (apply #'every predicate sequence more-sequences)))
Note: See TracBrowser for help on using the repository browser.