Skip to content

Commit 93e31dd

Browse files
ktakashiktakashi
committed
Adding SRFI-226 parameterize
1 parent 79d1a9b commit 93e31dd

File tree

5 files changed

+157
-15
lines changed

5 files changed

+157
-15
lines changed

‎lib/sagittarius/continuations.scm‎

Lines changed: 80 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -153,7 +153,86 @@
153153
(lambda (p)
154154
(lambda (:optional ((name (or symbol? #f)) #f)) (p name)))))
155155

156-
;; From SRFI-226 implementation
156+
;;;; shift reset
157+
158+
;; (define (abort-current-continuation/keep-prompt tag thunk)
159+
;; ((call-with-continuation-prompt
160+
;; (lambda ()
161+
;; ((call-with-delimited-current-continuation
162+
;; (lambda (k) (lambda () k))
163+
;; tag)))
164+
;; tag)
165+
;; thunk))
166+
;; (define (make-call-with-shift abort-cc inserted-handler)
167+
;; (letrec ((call-with-shift
168+
;; (lambda (f :optional (tag (default-continuation-prompt-tag)))
169+
;; (call-with-composable-continuation
170+
;; (lambda (k)
171+
;; (abort-cc
172+
;; tag
173+
;; (lambda ()
174+
;; (f (lambda vals
175+
;; (call-with-continuation-prompt
176+
;; (lambda () (apply k vals))
177+
;; tag
178+
;; inserted-handler))))))
179+
;; tag))))
180+
;; call-with-shift))
181+
182+
;; (define call-with-shift
183+
;; (make-call-with-shift abort-current-continuation/keep-prompt #f))
184+
185+
;; (define (make-call-with-control abort-cc)
186+
;; ;; Uses call/cc to always keep the enclosing prompt.
187+
;; (letrec ((call-with-control
188+
;; (lambda (f :optional (tag (default-continuation-prompt-tag)))
189+
;; (call-with-composable-continuation
190+
;; (lambda (k) (abort-cc tag (lambda () (f k))))
191+
;; tag))))
192+
;; call-with-control))
193+
194+
;; (define call-with-control
195+
;; (make-call-with-control abort-current-continuation/keep-prompt))
196+
197+
;; (define-syntax define-prompt-macros
198+
;; (syntax-rules ()
199+
;; ((_ prompt prompt-at call-with-prompt)
200+
;; (begin
201+
;; (define-syntax prompt
202+
;; (syntax-rules ()
203+
;; ((prompt expr0 expr (... ...))
204+
;; (call-with-prompt (lambda () expr0 expr (... ...))))))
205+
;; (define-syntax prompt-at
206+
;; (syntax-rules ()
207+
;; ((prompt-at tag expr0 expr (... ...))
208+
;; (call-with-prompt (lambda () expr0 expr (... ...)) tag))))))))
209+
210+
;; (define-syntax define-control-macros
211+
;; (syntax-rules ()
212+
;; ((_ control control-at call-with-control)
213+
;; (begin
214+
;; (define-syntax control
215+
;; (lambda (stx)
216+
;; (syntax-case stx ()
217+
;; ((control id expr0 expr (... ...))
218+
;; (identifier? #'id)
219+
;; #'(call-with-control
220+
;; (lambda (id) expr0 expr (... ...)))))))
221+
;; (define-syntax control-at
222+
;; (lambda (stx)
223+
;; (syntax-case stx ()
224+
;; ((control-at tag id expr0 expr (... ...))
225+
;; (identifier? #'id)
226+
;; #'(call-with-control
227+
;; (lambda (id) expr0 expr (... ...)) tag)))))))))
228+
229+
;; (define-prompt-macros prompt prompt-at call-with-continuation-prompt)
230+
;; (define-control-macros control control-at call-with-control)
231+
232+
;; (define-control-macros shift shift-at call-with-shift)
233+
;; (define-prompt-macros reset reset-at call-with-continuation-prompt)
234+
235+
;; ;; From SRFI-226 implementation
157236
(define-syntax reset
158237
(lambda (x)
159238
(syntax-case x ()

‎lib/sagittarius/parameters.scm‎

Lines changed: 58 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -32,23 +32,73 @@
3232
#!nounbound
3333
(library (sagittarius parameters)
3434
(export make-thread-parameter thread-parameter? <thread-parameter>
35-
(rename (make-thread-parameter make-parameter))
36-
<parameter> parameter?
35+
make-parameter <parameter> parameter?
3736

38-
parameterize temporarily)
39-
(import (rnrs)
37+
*parameterization-mark-key*
38+
39+
parameterize
40+
parameterize/dw temporarily)
41+
(import (core)
4042
(core syntax)
4143
(clos user)
4244
(sagittarius)
4345
(sagittarius object)
46+
(sagittarius continuations)
4447
(only (sagittarius) current-dynamic-environment))
4548

4649
(define mark (list 0)) ;; unique mark
4750

51+
(define-class <parameterization> ()
52+
((cells :init-value '() :init-keyword :cells :reader parameterization-cells)))
53+
(define (make-parameterization :optional (cells '()))
54+
(make <parameterization> :cells cells))
55+
(define (parameterization? o) (is-a? o <parameterization>))
56+
(define (parameterization-extend (p parameterization?) key+value*)
57+
(make-parameterization (append key+value* (parameterization-cells p))))
58+
(define (parameterization-ref (p parameterization?) key)
59+
(assq key (parameterization-cells p)))
60+
61+
(define *parameterization-mark-key*
62+
(make-continuation-mark-key 'parameterization))
63+
64+
(define (current-parameterization)
65+
;; Use #f as prompt-tag to search marks beyond prompt boundaries.
66+
;; This ensures parameterization from outside a prompt is visible inside.
67+
(cond ((continuation-mark-set-first #f *parameterization-mark-key* #f #f))
68+
(else (make-parameterization))))
69+
70+
(define-syntax parameterize
71+
(lambda (x)
72+
(syntax-case x ()
73+
((_ ((p v) ...) e1 e2 ...)
74+
#'(with-continuation-mark
75+
*parameterization-mark-key*
76+
(parameterization-extend
77+
(current-parameterization)
78+
(list (cons p (parameter-convert p v)) ...))
79+
(let () e1 e2 ...))))))
80+
4881
(define-class <parameter> ()
49-
((converter :init-keyword :converter)
50-
(init :init-keyword :init)))
82+
((converter :init-keyword :converter :reader parameter-converter)
83+
(init :init-keyword :init :reader parameter-val :writer parameter-val-set!)))
5184
(define (parameter? o) (is-a? o <parameter>))
85+
(define (make-parameter init :optional (converter #f))
86+
(let ((init (if converter (converter init) init)))
87+
(make <parameter> :converter converter :init init)))
88+
89+
(define (parameter-cell p)
90+
(parameterization-ref (current-parameterization) p))
91+
92+
(define-method object-apply ((p <parameter>))
93+
(cond ((parameter-cell p) => cdr)
94+
(else (parameter-val p))))
95+
96+
(define-method object-apply ((p <parameter>) v)
97+
(let ((conv (parameter-converter p)))
98+
(cond ((parameter-cell p) =>
99+
(lambda (cell)
100+
(set-cdr! cell (if conv (conv v) v))))
101+
(else (parameter-val-set! p (if conv (conv v) v))))))
52102

53103
;; TODO thread-local?
54104
(define-class <thread-parameter> (<parameter>) ())
@@ -80,7 +130,7 @@
80130
(p v)))
81131

82132
(define (parameter-convert p v)
83-
(if (is-a? p <thread-parameter>)
133+
(if (is-a? p <parameter>)
84134
(let ((conv (~ p 'converter)))
85135
(if (procedure? conv)
86136
(conv v)
@@ -119,7 +169,7 @@
119169
(parameterize-aux (param ... p) (val ... v) (tmps ... (P L S))
120170
more body))))
121171

122-
(define-syntax parameterize
172+
(define-syntax parameterize/dw
123173
(syntax-rules ()
124174
((_ (binds ...) . body)
125175
(parameterize-aux () () () (binds ...) body))))

‎sitelib/srfi/%3a39/parameters.scm‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@
2828
;;;
2929
#!core
3030
(library (srfi :39 parameters)
31-
(export make-parameter parameterize)
32-
(import (sagittarius parameters)))
31+
(export (rename (make-thread-parameter make-parameter)
32+
(parameterize/dw parameterize)))
33+
(import (sagittarius parameters)))
3334

‎src/vm.c‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2421,6 +2421,18 @@ SgObject Sg_VMCallCM(SgObject entries, SgObject thunk)
24212421
SgVM *vm = theVM;
24222422
long i, len = SG_VECTOR_SIZE(entries);
24232423

2424+
/* If the current mark frame is associated with a prompt frame,
2425+
we need to create a new mark frame to avoid polluting the prompt's marks.
2426+
Marks added inside a prompt should be stripped when aborting.
2427+
We use NULL as the frame pointer so strip_marks will walk past this frame. */
2428+
if (vm->marks && vm->marks->frame && PROMPT_FRAME_MARK_P(vm->marks->frame)) {
2429+
SgContMarks *cm = SG_NEW(SgContMarks);
2430+
cm->frame = NULL; /* NULL frame means this is a "virtual" frame for marks only */
2431+
cm->entries = NULL;
2432+
cm->prev = vm->marks;
2433+
vm->marks = cm;
2434+
}
2435+
24242436
for (i = 0; i < len; i++) {
24252437
SgObject entry = SG_VECTOR_ELEMENT(entries, i);
24262438
SgObject key = SG_CAR(entry);
@@ -2977,8 +2989,8 @@ static SgContFrame *skip_prompt_frame(SgVM *vm)
29772989
SgContMarks *marks = vm->marks;
29782990
while (PROMPT_FRAME_MARK_P(cont)) {
29792991
remove_prompt(theVM, (SgPrompt *)cont->pc);
2980-
cont = cont->prev;
29812992
if (marks) marks = marks->prev;
2993+
cont = cont->prev;
29822994
}
29832995
vm->marks = marks;
29842996
return cont;

‎test/tests/sagittarius/partcont-shift.scm‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
(import (rename (except (rnrs)
22
call/cc call-with-current-continuation guard)
33
(error r6rs:error))
4-
(srfi :39)
4+
;;(srfi :39)
55
(srfi :64)
66
(sagittarius)
7-
(only (sagittarius parameters) temporarily)
7+
(sagittarius parameters)
88
(rename (sagittarius continuations)
99
(call/delim-cc call/cc)
1010
(call-with-delimited-current-continuation
@@ -55,7 +55,7 @@
5555

5656
(define (with-output-to-string thunk)
5757
(let-values (((out e) (open-string-output-port)))
58-
(parameterize ((current-output-port out))
58+
(parameterize/dw ((current-output-port out))
5959
(reset (thunk))
6060
(e))))
6161

0 commit comments

Comments
 (0)