Context Navigation

source: project/chicken/branches/hygienic/chicken-more-macros.scm @ 10788

Last change on this file since 10788 was 10788, checked in by felix winkelmann, 13 years ago
added remaining import libraries csi uses srfi-69 now to avoid bootstrapping problem csi: renamed "-se" to "-sx" global assigns get variable name in comment in generated C code import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy) removed a lot of deprecated stuff it really seems to work...
File size: 32.8 KB

Line
1	;;;; chicken-more-macros.scm - More syntax extensions
2	;
3	; Copyright (c) 2000-2007, Felix L. Winkelmann
4	; Copyright (c) 2008, The Chicken Team
5	; All rights reserved.
6	;
7	; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8	; conditions are met:
9	;
10	; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11	; disclaimer.
12	; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13	; disclaimer in the documentation and/or other materials provided with the distribution.
14	; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15	; products derived from this software without specific prior written permission.
16	;
17	; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18	; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19	; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20	; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21	; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22	; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23	; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24	; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25	; POSSIBILITY OF SUCH DAMAGE.
26
27
28	(##sys#provide 'chicken-more-macros)
29
30
31	;;; Non-standard macros:
32
33	(define ##sys#chicken-macro-environment
34	(let ((me0 (##sys#macro-environment)))
35
36	(##sys#extend-macro-environment
37	'receive
38	'()
39	(##sys#er-transformer
40	(lambda (form r c)
41	(let ((%lambda (r 'lambda))
42	(%let (r 'let)))
43	(##sys#check-syntax 'receive form '(_ _ . #(_ 0)))
44	(cond ((null? (cddr form))
45	`(##sys#call-with-values (,%lambda () ,@(cdr form)) ##sys#list) )
46	(else
47	(##sys#check-syntax 'receive form '(_ lambda-list _ . #(_ 1)))
48	(let ((vars (cadr form))
49	(exp (caddr form))
50	(rest (cdddr form)))
51	(if (and (pair? vars) (null? (cdr vars)))
52	`(,%let ((,(car vars) ,exp)) ,@rest)
53	`(##sys#call-with-values
54	(,%lambda () ,exp)
55	(,%lambda ,vars ,@rest)) ) ) ) ) ))))
56
57	(##sys#extend-macro-environment
58	'time '()
59	(##sys#er-transformer
60	(lambda (form r c)
61	(let ((rvar (r 't))
62	(%begin (r 'begin))
63	(%lambda (r 'lambda)))
64	`(,%begin
65	(##sys#start-timer)
66	(##sys#call-with-values
67	(,%lambda () ,@(cdr form))
68	(,%lambda ,rvar
69	(##sys#display-times (##sys#stop-timer))
70	(##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
71
72	(##sys#extend-macro-environment
73	'declare '()
74	(##sys#er-transformer
75	(lambda (form r c)
76	`(##core#declare ,@(cdr form)))))
77
78	(##sys#extend-macro-environment
79	'include '()
80	(##sys#er-transformer
81	(lambda (form r c)
82	(##sys#check-syntax 'include form '(_ string))
83	(let ((path (##sys#resolve-include-filename (cadr form) #t))
84	(%begin (r 'begin)))
85	(when (load-verbose) (print "; including " path " ..."))
86	`(,%begin
87	,@(with-input-from-file path
88	(lambda ()
89	(fluid-let ((##sys#current-source-filename path))
90	(do ([x (read) (read)]
91	[xs '() (cons x xs)] )
92	((eof-object? x)
93	(reverse xs))) ) ) ) ) ) ) ) )
94
95	(##sys#extend-macro-environment
96	'assert '()
97	(##sys#er-transformer
98	(lambda (form r c)
99	(##sys#check-syntax 'assert form '#(_ 1))
100	(let* ((exp (cadr form))
101	(msg-and-args (cddr form))
102	(%if (r 'if))
103	(%quote (r 'quote))
104	(msg (if (eq? '() msg-and-args)
105	`(##core#immutable '"assertion failed")
106	(car msg-and-args) ) ) )
107	`(,%if (##core#check ,exp)
108	(##core#undefined)
109	(##sys#error
110	,msg
111	(,%quote ,exp)
112	,@(if (fx> (length msg-and-args) 1)
113	(cdr msg-and-args)
114	'() ) ) ) ) )) )
115
116	(##sys#extend-macro-environment
117	'ensure
118	'()
119	(##sys#er-transformer
120	(lambda (form r c)
121	(##sys#check-syntax 'ensure form '#(_ 3))
122	(let ((pred (cadr form))
123	(exp (caddr form))
124	(args (cdddr form))
125	(tmp (r 'tmp))
126	(%let (r 'let))
127	(%if (r 'if)) )
128	`(,%let ([,tmp ,exp])
129	(,%if (##core#check (,pred ,tmp))
130	,tmp
131	(##sys#signal-hook
132	#:type-error
133	,@(if (pair? args)
134	args
135	`((##core#immutable '"argument has incorrect type")
136	,tmp ',pred) ) ) ) ) ) ) ) )
137
138	(##sys#extend-macro-environment
139	'fluid-let '()
140	(##sys#er-transformer
141	(lambda (form r c)
142	(##sys#check-syntax 'fluid-let form '(_ #((symbol _) 0) . _))
143	(let* ((clauses (cadr form))
144	(body (cddr form))
145	(ids (##sys#map car clauses))
146	(new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
147	(old-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
148	(%let (r 'let))
149	(%lambda (r 'lambda)))
150	`(,%let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
151	,@(map ##sys#list old-tmps
152	(let loop ((n (length clauses)))
153	(if (eq? n 0)
154	'()
155	(cons #f (loop (fx- n 1))) ) ) ) )
156	(##sys#dynamic-wind
157	(,%lambda ()
158	,@(map (lambda (ot id) `(##core#set! ,ot ,id))
159	old-tmps ids)
160	,@(map (lambda (id nt) `(##core#set! ,id ,nt))
161	ids new-tmps)
162	(##core#undefined) )
163	(,%lambda () ,@body)
164	(,%lambda ()
165	,@(map (lambda (nt id) `(##core#set! ,nt ,id))
166	new-tmps ids)
167	,@(map (lambda (id ot) `(##core#set! ,id ,ot))
168	ids old-tmps)
169	(##core#undefined) ) ) ) ) )))
170
171	(##sys#extend-macro-environment
172	'eval-when '()
173	(##sys#er-transformer
174	(lambda (form r c)
175	(##sys#check-syntax 'eval-when form '#(_ 2))
176	(let* ((situations (cadr form))
177	(%begin (r 'begin))
178	(body `(,%begin ,@(cddr form)))
179	(%eval (r 'eval))
180	(%compile (r 'compile))
181	(%load (r 'load))
182	(e #f)
183	(co #f)
184	(l #f))
185	(let loop ([ss situations])
186	(if (pair? ss)
187	(let ((s (car ss)))
188	(cond ((c s %eval) (set! e #t))
189	((c s %load) (set! l #t))
190	((c s %compile) (set! co #t))
191	(else (##sys#error "invalid situation specifier" (car ss)) ))
192	(loop (##sys#slot ss 1)) ) ) )
193	(if (memq '#:compiling ##sys#features)
194	(cond [(and co l) `(##core#compiletimetoo ,body)]
195	[co `(##core#compiletimeonly ,body)]
196	[l body]
197	[else '(##core#undefined)] )
198	(if e
199	body
200	'(##core#undefined) ) ) ) ) ) )
201
202	(##sys#extend-macro-environment
203	'parameterize '()
204	(##sys#er-transformer
205	(lambda (form r c)
206	(##sys#check-syntax 'parameterize form '#(_ 2))
207	(let* ((bindings (cadr form))
208	(body (cddr form))
209	(swap (r 'swap))
210	(%let (r 'let))
211	(%lambda (r 'lambda))
212	[params (##sys#map car bindings)]
213	[vals (##sys#map cadr bindings)]
214	[aliases (##sys#map (lambda (z) (r (gensym))) params)]
215	[aliases2 (##sys#map (lambda (z) (r (gensym))) params)] )
216	`(,%let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
217	(,%let ((,swap (,%lambda ()
218	,@(map (lambda (a a2)
219	`(,%let ((t (,a))) (,a ,a2)
220	(##core#set! ,a2 t)))
221	aliases aliases2) ) ) )
222	(##sys#dynamic-wind
223	,swap
224	(,%lambda () ,@body)
225	,swap) ) ) ) )))
226
227	(##sys#extend-macro-environment
228	'when '()
229	(##sys#er-transformer
230	(lambda (form r c)
231	(##sys#check-syntax 'when form '#(_ 2))
232	`(,(r 'if) ,(cadr form)
233	(,(r 'begin) ,@(cddr form))))))
234
235	(##sys#extend-macro-environment
236	'unless '()
237	(##sys#er-transformer
238	(lambda (form r c)
239	(##sys#check-syntax 'unless form '#(_ 2))
240	`(,(r 'if) ,(cadr form)
241	(##core#undefined)
242	(,(r 'begin) ,@(cddr form))))))
243
244	(##sys#extend-macro-environment
245	'set!-values '()
246	(##sys#er-transformer
247	(lambda (form r c)
248	(##sys#check-syntax 'set!-values form '(_ #(variable 0) _))
249	(let ((vars (cadr form))
250	(exp (caddr form))
251	(%lambda (r 'lambda)))
252	(cond ((null? vars)
253	;; may this be simply "exp"?
254	`(##sys#call-with-values
255	(,%lambda () ,exp)
256	(,%lambda () (##core#undefined))) )
257	((null? (cdr vars))
258	`(##core#set! ,(car vars) ,exp))
259	(else
260	(let ([aliases (map gensym vars)])
261	`(##sys#call-with-values
262	(,%lambda () ,exp)
263	(,%lambda ,aliases
264	,@(map (lambda (v a)
265	`(##core#set! ,v ,a))
266	vars aliases) ) ) ) ) ) ))))
267
268	(##sys#extend-macro-environment
269	'define-values '()
270	(##sys#er-transformer
271	(lambda (form r c)
272	(##sys#check-syntax 'define-values form '(_ #(variable 0) _))
273	(for-each (cut ##sys#register-export <> (##sys#current-module)) (cadr form))
274	`(,(r 'set!-values) ,@(cdr form)))))
275
276	(##sys#extend-macro-environment
277	'let-values '()
278	(##sys#er-transformer
279	(lambda (form r c)
280	(##sys#check-syntax 'let-values form '(_ list . _))
281	(let ((vbindings (cadr form))
282	(body (cddr form))
283	(%let (r 'let))
284	(%lambda (r 'lambda)))
285	(letrec ((append* (lambda (il l)
286	(if (not (pair? il))
287	(cons il l)
288	(cons (car il)
289	(append* (cdr il) l)))))
290	(map* (lambda (proc l)
291	(cond ((null? l) '())
292	((not (pair? l)) (proc l))
293	(else (cons (proc (car l)) (map* proc (cdr l))))))))
294	(let* ([llists (map car vbindings)]
295	[vars (let loop ((llists llists) (acc '()))
296	(if (null? llists)
297	acc
298	(let* ((llist (car llists))
299	(new-acc
300	(cond ((list? llist) (append llist acc))
301	((pair? llist) (append* llist acc))
302	(else (cons llist acc)))))
303	(loop (cdr llists) new-acc))))]
304	[aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
305	[lookup (lambda (v) (cdr (assq v aliases)))]
306	[llists2 (let loop ((llists llists) (acc '()))
307	(if (null? llists)
308	(reverse acc)
309	(let* ((llist (car llists))
310	(new-acc
311	(cond ((not (pair? llist)) (cons (lookup llist) acc))
312	(else (cons (map* lookup llist) acc)))))
313	(loop (cdr llists) new-acc))))])
314	(let fold ([llists llists]
315	[exps (map (lambda (x) (cadr x)) vbindings)]
316	[llists2 llists2] )
317	(cond ((null? llists)
318	`(,%let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
319	((and (pair? (car llists2)) (null? (cdar llists2)))
320	`(,%let ((,(caar llists2) ,(car exps)))
321	,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
322	(else
323	`(##sys#call-with-values
324	(,%lambda () ,(car exps))
325	(,%lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
326
327	(##sys#extend-macro-environment
328	'let*-values '()
329	(##sys#er-transformer
330	(lambda (form r c)
331	(##sys#check-syntax 'let*-values form '(_ list . _))
332	(let ((vbindings (cadr form))
333	(body (cddr form))
334	(%let (r 'let))
335	(%let-values (r 'let-values)) )
336	(let fold ([vbindings vbindings])
337	(if (null? vbindings)
338	`(,%let () ,@body)
339	`(,%let-values (,(car vbindings))
340	,(fold (cdr vbindings))) ) ) ))))
341
342	(##sys#extend-macro-environment
343	'letrec-values '()
344	(##sys#er-transformer
345	(lambda (form r c)
346	(##sys#check-syntax 'letrec-values form '(_ list . _))
347	(let ((vbindings (cadr form))
348	(body (cddr form))
349	(%let (r 'let))
350	(%lambda (r 'lambda)))
351	(let* ([vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))]
352	[aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
353	[lookup (lambda (v) (cdr (assq v aliases)))] )
354	`(,%let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
355	,@(map (lambda (vb)
356	`(##sys#call-with-values
357	(,%lambda () ,(cadr vb))
358	(,%lambda ,(map lookup (car vb))
359	,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
360	vbindings)
361	,@body) ) ) ) ) )
362
363	(##sys#extend-macro-environment
364	'nth-value '()
365	(##sys#er-transformer
366	(lambda (form r c)
367	(##sys#check-syntax 'nth-value form '(_ _ _))
368	(let ((v (r 'tmp))
369	(%list-ref (r 'list-ref))
370	(%lambda (r 'lambda)))
371	`(##sys#call-with-values
372	(,%lambda () ,(caddr form))
373	(,%lambda ,v (,%list-ref ,v ,(cadr form))))))))
374
375	(##sys#extend-macro-environment
376	'define-inline '()
377	(##sys#er-transformer
378	(lambda (form r c)
379	(let ((%lambda (r 'lambda)))
380	(letrec ([quotify-proc
381	(lambda (xs id)
382	(##sys#check-syntax id xs '#(_ 1))
383	(let* ([head (car xs)]
384	[name (if (pair? head) (car head) head)]
385	[val (if (pair? head)
386	`(,%lambda ,(cdr head) ,@(cdr xs))
387	(cadr xs) ) ] )
388	(when (or (not (pair? val)) (not (c %lambda (car val))))
389	(syntax-error
390	'define-inline "invalid substitution form - must be lambda"
391	name) )
392	(list name val) ) ) ] )
393	`(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) ) )
394
395	(##sys#extend-macro-environment
396	'and-let* '()
397	(##sys#er-transformer
398	(lambda (form r c)
399	(##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
400	(let ((bindings (cadr form))
401	(body (cddr form))
402	(%if (r 'if))
403	(%let (r 'let)))
404	(let fold ([bs bindings])
405	(if (null? bs)
406	`(,(r 'begin) ,@body)
407	(let ([b (car bs)]
408	[bs2 (cdr bs)] )
409	(cond [(not (pair? b)) `(,%if ,b ,(fold bs2) #f)]
410	[(null? (cdr b)) `(,%if ,(car b) ,(fold bs2) #f)]
411	[else
412	(let ((var (car b)))
413	`(,%let ((,var ,(cadr b)))
414	(,%if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
415
416	(##sys#extend-macro-environment
417	'select '()
418	(##sys#er-transformer
419	(lambda (form r c)
420	(##sys#check-syntax 'select form '(_ _ . _))
421	(let ((exp (cadr form))
422	(body (cddr form))
423	(tmp (r 'tmp))
424	(%if (r 'if))
425	(%else (r 'else))
426	(%or (r 'or))
427	(%eqv? (r 'eqv?))
428	(%begin (r 'begin)))
429	`(,(r 'let) ((,tmp ,exp))
430	,(let expand ((clauses body))
431	(if (not (pair? clauses))
432	'(##core#undefined)
433	(let ((clause (##sys#slot clauses 0))
434	(rclauses (##sys#slot clauses 1)) )
435	(##sys#check-syntax 'select clause '#(_ 1))
436	(if (c %else (car clause))
437	`(,%begin ,@(cdr clause))
438	`(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x))
439	(car clause) ) )
440	(,%begin ,@(cdr clause))
441	,(expand rclauses) ) ) ) ) ) ) ) ) ) )
442
443
444	;;; Optional argument handling:
445
446	;;; Copyright (C) 1996 by Olin Shivers.
447	;;;
448	;;; This file defines three macros for parsing optional arguments to procs:
449	;;; (LET-OPTIONALS arg-list ((var1 default1) ...) . body)
450	;;; (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
451	;;; (:OPTIONAL rest-arg default-exp)
452	;;;
453	;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
454	;;; explicit-renaming low-level macro system. You'll have to do some work to
455	;;; port it to another macro system.
456	;;;
457	;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
458	;;; high-level macros, and should be portable to any R4RS system.
459	;;;
460	;;; These macros are all careful to evaluate their default forms only if
461	;;; their values are needed.
462	;;;
463	;;; The only non-R4RS dependencies in the macros are ERROR
464	;;; and CALL-WITH-VALUES.
465	;;; -Olin
466
467	;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
468	;;; body
469	;;; ...)
470	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471	;;; This form is for binding a procedure's optional arguments to either
472	;;; the passed-in values or a default.
473	;;;
474	;;; The expression takes a rest list ARG-LIST and binds the VARi to
475	;;; the elements of the rest list. When there are no more elements, then
476	;;; the remaining VARi are bound to their corresponding DEFAULTi values.
477	;;; It is an error if there are more args than variables.
478	;;;
479	;;; - The default expressions are not evaluated unless needed.
480	;;;
481	;;; - When evaluated, the default expressions are carried out in the outer
482	;;; environment. That is, the DEFAULTi forms do not see any of the VARi
483	;;; bindings.
484	;;;
485	;;; I originally wanted to have the DEFAULTi forms get eval'd in a LET*
486	;;; style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
487	;;; impossible to implement without side effects or redundant conditional
488	;;; tests. If I drop this requirement, I can use the efficient expansion
489	;;; shown below. If you need LET* scope, use the less-efficient
490	;;; LET-OPTIONALS* form defined below.
491	;;;
492	;;; Example:
493	;;; (define (read-string! str . maybe-args)
494	;;; (let-optionals maybe-args ((port (current-input-port))
495	;;; (start 0)
496	;;; (end (string-length str)))
497	;;; ...))
498	;;;
499	;;; expands to:
500	;;;
501	;;; (let* ((body (lambda (port start end) ...))
502	;;; (end-def (lambda (%port %start) (body %port %start <end-default>)))
503	;;; (start-def (lambda (%port) (end-def %port <start-default>)))
504	;;; (port-def (lambda () (start-def <port-def>))))
505	;;; (if (null? rest) (port-def)
506	;;; (let ((%port (car rest))
507	;;; (rest (cdr rest)))
508	;;; (if (null? rest) (start-def %port)
509	;;; (let ((%start (car rest))
510	;;; (rest (cdr rest)))
511	;;; (if (null? rest) (end-def %port %start)
512	;;; (let ((%end (car rest))
513	;;; (rest (cdr rest)))
514	;;; (if (null? rest) (body %port %start %end)
515	;;; (error ...)))))))))
516
517
518	;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
519
520	(##sys#extend-macro-environment
521	'let-optionals '()
522	(##sys#er-transformer
523	(lambda (form r c)
524	(##sys#check-syntax 'let-optionals form '(_ _ . _))
525	(let ((arg-list (cadr form))
526	(var/defs (caddr form))
527	(body (cdddr form))
528	(%null? (r 'null?))
529	(%if (r 'if))
530	(%let (r 'let))
531	(%car (r 'car))
532	(%cdr (r 'cdr))
533	(%lambda (r 'lambda)))
534
535	;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
536	;; I wish I had a reasonable loop macro.
537
538	(define (make-default-procs vars body-proc defaulter-names defs rename)
539	(let recur ((vars (reverse vars))
540	(defaulter-names (reverse defaulter-names))
541	(defs (reverse defs))
542	(next-guy body-proc))
543	(if (null? vars) '()
544	(let ((vars (cdr vars)))
545	`((,(car defaulter-names)
546	(,%lambda ,(reverse vars)
547	(,next-guy ,@(reverse vars) ,(car defs))))
548	. ,(recur vars
549	(cdr defaulter-names)
550	(cdr defs)
551	(car defaulter-names)))))))
552
553
554	;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
555
556	(define (make-if-tree vars defaulters body-proc rest rename)
557	(let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
558	(if (null? vars)
559	`(,%if (##core#check (,%null? ,rest))
560	(,body-proc . ,(reverse non-defaults))
561	(##sys#error (##core#immutable '"too many optional arguments") ,rest))
562	(let ((v (car vars)))
563	`(,%if (null? ,rest)
564	(,(car defaulters) . ,(reverse non-defaults))
565	(,%let ((,v (,%car ,rest))
566	(,rest (,%cdr ,rest)))
567	,(recur (cdr vars)
568	(cdr defaulters)
569	(cons v non-defaults))))))))
570
571	(##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
572	(##sys#check-syntax 'let-optionals body '#(_ 1))
573	(let* ((vars (map car var/defs))
574	(prefix-sym (lambda (prefix sym)
575	(string->symbol (string-append prefix (symbol->string sym)))))
576
577	;; Private vars, one for each user var.
578	;; We prefix the % to help keep macro-expanded code from being
579	;; too confusing.
580	(vars2 (map (lambda (v) (r (prefix-sym "%" v)))
581	vars))
582
583	(defs (map cadr var/defs))
584	(body-proc (r 'body))
585
586	;; A private var, bound to the value of the ARG-LIST expression.
587	(rest-var (r '%rest))
588
589	(defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
590	vars))
591
592	(defaulters (make-default-procs vars2 body-proc
593	defaulter-names defs gensym))
594	(if-tree (make-if-tree vars2 defaulter-names body-proc
595	rest-var gensym)))
596
597	`(,(r 'let*) ((,rest-var ,arg-list)
598	(,body-proc (,%lambda ,vars . ,body))
599	. ,defaulters)
600	,if-tree) ) ))))
601
602
603	;;; (optional rest-arg default-exp)
604	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
605	;;; This form is for evaluating optional arguments and their defaults
606	;;; in simple procedures that take a single optional argument. It is
607	;;; a macro so that the default will not be computed unless it is needed.
608	;;;
609	;;; REST-ARG is a rest list from a lambda -- e.g., R in
610	;;; (lambda (a b . r) ...)
611	;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
612	;;; - If REST-ARG has 1 element, return that element.
613	;;; - If REST-ARG has >1 element, error.
614
615	(##sys#extend-macro-environment
616	'optional '()
617	(##sys#er-transformer
618	(lambda (form r c)
619	(##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
620	(let ((var (r 'tmp))
621	(%null? (r 'null?))
622	(%if (r 'if)))
623	`(,(r 'let) ((,var ,(cadr form)))
624	(,%if (,%null? ,var)
625	,(optional (cddr form) #f)
626	(,%if (##core#check (,%null? (,(r 'cdr) ,var)))
627	(,(r 'car) ,var)
628	(##sys#error
629	(##core#immutable '"too many optional arguments")
630	,var))))))))
631
632
633	;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
634	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
635	;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
636	;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
637	;;; within the scope of VAR1 and VAR2, and so forth.
638	;;;
639	;;; - If the last form in the ((var1 default1) ...) list is not a
640	;;; (VARi DEFAULTi) pair, but a simple variable REST, then it is
641	;;; bound to any left-over values. For example, if we have VAR1 through
642	;;; VAR7, and ARGS has 9 values, then REST will be bound to the list of
643	;;; the two values of ARGS. If ARGS is too short, causing defaults to
644	;;; be used, then REST is bound to '().
645	;;; - If there is no REST variable, then it is an error to have excess
646	;;; values in the ARGS list.
647
648	(##sys#extend-macro-environment
649	'let-optionals* '()
650	(##sys#er-transformer
651	(lambda (form r c)
652	(##sys#check-syntax 'let-optionals* form '(_ _ list . _))
653	(let ((args (cadr form))
654	(var/defs (caddr form))
655	(body (cdddr form))
656	(%let (r 'let))
657	(%if (r 'if))
658	(%null? (r 'null?))
659	(%car (r 'car))
660	(%cdr (r 'cdr)))
661	(let ((rvar (r 'tmp)))
662	`(,%let ((,rvar ,args))
663	,(let loop ([args rvar] [vardefs var/defs])
664	(if (null? vardefs)
665	`(,%if (##core#check (,%null? ,args))
666	(,%let () ,@body)
667	(##sys#error
668	(##core#immutable '"too many optional arguments")
669	,args) )
670	(let ([head (car vardefs)])
671	(if (pair? head)
672	(let ((rvar2 (r 'tmp2)))
673	`(,%let ((,(car head) (,%if (,%null? ,args)
674	,(cadr head)
675	(,%car ,args)))
676	(,rvar2 (,%if (,%null? ,args)
677	'()
678	(,%cdr ,args))) )
679	,(loop rvar2 (cdr vardefs)) ) )
680	`(,%let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
681
682
683	;;; case-lambda (SRFI-16):
684
685	(##sys#extend-macro-environment
686	'case-lambda '()
687	(##sys#er-transformer
688	(lambda (form r c)
689	(##sys#check-syntax 'case-lambda form '(_ . _))
690	(define (genvars n)
691	(let loop ([i 0])
692	(if (fx>= i n)
693	'()
694	(cons (r (gensym)) (loop (fx+ i 1))) ) ) )
695	(require 'srfi-1) ; Urgh...
696	(let* ((mincount (apply min (map (lambda (c)
697	(##sys#decompose-lambda-list
698	(car c)
699	(lambda (vars argc rest) argc) ) )
700	(cdr form))))
701	(minvars (genvars mincount))
702	(rvar (r 'rvar))
703	(lvar (r 'lvar))
704	(%lambda (r 'lambda))
705	(%let (r 'let))
706	(%if (r 'if)))
707	`(,%lambda ,(append minvars rvar)
708	(,%let ((,lvar (length ,rvar)))
709	,(fold-right
710	(lambda (c body)
711	(##sys#decompose-lambda-list
712	(car c)
713	(lambda (vars argc rest)
714	(##sys#check-syntax 'case-lambda (car c) 'lambda-list)
715	`(,%if ,(let ([a2 (fx- argc mincount)])
716	(if rest
717	(if (zero? a2)
718	#t
719	`(,(r 'fx>=) ,lvar ,a2) )
720	`(,(r 'fx=) ,lvar ,a2) ) )
721	,(receive (vars1 vars2)
722	(split-at! (take vars argc) mincount)
723	(let ((bindings
724	(let build ((vars2 vars2) (vrest rvar))
725	(if (null? vars2)
726	(cond (rest `(,%let ((,rest ,vrest)) ,@(cdr c)))
727	((null? (cddr c)) (cadr c))
728	(else `(,%let () ,@(cdr c))) )
729	(let ((vrest2 (r (gensym))))
730	`(,%let ((,(car vars2) (,(r 'car) ,vrest))
731	(,vrest2 (,(r 'cdr) ,vrest)) )
732	,(if (pair? (cdr vars2))
733	(build (cdr vars2) vrest2)
734	(build '() vrest2) ) ) ) ) ) ) )
735	(if (null? vars1)
736	bindings
737	`(,%let ,(map list vars1 minvars) ,bindings) ) ) )
738	,body) ) ) )
739	'(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
740	(cdr form))))))))
741
742
743	;;; Record printing:
744
745	(##sys#extend-macro-environment
746	'define-record-printer '()
747	(##sys#er-transformer
748	(lambda (form r c)
749	(##sys#check-syntax 'define-record-printer form '(_ . _))
750	(cond [(pair? head)
751	(##sys#check-syntax
752	'define-record-printer (cons head body)
753	'((symbol symbol symbol) . #(_ 1)))
754	`(##sys#register-record-printer
755	',(##sys#slot head 0)
756	(,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
757	[else
758	(##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
759	`(##sys#register-record-printer ',head ,@body) ] ) )))
760
761
762	;;; Exceptions:
763
764	(##sys#extend-macro-environment
765	'handle-exceptions '()
766	(##sys#er-transformer
767	(lambda (form r c)
768	(##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
769	(let ((k (r 'k))
770	(args (r 'args))
771	(%lambda (r 'lambda)))
772	`((,(r 'call-with-current-continuation)
773	(,%lambda (,k)
774	(,(r 'with-exception-handler)
775	(,%lambda (,(cadr form)) (,k (,%lambda () ,(caddr form))))
776	(,%lambda ()
777	(##sys#call-with-values
778	(,%lambda () ,@(cdddr form))
779	(,%lambda
780	,args
781	(,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
782
783	(##sys#extend-macro-environment
784	'condition-case '()
785	(##sys#er-transformer
786	(lambda (form r c)
787	(##sys#check-syntax 'condition-case form '(_ _ . _))
788	(let ((exvar (r 'exvar))
789	(kvar (r 'kvar))
790	(%and (r 'and))
791	(%let (r 'let))
792	(%memv (r 'memv))
793	(%else (r 'else)))
794	(define (parse-clause c)
795	(let* ([var (and (symbol? (car c)) (car c))]
796	[kinds (if var (cadr c) (car c))]
797	[body (if var (cddr c) (cdr c))] )
798	(if (null? kinds)
799	`(,%else
800	,(if var
801	`(,%let ([,var ,exvar]) ,@body)
802	`(,%let () ,@body) ) )
803	`((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
804	,(if var
805	`(,%let ([,var ,exvar]) ,@body)
806	`(,%let () ,@body) ) ) ) ) )
807	`(,(r 'handle-exceptions) ,exvar
808	(,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition)
809	(##sys#slot ,exvar 1))])
810	(,(r 'cond) ,@(map parse-clause (cddr form))
811	(,%else (##sys#signal ,exvar)) ) )
812	,(cadr form))))))
813
814
815	;;; SRFI-9:
816
817	(##sys#extend-macro-environment
818	'define-record-type '()
819	(##sys#er-transformer
820	(lambda (form r c)
821	(##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
822	(let* ((t (cadr form))
823	(conser (caddr form))
824	(pred (cadddr form))
825	(slots (cddddr form))
826	(%begin (r 'begin))
827	(%lambda (r 'lambda))
828	(%define (r 'define))
829	(vars (cdr conser))
830	(x (r 'x))
831	(y (r 'y))
832	(%getter-with-setter (r 'getter-with-setter))
833	(slotnames (map car slots)))
834	`(,%begin
835	(,%define ,conser
836	(##sys#make-structure
837	',t
838	,@(map (lambda (sname)
839	(if (memq sname vars)
840	sname
841	'(##core#undefined) ) )
842	slotnames) ) )
843	(,%define (,pred ,x) (##sys#structure? ,x ',t))
844	,@(let loop ([slots slots] [i 1])
845	(if (null? slots)
846	'()
847	(let* ([slot (car slots)]
848	(setters (memq #:record-setters ##sys#features))
849	(setr? (pair? (cddr slot)))
850	(getr `(,%lambda (,x)
851	(##core#check (##sys#check-structure ,x ',t))
852	(##sys#block-ref ,x ,i) ) ) )
853	`(,@(if setr?
854	`((,%define (,(caddr slot) ,x ,y)
855	(##core#check (##sys#check-structure ,x ',t))
856	(##sys#block-set! ,x ,i ,y)) )
857	'() )
858	(,%define ,(cadr slot)
859	,(if (and setr? setters)
860	`(,%getter-with-setter ,getr ,(caddr slot))
861	getr) )
862	,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
863
864
865	;;; Compile-time `require':
866
867	(##sys#extend-macro-environment
868	'require-for-syntax '()
869	(##sys#er-transformer
870	(lambda (form r c)
871	`(##core#require-for-syntax ,@(cdr form)))))
872
873	(##sys#extend-macro-environment
874	'use '()
875	(##sys#er-transformer
876	(lambda (form r c)
877	`(##core#require-extension ,@(cdr form)))))
878
879
880	;;; SRFI-26:
881
882	(##sys#extend-macro-environment
883	'cut '()
884	(##sys#er-transformer
885	(lambda (form r c)
886	(let ((%<> (r '<>))
887	(%<...> (r '<...>))
888	(%apply (r 'apply))
889	(%begin (r 'begin))
890	(%lambda (r 'lambda)))
891	(let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
892	(if (null? xs)
893	(let ([rvars (reverse vars)]
894	[rvals (reverse vals)] )
895	(if rest
896	(let ([rv (r (gensym))])
897	`(,%lambda (,@rvars . ,rv)
898	(,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
899	`(,%lambda ,rvars ((,%begin ,(car rvals)) ,@(cdr rvals)) ) ) )
900	(cond ((c %<> (car xs))
901	(let ([v (r (gensym))])
902	(loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
903	((c %<...> (car xs)) (loop '() vars vals #t))
904	(else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
905
906	(##sys#extend-macro-environment
907	'cute '()
908	(##sys#er-transformer
909	(lambda (form r c)
910	(let ((%let (r 'let))
911	(%lambda (r 'lambda))
912	(%<> (r '<>))
913	(%<...> (r '<...>))
914	(%apply (r 'apply)))
915	(let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
916	(if (null? xs)
917	(let ([rvars (reverse vars)]
918	[rvals (reverse vals)] )
919	(if rest
920	(let ([rv (r (gensym))])
921	`(,%let
922	,bs
923	(,%lambda (,@rvars . ,rv)
924	(,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
925	`(,%let ,bs
926	(,%lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
927	(cond ((c %<> (car xs))
928	(let ([v (r (gensym))])
929	(loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
930	((c %<...> (car xs)) (loop '() vars bs vals #t))
931	(else
932	(let ([v (r (gensym))])
933	(loop (cdr xs)
934	vars
935	(cons (list v (car xs)) bs)
936	(cons v vals) #f) ) ))))))))
937
938
939	;;; SRFI-13:
940
941	(##sys#extend-macro-environment
942	'let-string-start+end '()
943	(##sys#er-transformer
944	(lambda (form r c)
945	(##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
946	(let ((s-e-r (cadr form))
947	(proc (caddr form))
948	(s-exp (cadddr form))
949	(args-exp (car (cddddr form)))
950	(body (cdr (cddddr form)))
951	(%receive (r 'receive))
952	(%string-parse-start+end (r 'string-parse-start+end))
953	(%string-parse-final-start+end (r 'string-parse-final-start+end)))
954	(if (pair? (cddr s-e-r))
955	`(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
956	(,%string-parse-start+end ,proc ,s-exp ,args-exp)
957	,@body)
958	`(,%receive ,s-e-r
959	(,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
960	,@body) ) ))))
961
962
963	;;; Extension helper:
964
965	(##sys#extend-macro-environment
966	'define-extension '()
967	(##sys#er-transformer
968	(lambda (form r c)
969	(##sys#check-syntax 'define-extension form '(_ symbol . _))
970	(let ((%declare (r 'declare))
971	(%begin (r 'begin))
972	(%static (r 'static))
973	(%dynamic (r 'dynamic))
974	(%export (r 'export)))
975	(let loop ((s '()) (d '()) (cs (cddr form)) (exports #f))
976	(cond ((null? cs)
977	(let ((exps (if exports
978	`(,%declare (,%export ,@exports))
979	'(,%begin))))
980	`(,(r 'cond-expand)
981	(chicken-compile-shared ,exps ,@d)
982	((,(r 'not) compiling) ,@d)
983	(,(r 'else)
984	(,%declare (unit ,name))
985	,exps
986	(,(r 'provide) (,(r 'quote) ,name))
987	,@s) ) ) )
988	((and (pair? cs) (pair? (car cs)))
989	(let ((t (caar cs))
990	(next (cdr cs)) )
991	(cond ((c %static t)
992	(loop (cons `(,%begin ,@(cdar cs)) s) d next exports))
993	((c %dynamic t)
994	(loop s (cons `(,%begin ,@(cdar cs)) d) next exports))
995	((c %export t)
996	(loop s d next (append (or exports '()) (cdar cs))))
997	(else
998	(syntax-error 'define-extension "invalid clause specifier" (caar cs))) ) ) )
999	(else
1000	(syntax-error
1001	'define-extension
1002	"invalid clause syntax" cs)) ) ) ))))
1003
1004
1005	;;; SRFI-31
1006
1007	(##sys#extend-macro-environment
1008	'rec '()
1009	(##sys#er-transformer
1010	(lambda (form r c)
1011	(##sys#check-syntax 'rec form '(_ _ . _))
1012	(let ((head (cadr form))
1013	(%letrec (r 'letrec)))
1014	(if (pair? head)
1015	`(,%letrec ((,(car head)
1016	(,(r 'lambda) ,(cdr head)
1017	,@(cddr form))))
1018	,(car head))
1019	`(,%letrec ((,head ,@(cddr form))) ,head))))))
1020
1021
1022	;;; Definitions available at macroexpansion-time:
1023
1024	(##sys#extend-macro-environment
1025	'define-for-syntax '()
1026	(##sys#er-transformer
1027	(lambda (form r c)
1028	(##sys#check-syntax 'define-for-syntax form '(_ _ . _))
1029	(let ((head (cadr form))
1030	(body (cddr form)))
1031	(let* ((body (if (null? body) '((##core#undefined)) body))
1032	(name (if (pair? head) (car head) head))
1033	(body (if (pair? head)
1034	`(,(r 'lambda) ,(cdr head) ,@body)
1035	(car body))))
1036	(if (symbol? name)
1037	(##sys#setslot name 0 (eval body))
1038	(syntax-error 'define-for-syntax "invalid identifier" name) )
1039	(if ##sys#enable-runtime-macros
1040	`(,(r 'define) ,name ,body)
1041	'(##core#undefined)))))))
1042
1043
1044	;;; just in case someone forgets
1045
1046	(##sys#extend-macro-environment
1047	'define-macro '()
1048	(##sys#er-transformer
1049	(lambda (form r c)
1050	(syntax-error 'define-macro "`define-macro' is not supported - please use `define-syntax'"))))
1051
1052	(##sys#macro-subset me0)))
1053
1054	(eval-when (compile load eval)
1055	(register-feature! 'srfi-8 'srfi-16 'srfi-26 'srfi-31 'srfi-15 'srfi-11) )

Note: See TracBrowser for help on using the repository browser.

Download in other formats: