source: trunk/abcl/src/org/armedbear/lisp/early-defuns.lisp @ 11457

Last change on this file since 11457 was 11391, checked in by vvoutilainen, 13 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

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