Commit | Line | Data |
---|---|---|
ac4d09b1 | 1 | ;;; open-coding primitive procedures |
cb28c085 | 2 | |
e2fafeb9 | 3 | ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
cb28c085 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
cb28c085 AW |
18 | |
19 | ;;; Code: | |
20 | ||
55ae815b | 21 | (define-module (language tree-il primitives) |
7382f23e | 22 | #:use-module (system base pmatch) |
71673fba | 23 | #:use-module (ice-9 match) |
07d22c02 | 24 | #:use-module (rnrs bytevectors) |
cb28c085 AW |
25 | #:use-module (system base syntax) |
26 | #:use-module (language tree-il) | |
6c498233 | 27 | #:use-module (srfi srfi-4) |
cb28c085 | 28 | #:use-module (srfi srfi-16) |
403d78f9 | 29 | #:export (resolve-primitives add-interesting-primitive! |
25450a0d | 30 | expand-primitives |
11671bba | 31 | effect-free-primitive? effect+exception-free-primitive? |
863dd873 | 32 | constructor-primitive? |
c46e0a8a AW |
33 | singly-valued-primitive? equality-primitive? |
34 | bailout-primitive? | |
5deea34d | 35 | negate-primitive)) |
55ae815b | 36 | |
5deea34d AW |
37 | ;; When adding to this, be sure to update *multiply-valued-primitives* |
38 | ;; if appropriate. | |
55ae815b | 39 | (define *interesting-primitive-names* |
39caffe7 | 40 | '(apply |
0fcc39a0 | 41 | call-with-values |
bc056057 | 42 | call-with-current-continuation |
55ae815b | 43 | call/cc |
1bf78495 | 44 | dynamic-wind |
55ae815b AW |
45 | values |
46 | eq? eqv? equal? | |
349d5c44 | 47 | memq memv |
ca5e0414 | 48 | = < > <= >= zero? positive? negative? |
55ae815b | 49 | + * - / 1- 1+ quotient remainder modulo |
8006d2d6 | 50 | ash logand logior logxor lognot logtest logbit? |
9b3c4ced | 51 | sqrt abs |
55ae815b | 52 | not |
c46e0a8a | 53 | pair? null? list? symbol? vector? string? struct? number? char? nil? |
e2fafeb9 | 54 | bytevector? keyword? bitvector? |
5deea34d | 55 | |
bb97e4ab AW |
56 | procedure? thunk? |
57 | ||
5deea34d AW |
58 | complex? real? rational? inf? nan? integer? exact? inexact? even? odd? |
59 | ||
60 | char<? char<=? char>=? char>? | |
61 | ||
2874f660 AW |
62 | integer->char char->integer number->string string->number |
63 | ||
9be8a338 | 64 | acons cons cons* |
55ae815b AW |
65 | |
66 | list vector | |
67 | ||
68 | car cdr | |
69 | set-car! set-cdr! | |
70 | ||
71 | caar cadr cdar cddr | |
72 | ||
73 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
74 | ||
75 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
d6f1ce3d AW |
76 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr |
77 | ||
91fc226e AW |
78 | length |
79 | ||
607fe5a6 | 80 | make-vector vector-length vector-ref vector-set! |
d023ae86 | 81 | variable? variable-ref variable-set! |
d27a7811 | 82 | variable-bound? |
39141c87 | 83 | |
3e248c70 | 84 | current-module define! |
d422f316 | 85 | |
c32b7c4c | 86 | fluid-ref fluid-set! with-fluid* |
f5b1f76a | 87 | |
1773bc7d | 88 | call-with-prompt |
38504994 | 89 | abort-to-prompt* abort-to-prompt |
38030bdf | 90 | make-prompt-tag |
747022e4 | 91 | |
5deea34d AW |
92 | throw error scm-error |
93 | ||
9be8a338 AW |
94 | string-length string-ref string-set! |
95 | ||
4c906ad5 | 96 | allocate-struct struct-vtable make-struct struct-ref struct-set! |
bd91ecce | 97 | |
a694809e AW |
98 | bytevector-length |
99 | ||
39141c87 AW |
100 | bytevector-u8-ref bytevector-u8-set! |
101 | bytevector-s8-ref bytevector-s8-set! | |
6c498233 AW |
102 | u8vector-ref u8vector-set! s8vector-ref s8vector-set! |
103 | ||
39141c87 AW |
104 | bytevector-u16-ref bytevector-u16-set! |
105 | bytevector-u16-native-ref bytevector-u16-native-set! | |
106 | bytevector-s16-ref bytevector-s16-set! | |
107 | bytevector-s16-native-ref bytevector-s16-native-set! | |
6c498233 | 108 | u16vector-ref u16vector-set! s16vector-ref s16vector-set! |
39141c87 AW |
109 | |
110 | bytevector-u32-ref bytevector-u32-set! | |
111 | bytevector-u32-native-ref bytevector-u32-native-set! | |
112 | bytevector-s32-ref bytevector-s32-set! | |
113 | bytevector-s32-native-ref bytevector-s32-native-set! | |
6c498233 | 114 | u32vector-ref u32vector-set! s32vector-ref s32vector-set! |
39141c87 AW |
115 | |
116 | bytevector-u64-ref bytevector-u64-set! | |
117 | bytevector-u64-native-ref bytevector-u64-native-set! | |
118 | bytevector-s64-ref bytevector-s64-set! | |
119 | bytevector-s64-native-ref bytevector-s64-native-set! | |
6c498233 | 120 | u64vector-ref u64vector-set! s64vector-ref s64vector-set! |
39141c87 AW |
121 | |
122 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
123 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
124 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
6c498233 AW |
125 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! |
126 | f32vector-ref f32vector-set! f64vector-ref f64vector-set!)) | |
55ae815b AW |
127 | |
128 | (define (add-interesting-primitive! name) | |
129 | (hashq-set! *interesting-primitive-vars* | |
83c76550 AW |
130 | (or (module-variable (current-module) name) |
131 | (error "unbound interesting primitive" name)) | |
39141c87 | 132 | name)) |
55ae815b AW |
133 | |
134 | (define *interesting-primitive-vars* (make-hash-table)) | |
135 | ||
136 | (for-each add-interesting-primitive! *interesting-primitive-names*) | |
137 | ||
11671bba LC |
138 | (define *primitive-constructors* |
139 | ;; Primitives that return a fresh object. | |
4c906ad5 AW |
140 | '(acons cons cons* list vector make-vector |
141 | allocate-struct make-struct make-struct/no-tail | |
f26c3a93 AW |
142 | make-prompt-tag)) |
143 | ||
144 | (define *primitive-accessors* | |
145 | ;; Primitives that are pure, but whose result depends on the mutable | |
146 | ;; memory pointed to by their operands. | |
863dd873 AW |
147 | ;; |
148 | ;; Note: if you add an accessor here, be sure to add a corresponding | |
149 | ;; case in (language tree-il effects)! | |
f26c3a93 AW |
150 | '(vector-ref |
151 | car cdr | |
152 | memq memv | |
5deea34d | 153 | struct-ref |
9be8a338 | 154 | string-ref |
f26c3a93 AW |
155 | bytevector-u8-ref bytevector-s8-ref |
156 | bytevector-u16-ref bytevector-u16-native-ref | |
157 | bytevector-s16-ref bytevector-s16-native-ref | |
158 | bytevector-u32-ref bytevector-u32-native-ref | |
159 | bytevector-s32-ref bytevector-s32-native-ref | |
160 | bytevector-u64-ref bytevector-u64-native-ref | |
161 | bytevector-s64-ref bytevector-s64-native-ref | |
162 | bytevector-ieee-single-ref bytevector-ieee-single-native-ref | |
163 | bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) | |
11671bba | 164 | |
80af1168 | 165 | (define *effect-free-primitives* |
11671bba | 166 | `(values |
80af1168 | 167 | eq? eqv? equal? |
ca5e0414 | 168 | = < > <= >= zero? positive? negative? |
8006d2d6 | 169 | ash logand logior logxor lognot logtest logbit? |
9b3c4ced | 170 | + * - / 1- 1+ sqrt abs quotient remainder modulo |
80af1168 | 171 | not |
d023ae86 AW |
172 | pair? null? nil? list? |
173 | symbol? variable? vector? struct? string? number? char? | |
e2fafeb9 | 174 | bytevector? keyword? bitvector? |
5deea34d AW |
175 | complex? real? rational? inf? nan? integer? exact? inexact? even? odd? |
176 | char<? char<=? char>=? char>? | |
2874f660 | 177 | integer->char char->integer number->string string->number |
5deea34d | 178 | struct-vtable |
a694809e | 179 | length string-length vector-length bytevector-length |
25450a0d | 180 | ;; These all should get expanded out by expand-primitives. |
80af1168 AW |
181 | caar cadr cdar cddr |
182 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
183 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
184 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr | |
f26c3a93 AW |
185 | ,@*primitive-constructors* |
186 | ,@*primitive-accessors*)) | |
80af1168 | 187 | |
4ee781a6 AW |
188 | ;; Like *effect-free-primitives* above, but further restricted in that they |
189 | ;; cannot raise exceptions. | |
190 | (define *effect+exception-free-primitives* | |
191 | '(values | |
192 | eq? eqv? equal? | |
193 | not | |
d023ae86 AW |
194 | pair? null? nil? list? |
195 | symbol? variable? vector? struct? string? number? char? | |
e2fafeb9 | 196 | bytevector? keyword? bitvector? |
bb97e4ab | 197 | procedure? thunk? |
f26c3a93 | 198 | acons cons cons* list vector)) |
80af1168 | 199 | |
5deea34d AW |
200 | ;; Primitives that don't always return one value. |
201 | (define *multiply-valued-primitives* | |
39caffe7 | 202 | '(apply |
0fcc39a0 | 203 | call-with-values |
bc056057 | 204 | call-with-current-continuation |
5deea34d AW |
205 | call/cc |
206 | dynamic-wind | |
5deea34d | 207 | values |
1773bc7d | 208 | call-with-prompt |
38504994 | 209 | @abort abort-to-prompt)) |
5deea34d AW |
210 | |
211 | ;; Procedures that cause a nonlocal, non-resumable abort. | |
212 | (define *bailout-primitives* | |
213 | '(throw error scm-error)) | |
214 | ||
215 | ;; Negatable predicates. | |
216 | (define *negatable-primitives* | |
217 | '((even? . odd?) | |
218 | (exact? . inexact?) | |
73b98028 | 219 | ;; (< <= > >=) are not negatable because of NaNs. |
5deea34d AW |
220 | (char<? . char>=?) |
221 | (char>? . char<=?))) | |
03026d0f | 222 | |
3c65e3fd NL |
223 | (define *equality-primitives* |
224 | '(eq? eqv? equal?)) | |
225 | ||
80af1168 | 226 | (define *effect-free-primitive-table* (make-hash-table)) |
4ee781a6 | 227 | (define *effect+exceptions-free-primitive-table* (make-hash-table)) |
3c65e3fd | 228 | (define *equality-primitive-table* (make-hash-table)) |
5deea34d AW |
229 | (define *multiply-valued-primitive-table* (make-hash-table)) |
230 | (define *bailout-primitive-table* (make-hash-table)) | |
231 | (define *negatable-primitive-table* (make-hash-table)) | |
80af1168 | 232 | |
4ee781a6 AW |
233 | (for-each (lambda (x) |
234 | (hashq-set! *effect-free-primitive-table* x #t)) | |
80af1168 | 235 | *effect-free-primitives*) |
4ee781a6 AW |
236 | (for-each (lambda (x) |
237 | (hashq-set! *effect+exceptions-free-primitive-table* x #t)) | |
238 | *effect+exception-free-primitives*) | |
3c65e3fd NL |
239 | (for-each (lambda (x) |
240 | (hashq-set! *equality-primitive-table* x #t)) | |
241 | *equality-primitives*) | |
03026d0f | 242 | (for-each (lambda (x) |
5deea34d AW |
243 | (hashq-set! *multiply-valued-primitive-table* x #t)) |
244 | *multiply-valued-primitives*) | |
245 | (for-each (lambda (x) | |
246 | (hashq-set! *bailout-primitive-table* x #t)) | |
247 | *bailout-primitives*) | |
248 | (for-each (lambda (x) | |
249 | (hashq-set! *negatable-primitive-table* (car x) (cdr x)) | |
250 | (hashq-set! *negatable-primitive-table* (cdr x) (car x))) | |
251 | *negatable-primitives*) | |
80af1168 | 252 | |
11671bba LC |
253 | (define (constructor-primitive? prim) |
254 | (memq prim *primitive-constructors*)) | |
80af1168 AW |
255 | (define (effect-free-primitive? prim) |
256 | (hashq-ref *effect-free-primitive-table* prim)) | |
4ee781a6 AW |
257 | (define (effect+exception-free-primitive? prim) |
258 | (hashq-ref *effect+exceptions-free-primitive-table* prim)) | |
3c65e3fd NL |
259 | (define (equality-primitive? prim) |
260 | (hashq-ref *equality-primitive-table* prim)) | |
03026d0f | 261 | (define (singly-valued-primitive? prim) |
5deea34d AW |
262 | (not (hashq-ref *multiply-valued-primitive-table* prim))) |
263 | (define (bailout-primitive? prim) | |
264 | (hashq-ref *bailout-primitive-table* prim)) | |
265 | (define (negate-primitive prim) | |
266 | (hashq-ref *negatable-primitive-table* prim)) | |
80af1168 | 267 | |
403d78f9 | 268 | (define (resolve-primitives x mod) |
14b20818 AW |
269 | (define local-definitions |
270 | (make-hash-table)) | |
271 | ||
33e9a90d AW |
272 | ;; Assume that any definitions with primitive names in the root module |
273 | ;; have the same semantics as the primitives. | |
274 | (unless (eq? mod the-root-module) | |
275 | (let collect-local-definitions ((x x)) | |
276 | (record-case x | |
277 | ((<toplevel-define> name) | |
278 | (hashq-set! local-definitions name #t)) | |
279 | ((<seq> head tail) | |
280 | (collect-local-definitions head) | |
281 | (collect-local-definitions tail)) | |
282 | (else #f)))) | |
14b20818 | 283 | |
403d78f9 | 284 | (post-order |
55ae815b | 285 | (lambda (x) |
403d78f9 AW |
286 | (or |
287 | (record-case x | |
288 | ((<toplevel-ref> src name) | |
289 | (and=> (and (not (hashq-ref local-definitions name)) | |
290 | (hashq-ref *interesting-primitive-vars* | |
291 | (module-variable mod name))) | |
292 | (lambda (name) (make-primitive-ref src name)))) | |
293 | ((<module-ref> src mod name public?) | |
294 | ;; for the moment, we're disabling primitive resolution for | |
295 | ;; public refs because resolve-interface can raise errors. | |
296 | (and=> (and=> (resolve-module mod) | |
297 | (if public? | |
298 | module-public-interface | |
299 | identity)) | |
300 | (lambda (m) | |
301 | (and=> (hashq-ref *interesting-primitive-vars* | |
302 | (module-variable m name)) | |
303 | (lambda (name) | |
304 | (make-primitive-ref src name)))))) | |
305 | ((<call> src proc args) | |
306 | (and (primitive-ref? proc) | |
307 | (make-primcall src (primitive-ref-name proc) args))) | |
308 | (else #f)) | |
309 | x)) | |
55ae815b AW |
310 | x)) |
311 | ||
312 | \f | |
cb28c085 AW |
313 | |
314 | (define *primitive-expand-table* (make-hash-table)) | |
315 | ||
25450a0d AW |
316 | (define (expand-primitives x) |
317 | (pre-order | |
cb28c085 AW |
318 | (lambda (x) |
319 | (record-case x | |
a881a4ae AW |
320 | ((<primcall> src name args) |
321 | (let ((expand (hashq-ref *primitive-expand-table* name))) | |
25450a0d AW |
322 | (or (and expand (apply expand src args)) |
323 | x))) | |
324 | (else x))) | |
cb28c085 AW |
325 | x)) |
326 | ||
327 | ;;; I actually did spend about 10 minutes trying to redo this with | |
328 | ;;; syntax-rules. Patches appreciated. | |
329 | ;;; | |
330 | (define-macro (define-primitive-expander sym . clauses) | |
331 | (define (inline-args args) | |
332 | (let lp ((in args) (out '())) | |
333 | (cond ((null? in) `(list ,@(reverse out))) | |
334 | ((symbol? in) `(cons* ,@(reverse out) ,in)) | |
335 | ((pair? (car in)) | |
336 | (lp (cdr in) | |
9b2a2a39 AW |
337 | (cons (if (eq? (caar in) 'quote) |
338 | `(make-const src ,@(cdar in)) | |
a881a4ae AW |
339 | `(make-primcall src ',(caar in) |
340 | ,(inline-args (cdar in)))) | |
cb28c085 AW |
341 | out))) |
342 | ((symbol? (car in)) | |
343 | ;; assume it's locally bound | |
344 | (lp (cdr in) (cons (car in) out))) | |
9b2a2a39 | 345 | ((self-evaluating? (car in)) |
cb28c085 AW |
346 | (lp (cdr in) (cons `(make-const src ,(car in)) out))) |
347 | (else | |
348 | (error "what what" (car in)))))) | |
349 | (define (consequent exp) | |
350 | (cond | |
351 | ((pair? exp) | |
7382f23e AW |
352 | (pmatch exp |
353 | ((if ,test ,then ,else) | |
354 | `(if ,test | |
355 | ,(consequent then) | |
356 | ,(consequent else))) | |
357 | (else | |
a881a4ae AW |
358 | `(make-primcall src ',(car exp) |
359 | ,(inline-args (cdr exp)))))) | |
cb28c085 AW |
360 | ((symbol? exp) |
361 | ;; assume locally bound | |
362 | exp) | |
363 | ((number? exp) | |
364 | `(make-const src ,exp)) | |
9a974fd3 AW |
365 | ((not exp) |
366 | ;; failed match | |
367 | #f) | |
cb28c085 AW |
368 | (else (error "bad consequent yall" exp)))) |
369 | `(hashq-set! *primitive-expand-table* | |
370 | ',sym | |
71673fba | 371 | (match-lambda* |
cb28c085 AW |
372 | ,@(let lp ((in clauses) (out '())) |
373 | (if (null? in) | |
71673fba | 374 | (reverse (cons '(_ #f) out)) |
cb28c085 AW |
375 | (lp (cddr in) |
376 | (cons `((src . ,(car in)) | |
71673fba MW |
377 | ,(consequent (cadr in))) |
378 | out))))))) | |
cb28c085 | 379 | |
9b29d607 AW |
380 | (define-primitive-expander zero? (x) |
381 | (= x 0)) | |
382 | ||
ca5e0414 MW |
383 | (define-primitive-expander positive? (x) |
384 | (> x 0)) | |
385 | ||
386 | (define-primitive-expander negative? (x) | |
387 | (< x 0)) | |
388 | ||
11671bba LC |
389 | ;; FIXME: All the code that uses `const?' is redundant with `peval'. |
390 | ||
cb28c085 AW |
391 | (define-primitive-expander + |
392 | () 0 | |
b88fef55 | 393 | (x) (values x) |
71673fba | 394 | (x y) (if (and (const? y) (eqv? (const-exp y) 1)) |
7382f23e | 395 | (1+ x) |
71673fba | 396 | (if (and (const? y) (eqv? (const-exp y) -1)) |
8753fd53 | 397 | (1- x) |
71673fba | 398 | (if (and (const? x) (eqv? (const-exp x) 1)) |
8753fd53 | 399 | (1+ y) |
71673fba MW |
400 | (if (and (const? x) (eqv? (const-exp x) -1)) |
401 | (1- y) | |
402 | (+ x y))))) | |
403 | (x y z ... last) (+ (+ x y . z) last)) | |
404 | ||
cb28c085 AW |
405 | (define-primitive-expander * |
406 | () 1 | |
b88fef55 | 407 | (x) (values x) |
71673fba | 408 | (x y z ... last) (* (* x y . z) last)) |
cb28c085 AW |
409 | |
410 | (define-primitive-expander - | |
411 | (x) (- 0 x) | |
71673fba | 412 | (x y) (if (and (const? y) (eqv? (const-exp y) 1)) |
7382f23e AW |
413 | (1- x) |
414 | (- x y)) | |
71673fba | 415 | (x y z ... last) (- (- x y . z) last)) |
cb28c085 | 416 | |
cb28c085 AW |
417 | (define-primitive-expander / |
418 | (x) (/ 1 x) | |
71673fba | 419 | (x y z ... last) (/ (/ x y . z) last)) |
cb28c085 | 420 | |
b3f25e62 AW |
421 | (define-primitive-expander logior |
422 | () 0 | |
423 | (x) (logior x 0) | |
424 | (x y) (logior x y) | |
71673fba | 425 | (x y z ... last) (logior (logior x y . z) last)) |
b3f25e62 AW |
426 | |
427 | (define-primitive-expander logand | |
428 | () -1 | |
429 | (x) (logand x -1) | |
430 | (x y) (logand x y) | |
71673fba | 431 | (x y z ... last) (logand (logand x y . z) last)) |
b3f25e62 | 432 | |
cb28c085 AW |
433 | (define-primitive-expander caar (x) (car (car x))) |
434 | (define-primitive-expander cadr (x) (car (cdr x))) | |
435 | (define-primitive-expander cdar (x) (cdr (car x))) | |
436 | (define-primitive-expander cddr (x) (cdr (cdr x))) | |
437 | (define-primitive-expander caaar (x) (car (car (car x)))) | |
438 | (define-primitive-expander caadr (x) (car (car (cdr x)))) | |
439 | (define-primitive-expander cadar (x) (car (cdr (car x)))) | |
440 | (define-primitive-expander caddr (x) (car (cdr (cdr x)))) | |
441 | (define-primitive-expander cdaar (x) (cdr (car (car x)))) | |
442 | (define-primitive-expander cdadr (x) (cdr (car (cdr x)))) | |
443 | (define-primitive-expander cddar (x) (cdr (cdr (car x)))) | |
444 | (define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) | |
445 | (define-primitive-expander caaaar (x) (car (car (car (car x))))) | |
446 | (define-primitive-expander caaadr (x) (car (car (car (cdr x))))) | |
447 | (define-primitive-expander caadar (x) (car (car (cdr (car x))))) | |
448 | (define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) | |
449 | (define-primitive-expander cadaar (x) (car (cdr (car (car x))))) | |
450 | (define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) | |
451 | (define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) | |
452 | (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) | |
453 | (define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) | |
454 | (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) | |
455 | (define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) | |
456 | (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) | |
457 | (define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) | |
458 | (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) | |
459 | (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) | |
460 | (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) | |
461 | ||
462 | (define-primitive-expander cons* | |
b88fef55 | 463 | (x) (values x) |
cb28c085 AW |
464 | (x y) (cons x y) |
465 | (x y . rest) (cons x (cons* y . rest))) | |
466 | ||
dce042f1 AW |
467 | (define-primitive-expander acons (x y z) |
468 | (cons (cons x y) z)) | |
469 | ||
0f423f20 | 470 | (define-primitive-expander call/cc (proc) |
bc056057 | 471 | (call-with-current-continuation proc)) |
0f423f20 | 472 | |
9a974fd3 AW |
473 | (define-primitive-expander make-struct (vtable tail-size . args) |
474 | (if (and (const? tail-size) | |
475 | (let ((n (const-exp tail-size))) | |
476 | (and (number? n) (exact? n) (zero? n)))) | |
477 | (make-struct/no-tail vtable . args) | |
478 | #f)) | |
479 | ||
6c498233 AW |
480 | (define-primitive-expander u8vector-ref (vec i) |
481 | (bytevector-u8-ref vec i)) | |
482 | (define-primitive-expander u8vector-set! (vec i x) | |
483 | (bytevector-u8-set! vec i x)) | |
484 | (define-primitive-expander s8vector-ref (vec i) | |
485 | (bytevector-s8-ref vec i)) | |
486 | (define-primitive-expander s8vector-set! (vec i x) | |
487 | (bytevector-s8-set! vec i x)) | |
488 | ||
489 | (define-primitive-expander u16vector-ref (vec i) | |
490 | (bytevector-u16-native-ref vec (* i 2))) | |
491 | (define-primitive-expander u16vector-set! (vec i x) | |
492 | (bytevector-u16-native-set! vec (* i 2) x)) | |
493 | (define-primitive-expander s16vector-ref (vec i) | |
494 | (bytevector-s16-native-ref vec (* i 2))) | |
495 | (define-primitive-expander s16vector-set! (vec i x) | |
496 | (bytevector-s16-native-set! vec (* i 2) x)) | |
497 | ||
498 | (define-primitive-expander u32vector-ref (vec i) | |
499 | (bytevector-u32-native-ref vec (* i 4))) | |
500 | (define-primitive-expander u32vector-set! (vec i x) | |
501 | (bytevector-u32-native-set! vec (* i 4) x)) | |
502 | (define-primitive-expander s32vector-ref (vec i) | |
503 | (bytevector-s32-native-ref vec (* i 4))) | |
504 | (define-primitive-expander s32vector-set! (vec i x) | |
505 | (bytevector-s32-native-set! vec (* i 4) x)) | |
506 | ||
507 | (define-primitive-expander u64vector-ref (vec i) | |
508 | (bytevector-u64-native-ref vec (* i 8))) | |
509 | (define-primitive-expander u64vector-set! (vec i x) | |
510 | (bytevector-u64-native-set! vec (* i 8) x)) | |
511 | (define-primitive-expander s64vector-ref (vec i) | |
512 | (bytevector-s64-native-ref vec (* i 8))) | |
513 | (define-primitive-expander s64vector-set! (vec i x) | |
514 | (bytevector-s64-native-set! vec (* i 8) x)) | |
515 | ||
516 | (define-primitive-expander f32vector-ref (vec i) | |
517 | (bytevector-ieee-single-native-ref vec (* i 4))) | |
518 | (define-primitive-expander f32vector-set! (vec i x) | |
519 | (bytevector-ieee-single-native-set! vec (* i 4) x)) | |
520 | (define-primitive-expander f32vector-ref (vec i) | |
521 | (bytevector-ieee-single-native-ref vec (* i 4))) | |
522 | (define-primitive-expander f32vector-set! (vec i x) | |
523 | (bytevector-ieee-single-native-set! vec (* i 4) x)) | |
524 | ||
525 | (define-primitive-expander f64vector-ref (vec i) | |
526 | (bytevector-ieee-double-native-ref vec (* i 8))) | |
527 | (define-primitive-expander f64vector-set! (vec i x) | |
528 | (bytevector-ieee-double-native-set! vec (* i 8) x)) | |
529 | (define-primitive-expander f64vector-ref (vec i) | |
530 | (bytevector-ieee-double-native-ref vec (* i 8))) | |
531 | (define-primitive-expander f64vector-set! (vec i x) | |
532 | (bytevector-ieee-double-native-set! vec (* i 8) x)) | |
1bf78495 | 533 | |
58147d67 MW |
534 | (define (chained-comparison-expander prim-name) |
535 | (case-lambda | |
536 | ((src) (make-const src #t)) | |
537 | ((src a) #f) | |
538 | ((src a b) #f) | |
539 | ((src a b . rest) | |
04f59ec2 | 540 | (let* ((b-sym (gensym "b")) |
58147d67 MW |
541 | (b* (make-lexical-ref src 'b b-sym))) |
542 | (make-let src | |
543 | '(b) | |
544 | (list b-sym) | |
545 | (list b) | |
546 | (make-conditional src | |
04f59ec2 AW |
547 | (make-primcall src prim-name (list a b*)) |
548 | (make-primcall src prim-name (cons b* rest)) | |
58147d67 MW |
549 | (make-const src #f))))))) |
550 | ||
551 | (for-each (lambda (prim-name) | |
552 | (hashq-set! *primitive-expand-table* prim-name | |
553 | (chained-comparison-expander prim-name))) | |
554 | '(< > <= >= =)) | |
555 | ||
75a5de18 | 556 | ;; Appropriate for use with either 'eqv?' or 'equal?'. |
62d3430c | 557 | (define (maybe-simplify-to-eq prim) |
75a5de18 | 558 | (case-lambda |
62d3430c MW |
559 | ((src) (make-const src #t)) |
560 | ((src a) (make-const src #t)) | |
75a5de18 MW |
561 | ((src a b) |
562 | ;; Simplify cases where either A or B is constant. | |
563 | (define (maybe-simplify a b) | |
564 | (and (const? a) | |
565 | (let ((v (const-exp a))) | |
566 | (and (or (memq v '(#f #t () #nil)) | |
567 | (symbol? v) | |
568 | (and (integer? v) | |
569 | (exact? v) | |
fa980bcc MW |
570 | (<= v most-positive-fixnum) |
571 | (>= v most-negative-fixnum))) | |
572 | (make-primcall src 'eq? (list a b)))))) | |
75a5de18 | 573 | (or (maybe-simplify a b) (maybe-simplify b a))) |
62d3430c MW |
574 | ((src a b . rest) |
575 | (make-conditional src (make-primcall src prim (list a b)) | |
576 | (make-primcall src prim (cons b rest)) | |
577 | (make-const src #f))) | |
75a5de18 MW |
578 | (else #f))) |
579 | ||
62d3430c MW |
580 | (hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?)) |
581 | (hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?)) | |
582 | ||
583 | (define (expand-chained-comparisons prim) | |
584 | (case-lambda | |
585 | ((src) (make-const src #t)) | |
586 | ((src a) (make-const src #t)) | |
587 | ((src a b) #f) | |
588 | ((src a b . rest) | |
589 | (make-conditional src (make-primcall src prim (list a b)) | |
590 | (make-primcall src prim (cons b rest)) | |
591 | (make-const src #f))) | |
592 | (else #f))) | |
593 | ||
594 | (for-each (lambda (prim) | |
595 | (hashq-set! *primitive-expand-table* prim | |
596 | (expand-chained-comparisons prim))) | |
597 | '(< <= = >= > eq?)) | |
2446f8e1 | 598 | |
9b2a2a39 | 599 | (hashq-set! *primitive-expand-table* |
8fc43b12 | 600 | 'call-with-prompt |
9b2a2a39 | 601 | (case-lambda |
f828ab4f | 602 | ((src tag thunk handler) |
178a4092 | 603 | (make-prompt src #f tag thunk handler)) |
9b2a2a39 | 604 | (else #f))) |
f828ab4f | 605 | |
2d026f04 | 606 | (hashq-set! *primitive-expand-table* |
38504994 | 607 | 'abort-to-prompt* |
2d026f04 AW |
608 | (case-lambda |
609 | ((src tag tail-args) | |
610 | (make-abort src tag '() tail-args)) | |
611 | (else #f))) | |
9b2a2a39 | 612 | (hashq-set! *primitive-expand-table* |
8fc43b12 | 613 | 'abort-to-prompt |
9b2a2a39 | 614 | (case-lambda |
6e84cb95 | 615 | ((src tag . args) |
2d026f04 | 616 | (make-abort src tag args (make-const #f '()))) |
9b2a2a39 | 617 | (else #f))) |