source: project/crunch/primitives.scm @ 3920

Last change on this file since 3920 was 3920, checked in by felix winkelmann, 13 years ago

crunch bugfixes

File size: 8.7 KB
Line 
1;;;; primitives.scm
2;
3; Copyright (c) 2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35(require-for-syntax 'format-modular)
36
37(define-for-syntax (crunch:cify-name name)
38  (string-intersperse
39   (map (lambda (c)
40          (if (or (char-alphabetic? c)
41                  (char-numeric? c) )
42              (string c)
43              (format #f "_~2,'0x" (char->integer c))) )
44        (string->list (->string name)))
45   ""))
46
47(define-macro (defprimitives . prims)
48  `(begin
49     ,@(map
50        (match-lambda
51          (((name args ...) (and ra (or '-> '+>)) result . rm)
52           (let ((real-name (:optional rm (conc "crunch_" (crunch:cify-name name)))))
53             `(crunch-register-primitive
54               ',name ',args ',result
55               ,real-name #f ,(eq? ra '+>)) ) )
56          (def (syntax-error 
57                'defprimitives
58                "invalid primitive definition" def)) )
59        prims) ) )
60
61
62;;; R5RS
63
64(defprimitives
65  ((+ number number) -> number*)
66  ((- number number) -> number*)
67  ((* number number) -> number*)
68  ((/ number number) -> number*)
69  ((= number number) -> bool)
70  ((< number number) -> bool)
71  ((> number number) -> bool)
72  ((<= number number) -> bool)
73  ((>= number number) -> bool)
74  ((quotient int int) -> int)
75  ((remainder int int) -> int)
76  ((modulo int int) -> int)
77  ((max number number) -> number*)
78  ((min number number) -> number*)
79  ((abs number) -> number*)
80  ((floor number) -> number*)
81  ((ceiling number) -> number*)
82  ((truncate number) -> number*)
83  ((round number) -> number*)
84  ((eq? * *) -> bool)
85  ((eqv? * *) -> bool)
86  ((equal? * *) -> bool)
87  ((not *) -> bool)
88  ((newline) -> void)
89  ((display *) -> void)
90  ((write-char char) -> void)
91  ((integer? *) -> bool)
92  ((positive? number) -> bool)
93  ((negative? number) -> bool)
94  ((odd? int) -> bool)
95  ((even? int) -> bool)
96  ((exact? number) -> bool)
97  ((inexact? number) -> bool)
98  ((sqrt double) -> double)
99  ((sin double) -> double)
100  ((cos double) -> double)
101  ((tan double) -> double)
102  ((exp double) -> double)
103  ((log double) -> double)
104  ((expt double double) -> double)
105  ((asin double) -> double)
106  ((acos double) -> double)
107  ((atan double) -> double)
108  ((atan2 double double) -> double)
109  ((exact->inexact number) -> double)
110  ((inexact->exact number) -> int)
111  ((zero? number) -> bool) 
112  ((make-string int char) -> string)
113  ((string-ref string int) -> char)
114  ((string-set! string int char) -> void)
115  ((string-length string) -> int)
116  ((substring string int int) -> string)
117  ((string-append string string) -> string)
118  ((string-copy string) -> string)
119  ((string-fill! string char) -> void)
120  ((string=? string string) -> bool)
121  ((string>? string string) -> bool)
122  ((string<? string string) -> bool)
123  ((string>=? string string) -> bool)
124  ((string<=? string string) -> bool)
125  ((string-ci=? string string) -> bool)
126  ((string-ci>? string string) -> bool)
127  ((string-ci<? string string) -> bool)
128  ((string-ci>=? string string) -> bool)
129  ((string-ci<=? string string) -> bool)
130  ((number->string number int) -> string)
131  ((string->number string int) +> number)
132  ((char-upper-case? char) -> bool)
133  ((char-lower-case? char) -> bool)
134  ((char-alphabetic? char) -> bool)
135  ((char-numeric? char) -> bool)
136  ((char-whitespace? char) -> bool)
137  ((char-upcase char) -> char)
138  ((char-downcase char) -> char)
139  ((char->integer char) -> int)
140  ((integer->char int) -> char)
141  ((char=? char char) -> bool)
142  ((char>? char char) -> bool)
143  ((char<? char char) -> bool)
144  ((char>=? char char) -> bool)
145  ((char<=? char char) -> bool)
146  ((char-ci=? char char) -> bool)
147  ((char-ci>? char char) -> bool)
148  ((char-ci<? char char) -> bool)
149  ((char-ci>=? char char) -> bool)
150  ((char-ci<=? char char) -> bool) )
151
152
153;;; Extensions
154
155(defprimitives
156  ((void) -> void)
157  ((##sys#void) -> void)
158  ((u8vector-ref u8vector int) -> int)
159  ((u8vector-set! u8vector int int) -> void)
160  ((u16vector-ref u16vector int) -> int)
161  ((u16vector-set! u16vector int int) -> void)
162  ((u32vector-ref u32vector int) -> int)
163  ((u32vector-set! u32vector int int) -> void)
164  ((s8vector-ref s8vector int) -> int)
165  ((s8vector-set! s8vector int int) -> void)
166  ((s16vector-ref s16vector int) -> int)
167  ((s16vector-set! s16vector int int) -> void)
168  ((s32vector-ref s32vector int) -> int)
169  ((s32vector-set! s32vector int int) -> void)
170  ((f32vector-ref f32vector int) -> float)
171  ((f32vector-set! f32vector int float) -> void)
172  ((f64vector-ref f64vector int) -> double)
173  ((f64vector-set! f64vector int double) -> void)
174  ((make-u8vector int int) -> u8vector)
175  ((make-s8vector int int) -> s8vector)
176  ((make-u16vector int int) -> u16vector)
177  ((make-s16vector int int) -> s16vector)
178  ((make-u32vector int int) -> u32vector)
179  ((make-s32vector int int) -> s32vector)
180  ((make-f32vector int double) -> f32vector)
181  ((make-f64vector int double) -> f64vector)
182  ((u8vector-length u8vector) -> int)
183  ((s8vector-length s8vector) -> int)
184  ((u16vector-length u16vector) -> int)
185  ((s16vector-length s16vector) -> int)
186  ((u32vector-length u32vector) -> int)
187  ((s32vector-length s32vector) -> int)
188  ((f32vector-length f32vector) -> int)
189  ((f64vector-length f64vector) -> int)
190  ((blob->string blob) -> string)
191  ((string->blob string) -> blob)
192  ((blob->string/shared blob) -> string)
193  ((string->blob/shared blob) -> blob)
194  ((blob->u8vector blob) -> u8vector)
195  ((blob->s8vector blob) -> s8vector)
196  ((blob->u16vector blob) -> u16vector)
197  ((blob->s16vector blob) -> s16vector)
198  ((blob->u32vector blob) -> u32vector)
199  ((blob->s32vector blob) -> s32vector)
200  ((blob->f32vector blob) -> f32vector)
201  ((blob->f64vector blob) -> f64vector)
202  ((blob->u8vector/shared blob) -> u8vector)
203  ((blob->s8vector/shared blob) -> s8vector)
204  ((blob->u16vector/shared blob) -> u16vector)
205  ((blob->s16vector/shared blob) -> s16vector)
206  ((blob->u32vector/shared blob) -> u32vector)
207  ((blob->s32vector/shared blob) -> s32vector)
208  ((blob->f32vector/shared blob) -> f32vector)
209  ((blob->f64vector/shared blob) -> f64vector)
210  ((u8vector->blob blob) -> blob)
211  ((s8vector->blob blob) -> blob)
212  ((u16vector->blob blob) -> blob)
213  ((s16vector->blob blob) -> blob)
214  ((u32vector->blob blob) -> blob)
215  ((s32vector->blob blob) -> blob)
216  ((f32vector->blob blob) -> blob)
217  ((f64vector->blob blob) -> blob)
218  ((u8vector->blob/shared blob) -> blob)
219  ((s8vector->blob/shared blob) -> blob)
220  ((u16vector->blob/shared blob) -> blob)
221  ((s16vector->blob/shared blob) -> blob)
222  ((u32vector->blob/shared blob) -> blob)
223  ((s32vector->blob/shared blob) -> blob)
224  ((f32vector->blob/shared blob) -> blob)
225  ((f64vector->blob/shared blob) -> blob)
226  ((subu8vector u8vector int int) -> u8vector)
227  ((subs8vector s8vector int int) -> s8vector)
228  ((subu16vector u16vector int int) -> u16vector)
229  ((subs16vector s16vector int int) -> s16vector)
230  ((subu32vector u32vector int int) -> u32vector)
231  ((subs32vector s32vector int int) -> s32vector)
232  ((subf32vector f32vector int int) -> f32vector)
233  ((subf64vector f64vector int int) -> f64vector)
234  ((flush-output) -> void)
235  ((bitwise-and int int) -> int)
236  ((bitwise-ior int int) -> int)
237  ((bitwise-xor int int) -> int)
238  ((bitwise-not int) -> int)
239  ((arithmetic-shift int int) -> int)
240  ((error string) -> void)
241  ((exit int) -> void)
242  ((argc) -> int)
243  ((argv-ref int) -> string)
244  ((sub1 number) -> number*)
245  ((add1 number) -> number*) )
Note: See TracBrowser for help on using the repository browser.