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

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

CLASS-NAME => SYS::%CLASS-NAME

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