Skip to content

Commit 4f6651b

Browse files
ktakashiktakashi
committed
Adding more continuation mark test
Reconstruct continuation marks after restoring cont frame
1 parent 03442ba commit 4f6651b

File tree

2 files changed

+217
-2
lines changed

2 files changed

+217
-2
lines changed

‎src/vm.c‎

Lines changed: 35 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1548,6 +1548,9 @@ static int bottom_cont_frame_p(SgVM *vm, SgContFrame *cont)
15481548
|| cont == cont->prev->prev;
15491549
}
15501550

1551+
/* Forward declaration */
1552+
static void rebuild_prompts_from_cont(SgVM *vm);
1553+
15511554
static SgPromptNode *insert_prompt(SgVM *vm, SgPromptNode *node,
15521555
SgPrompt *prompt, SgContFrame *frame)
15531556
{
@@ -1758,6 +1761,8 @@ static SgObject throw_continuation_body(SgObject handlers,
17581761
vm->cont = c->cont;
17591762
vm->marks = c->marks;
17601763
vm->dynamicWinders = c->winders;
1764+
/* Rebuild prompt chain to match the restored cont chain */
1765+
rebuild_prompts_from_cont(vm);
17611766
}
17621767
return throw_continuation_end(vm, args);
17631768
}
@@ -2345,7 +2350,7 @@ static void remove_prompt(SgVM *vm, SgPrompt *prompt)
23452350
} else {
23462351
vm->prompts = node->next;
23472352
}
2348-
break;
2353+
return;
23492354
}
23502355
prev = node;
23512356
node = node->next;
@@ -2552,6 +2557,7 @@ static SgObject continuation_marks(SgContFrame *cont,
25522557

25532558
/* Reverse to get the correct order (most recent frame first) */
25542559
frames = Sg_ReverseX(frames);
2560+
25552561

25562562
/* Create mark set vector:
25572563
[0] = cont_mark_set_sym (type marker)
@@ -2577,7 +2583,8 @@ SgObject Sg_ContinuationMarks(SgObject k, SgObject tag)
25772583

25782584
SgObject Sg_CurrentContinuationMarks(SgObject tag)
25792585
{
2580-
return continuation_marks(theVM->cont, theVM->marks, tag);
2586+
SgVM *vm = theVM;
2587+
return continuation_marks(vm->cont, vm->marks, tag);
25812588
}
25822589

25832590
/* given load path must be unshifted.
@@ -2938,6 +2945,32 @@ static SG_DEFINE_SUBR(default_exception_handler_rec, 1, 0,
29382945

29392946
#define TAIL_POS(vm) (*PC(vm) == RET)
29402947

2948+
/* Rebuild vm->prompts from the continuation frame chain.
2949+
This is needed after restoring a full continuation, since
2950+
the prompt chain may not match the new cont chain.
2951+
*/
2952+
static void rebuild_prompts_from_cont(SgVM *vm)
2953+
{
2954+
SgContFrame *cont = vm->cont;
2955+
SgPromptNode *head = NULL;
2956+
2957+
/* Walk the cont chain and collect prompt frames in order */
2958+
while (cont && !bottom_cont_frame_p(vm, cont)) {
2959+
if (PROMPT_FRAME_MARK_P(cont)) {
2960+
SgPromptNode *node = SG_NEW(SgPromptNode);
2961+
node->prompt = (SgPrompt *)cont->pc;
2962+
node->frame = cont;
2963+
node->next = NULL;
2964+
/* Build list in reverse (head insertion) so prompts are
2965+
in correct order (most recent first) */
2966+
node->next = head;
2967+
head = node;
2968+
}
2969+
cont = cont->prev;
2970+
}
2971+
vm->prompts = head;
2972+
}
2973+
29412974
static SgContFrame *skip_prompt_frame(SgVM *vm)
29422975
{
29432976
SgContFrame *cont = vm->cont;

‎test/tests/sagittarius/continuations.scm‎

Lines changed: 182 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -347,4 +347,186 @@
347347
((call-with-continuation-barrier
348348
(lambda ()
349349
(call/cc values))))))
350+
351+
;; continuation marks
352+
(test-assert (continuation-mark-set? (current-continuation-marks)))
353+
354+
(test-equal 'mark
355+
(with-continuation-mark 'key 'mark
356+
(call-with-immediate-continuation-mark 'key values)))
357+
358+
(test-equal 'default
359+
(let ([tag (make-continuation-prompt-tag)])
360+
(with-continuation-mark 'key 'mark
361+
(call-with-continuation-prompt
362+
(lambda ()
363+
(call-with-immediate-continuation-mark 'key values 'default))
364+
tag))))
365+
366+
(let ()
367+
(define tag (make-continuation-prompt-tag))
368+
(define key (make-continuation-mark-key))
369+
(define key1 (make-continuation-mark-key))
370+
(define key2 (make-continuation-mark-key))
371+
372+
;; With default prompt tag, marks outside the prompt boundary are
373+
;; not visible. mark2 replaces mark1 (same key, tail position), but
374+
;; both are outside the prompt.
375+
(test-equal '(mark3)
376+
(with-continuation-mark key 'mark1
377+
(with-continuation-mark key 'mark2
378+
(call-with-continuation-prompt
379+
(lambda ()
380+
(with-continuation-mark key 'mark3
381+
(continuation-mark-set->list #f key)))))))
382+
383+
;; With custom prompt tag for installation but default tag for
384+
;; querying, the prompt boundary is not detected, so all marks are
385+
;; visible.
386+
(test-equal '(#(mark3 default) #(mark1 mark2))
387+
(with-continuation-mark key1 'mark1
388+
(with-continuation-mark key2 'mark2
389+
(call-with-continuation-prompt
390+
(lambda ()
391+
(with-continuation-mark key1 'mark3
392+
(continuation-mark-set->list* #f (list key1 key2) 'default)))
393+
tag)))))
394+
395+
(test-equal 'mark2
396+
(let ([tag (make-continuation-prompt-tag)]
397+
[key (make-continuation-mark-key)])
398+
(with-continuation-mark key 'mark1
399+
(call-with-continuation-prompt
400+
(lambda ()
401+
(with-continuation-mark key 'mark2
402+
(continuation-mark-set-first #f key)))
403+
tag))))
404+
405+
(test-equal 'mark
406+
(let ([tag (make-continuation-prompt-tag 'mytag)]
407+
[key (make-continuation-mark-key)])
408+
(define k
409+
(with-continuation-mark key 'mark
410+
(call-with-continuation-prompt
411+
(lambda ()
412+
(call/cc values))
413+
tag)))
414+
(continuation-mark-set-first (continuation-marks k) key)))
415+
416+
(test-equal 'mark1
417+
(with-continuation-mark 'key 'mark1
418+
(call-with-immediate-continuation-mark 'key values)))
419+
420+
(test-equal 'mark2
421+
(with-continuation-mark 'key 'mark1
422+
(with-continuation-mark 'key 'mark2
423+
(call-with-immediate-continuation-mark 'key values))))
424+
425+
(test-equal '(#f)
426+
(with-continuation-mark 'key 'mark1
427+
(list
428+
(call-with-immediate-continuation-mark 'key values))))
429+
430+
(test-equal '((mark1) (mark2))
431+
(with-continuation-mark 'key1 'mark1
432+
(with-continuation-mark 'key2 'mark2
433+
(list
434+
(continuation-mark-set->list #f 'key1)
435+
(continuation-mark-set->list #f 'key2)))))
436+
437+
(test-equal '((mark1) (mark2))
438+
(with-continuation-marks (['key1 'mark1]
439+
['key2 'mark2])
440+
(list
441+
(continuation-mark-set->list #f 'key1)
442+
(continuation-mark-set->list #f 'key2))))
443+
444+
(test-equal '(1)
445+
(let f ([n 10])
446+
(if (fxzero? n)
447+
(continuation-mark-set->list #f 'key)
448+
(with-continuation-mark 'key n
449+
(f (fx- n 1))))))
450+
451+
(test-equal '(mark2)
452+
(with-continuation-mark 'key 'mark1
453+
(call-with-continuation-prompt
454+
(lambda ()
455+
(with-continuation-mark 'key 'mark2
456+
(continuation-mark-set->list #f 'key))))))
457+
458+
(test-equal '(mark2)
459+
(with-continuation-mark 'key 'mark1
460+
(list
461+
(with-continuation-mark 'key 'mark2
462+
(continuation-mark-set-first #f 'key)))))
463+
464+
(test-equal '(((#(#f mark2) #(mark1 mark2))))
465+
(with-continuation-mark 'key1 'mark1
466+
(with-continuation-mark 'key2 'mark2
467+
(list
468+
(with-continuation-mark 'key3 'mark3
469+
(list
470+
(with-continuation-mark 'key2 'mark2
471+
(continuation-mark-set->list* #f '(key1 key2)))))))))
472+
473+
474+
(test-equal 'mark
475+
(with-continuation-mark 'key 'mark
476+
(call-with-immediate-continuation-mark 'key values)))
477+
(test-equal 'default
478+
(let ([tag (make-continuation-prompt-tag)])
479+
(with-continuation-mark 'key 'mark
480+
(call-with-continuation-prompt
481+
(lambda ()
482+
(call-with-immediate-continuation-mark 'key values 'default))
483+
tag))))
484+
485+
(test-equal #t (continuation-mark-set? (current-continuation-marks)))
486+
487+
(test-equal '(mark3 mark2)
488+
(let ([tag (make-continuation-prompt-tag)]
489+
[key (make-continuation-mark-key)])
490+
(with-continuation-mark key 'mark1
491+
(with-continuation-mark key 'mark2
492+
(call-with-continuation-prompt
493+
(lambda ()
494+
(with-continuation-mark key 'mark3
495+
(continuation-mark-set->list #f key)))
496+
tag)))))
497+
(test-equal '(#(mark3 default) #(mark1 mark2))
498+
(let ([tag (make-continuation-prompt-tag)]
499+
[key1 (make-continuation-mark-key)]
500+
[key2 (make-continuation-mark-key)])
501+
(with-continuation-mark key1 'mark1
502+
(with-continuation-mark key2 'mark2
503+
(call-with-continuation-prompt
504+
(lambda ()
505+
(with-continuation-mark key1 'mark3
506+
(continuation-mark-set->list* #f (list key1 key2) 'default)))
507+
tag)))))
508+
509+
(test-equal 'mark2
510+
(let ([tag (make-continuation-prompt-tag)]
511+
[key (make-continuation-mark-key)])
512+
(with-continuation-mark key 'mark1
513+
(call-with-continuation-prompt
514+
(lambda ()
515+
(with-continuation-mark key 'mark2
516+
(continuation-mark-set-first #f key)))
517+
tag))))
518+
519+
(test-equal 'mark
520+
(let ([tag (make-continuation-prompt-tag 'mytag)]
521+
[key (make-continuation-mark-key)])
522+
(define k
523+
(with-continuation-mark key 'mark
524+
(call-with-continuation-prompt
525+
(lambda ()
526+
(call/cc values))
527+
tag)))
528+
(continuation-mark-set-first (continuation-marks k) key)))
529+
530+
(test-equal #t (continuation-mark-key? (make-continuation-mark-key)))
531+
(test-equal #f (equal? (make-continuation-mark-key) (make-continuation-mark-key)))
350532
(test-end)

0 commit comments

Comments
 (0)