blob: 3a175a55801ad2ae65014fb8b81317f17bfc1408 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
(export
apply
call-with-current-continuation
call-with-values
call/cc
define-values
let*-values
let-values
values)
(import (only (csc builtins)
call-builtin))
(begin
(define (call-with-current-continuation proc)
(call-builtin call-with-current-continuation proc))
(define call/cc call-with-current-continuation)
(define (call-with-values producer consumer)
(call-builtin call-with-values producer consumer))
(define (values . things)
(call-with-current-continuation
(lambda (cont) (apply cont things))))
(define-syntax let-values
(syntax-rules ()
((let-values (binding ...) body0 body1 ...)
(let-values "bind"
(binding ...) () (begin body0 body1 ...)))
((let-values "bind" () tmps body)
(let tmps body))
((let-values "bind" ((b0 e0)
binding ...) tmps body)
(let-values "mktmp" b0 e0 ()
(binding ...) tmps body))
((let-values "mktmp" () e0 args
bindings tmps body)
(call-with-values
(lambda () e0)
(lambda args
(let-values "bind"
bindings tmps body))))
((let-values "mktmp" (a . b) e0 (arg ...)
bindings (tmp ...) body)
(let-values "mktmp" b e0 (arg ... x)
bindings (tmp ... (a x)) body))
((let-values "mktmp" a e0 (arg ...)
bindings (tmp ...) body)
(call-with-values
(lambda () e0)
(lambda (arg ... . x)
(let-values "bind"
bindings (tmp ... (a x)) body))))))
(define-syntax let*-values
(syntax-rules ()
((let*-values () body0 body1 ...)
(let () body0 body1 ...))
((let*-values (binding0 binding1 ...)
body0 body1 ...)
(let-values (binding0)
(let*-values (binding1 ...)
body0 body1 ...)))))
(define-syntax define-values
(syntax-rules ()
((define-values () expr)
(define dummy
(call-with-values (lambda () expr)
(lambda args #f))))
((define-values (var) expr)
(define var expr))
((define-values (var0 var1 ... varn) expr)
(begin
(define var0
(call-with-values (lambda () expr)
list))
(define var1
(let ((v (cadr var0)))
(set-cdr! var0 (cddr var0))
v)) ...
(define varn
(let ((v (cadr var0)))
(set! var0 (car var0))
v))))
((define-values (var0 var1 ... . varn) expr)
(begin
(define var0
(call-with-values (lambda () expr)
list))
(define var1
(let ((v (cadr var0)))
(set-cdr! var0 (cddr var0))
v)) ...
(define varn
(let ((v (cdr var0)))
(set! var0 (car var0))
v))))
((define-values var expr)
(define var
(call-with-values (lambda () expr)
list)))))
(define (apply proc arg1 . args)
(define args*
(let loop ((args (cons arg1 args)))
(if (null? (cdr args))
(car args)
(cons (car args) (loop (cdr args))))))
(call-builtin apply proc (list->vector args*))))
|
