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

Last change on this file since 11297 was 11297, checked in by ehuelsmann, 13 years ago

Set Id keyword for expansion.

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