From bb92809ffbe561b42867572d96ffd58eead7d45d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Sun, 29 Jan 2023 19:56:39 +0100 Subject: [PATCH 1/5] Implement delimited continuations. A SRFI 226 compatible API for delimited continuations is provided. --- Makefile | 4 +- lib/init-7.scm | 494 ++++++++++++++++++++++++++++++---- lib/srfi/226/continuation.sld | 43 +++ lib/srfi/226/prompt.sld | 11 + lib/srfi/226/shift-reset.sld | 46 ++++ lib/srfi/226/test.sld | 187 +++++++++++++ tests/lib-tests.scm | 4 +- 7 files changed, 738 insertions(+), 51 deletions(-) create mode 100644 lib/srfi/226/continuation.sld create mode 100644 lib/srfi/226/prompt.sld create mode 100644 lib/srfi/226/shift-reset.sld create mode 100644 lib/srfi/226/test.sld diff --git a/Makefile b/Makefile index 96b7def9..4444862e 100644 --- a/Makefile +++ b/Makefile @@ -315,7 +315,7 @@ install-base: all $(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time - $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(MODDIR)/srfi/179 + $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(MODDIR)/srfi/226 $(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/ $(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/ $(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/ @@ -368,6 +368,7 @@ install-base: all $(INSTALL) -m0644 lib/srfi/146/*.scm $(DESTDIR)$(MODDIR)/srfi/146/ $(INSTALL) -m0644 lib/srfi/179/*.sld $(DESTDIR)$(MODDIR)/srfi/179/ $(INSTALL) -m0644 lib/srfi/179/*.scm $(DESTDIR)$(MODDIR)/srfi/179/ + $(INSTALL) -m0644 lib/srfi/226/*.sld $(DESTDIR)$(MODDIR)/srfi/226/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/ $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/ @@ -479,6 +480,7 @@ uninstall: -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(BINMODDIR)/srfi/166 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(BINMODDIR)/srfi/179 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/226 $(DESTDIR)$(BINMODDIR)/srfi/226 -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi -$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR) -$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1 diff --git a/lib/init-7.scm b/lib/init-7.scm index b14b0540..8225dbbe 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -771,62 +771,458 @@ (consumer res)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; dynamic-wind +;; continuations -(define %make-point vector) -(define (%point-depth point) (vector-ref point 0)) -(define (%point-in point) (vector-ref point 1)) -(define (%point-out point) (vector-ref point 2)) -(define (%point-parent point) (vector-ref point 3)) +(define %sentinel (list #f)) +(define (%sentinel? obj) (eq? obj %sentinel)) -(define root-point ; Shared among all state spaces - (%make-point 0 - (lambda () (error "winding in to root!")) - (lambda () (error "winding out of root!")) - #f)) +;; Primitives -(cond-expand - (threads) - (else - (define %dk - (let ((dk root-point)) - (lambda o (if (pair? o) (set! dk (car o)) dk)))))) - -(%dk root-point) - -(define (dynamic-wind in body out) - (in) - (let ((here (%dk))) - (%dk (%make-point (+ (%point-depth here) 1) - in - out - here)) - (let ((res (body))) - (%dk here) - (out) - res))) +(define (%call-with-current-continuation proc) + (%call/cc + (lambda (k) + ((%call/cc + (lambda (abort-k) + (lambda () + (proc (%continuation k abort-k))))))))) -(define (travel-to-point! here target) - (cond - ((eq? here target) - 'done) - ((< (%point-depth here) (%point-depth target)) - (travel-to-point! here (%point-parent target)) - ((%point-in target))) - (else - ((%point-out here)) - (travel-to-point! (%point-parent here) target)))) +(define (%continuation k abort-k) + (lambda arg* + (if (and (pair? arg*) + (%sentinel? (car arg*))) + (abort-k (cadr arg*)) + (apply k arg*)))) + +(define (%call-in-continuation k thunk) + (k %sentinel thunk)) + +;; Continuation prompt tags + +(define %default-continuation-prompt-tag + (list 0 'default)) + +(define %continuation-barrier-tag + (list 1 'barrier)) + +(define (default-continuation-prompt-tag) + %default-continuation-prompt-tag) + +(define make-continuation-prompt-tag + (let ((counter 1)) + (lambda name* + (set! counter (+ counter 1)) + (cons counter name*)))) + +(define (continuation-prompt-tag? obj) #t) + +;; Continuation infos + +(define (%make-continuation mk k winders prompt-tag resume-k non-composable?) + (define info (vector mk prompt-tag resume-k non-composable?)) + (lambda arg* + (if (and (pair? arg*) + (%sentinel? (car arg*))) + info + (resume-k (lambda () (apply values arg*)))))) + +(define (%continuation->continuation-info k) + (k %sentinel)) -(define (continuation->procedure cont point) - (lambda res - (travel-to-point! (%dk) point) - (%dk point) - (cont (%values res)))) +(define (%continuation-metacontinuation k) + (vector-ref (%continuation->continuation-info k) 0)) + +(define (%continuation-prompt-tag k) + (vector-ref (%continuation->continuation-info k) 1)) + +(define (%continuation-resume-k k) + (vector-ref (%continuation->continuation-info k) 2)) + +(define (%continuation-non-composable? k) + (vector-ref (%continuation->continuation-info k) 3)) + +;; Winders + +(define (%make-winder height k pre-thunk post-thunk) + (vector height k pre-thunk post-thunk)) + +(define (%winder-height winder) + (vector-ref winder 0)) +(define (%winder-continuation winder) + (vector-ref winder 1)) +(define (%winder-pre-thunk winder) + (vector-ref winder 2)) +(define (%winder-post-thunk winder) + (vector-ref winder 3)) + +(define (%winders-height winders) + (if (null? winders) + 0 + (+ (%winder-height (car winders)) 1))) + +;; Metacontinuations + +(define (%make-metacontinuation-frame tag k handler winders) + (vector tag k handler winders)) + +(define (%metacontinuation-frame-tag mf) (vector-ref mf 0)) +(define (%metacontinuation-frame-continuation mf) (vector-ref mf 1)) +(define (%metacontinuation-frame-handler mf) (vector-ref mf 2)) +(define (%metacontinuation-frame-winders mf) (vector-ref mf 3)) + +(define (%push-continuation k winders) + (%push-metacontinuation-frame! + (%make-metacontinuation-frame #f k #f winders))) + +(define (%push-metacontinuation-frame! mf) + (%current-metacontinuation (cons mf (%current-metacontinuation)))) + +(define (%pop-metacontinuation-frame!) + (let ((mk (%current-metacontinuation))) + (and (pair? mk) + (let ((mf (car mk))) + (%current-metacontinuation (cdr mk)) + (%current-winders (%metacontinuation-frame-winders mf)) + mf)))) + +(define (%append-metacontinuation! mk) + (%current-metacontinuation (append mk (%current-metacontinuation)))) + +(define (%take-metacontinuation prompt-tag barrier?) + (let f ((mk (%current-metacontinuation))) + (if (null? mk) + (error "continuation includes no prompt with the given tag" prompt-tag)) + (let ((frame (car mk)) (mk (cdr mk))) + (let ((tag (%metacontinuation-frame-tag frame))) + (cond + ((eq? tag prompt-tag) + '()) + ((and barrier? (eq? tag %continuation-barrier-tag)) + (error "applying the composable continuation would introduce a continuation barrier" + prompt-tag)) + (else + (cons frame (f mk)))))))) + +;; Trampoline + +(define (%abort thunk) + (let ((val (thunk))) + (cond + ((%pop-metacontinuation-frame!) + => (lambda (mf) + (call-with-values (lambda () val) + (%metacontinuation-frame-continuation mf)) + 12)) + (else val)))) + +(define (%call-in-empty-continuation thunk) + (%call-with-current-continuation + (lambda (k) + (%push-metacontinuation-frame! + (%make-metacontinuation-frame #f k #f (%current-winders))) + (%current-winders '()) + (%abort thunk)))) + +(define (%call-in-empty-marks arg . arg*) + (let ((thunk (if (null? arg*) + arg + (cadr arg*))) + (tag (and (pair? arg*) + arg)) + (handler (and (pair? arg*) + (car arg*)))) + (%call-with-current-continuation + (lambda (k) + (%push-metacontinuation-frame! + (%make-metacontinuation-frame tag k handler (%current-winders))) + (%current-winders '()) + (%abort thunk))))) + +(define (%abort-to k winders thunk) + (%call-in-continuation + k + (lambda () + (%current-winders winders) + (thunk)))) + +;; Continuation prompts + +(define (call-with-continuation-prompt thunk . arg*) + (let* ((prompt-tag (if (pair? arg*) + (car arg*) + %default-continuation-prompt-tag)) + (handler (or (and (pair? arg*) (pair? (cdr arg*)) + (cadr arg*)) + (%make-default-handler prompt-tag)))) + (%call-in-empty-marks prompt-tag handler thunk))) + +(define (%make-default-handler prompt-tag) + (lambda (thunk) + (call-with-continuation-prompt thunk prompt-tag))) + +(define (abort-current-continuation prompt-tag . arg*) + (if (not (%metacontinuation-contains-prompt? + (%current-metacontinuation) + prompt-tag)) + (error "abort-current-continuation: no prompt with the given tag in current continuation" + prompt-tag)) + (let f () + (if (null? (%current-winders)) + (let ((mf (car (%current-metacontinuation)))) + (if (eq? (%metacontinuation-frame-tag mf) prompt-tag) + (let ((handler (%metacontinuation-frame-handler mf))) + (%pop-metacontinuation-frame!) + (%abort-to + (%metacontinuation-frame-continuation mf) + (%metacontinuation-frame-winders mf) + (lambda () + (apply handler arg*)))) + (begin + (%pop-metacontinuation-frame!) + (f)))) + (%wind-to + '() + f + (lambda () + (if (not (%metacontinuation-contains-prompt? + (%current-metacontinuation) + prompt-tag)) + (error + "abort-current-continuation: lost prompt with the given tag during abort of the current continuation" + prompt-tag)) + (f)))))) + +;; Continuations + +(define (%make-composable-continuation mk k winders prompt-tag) + (%make-continuation + mk + k + winders + prompt-tag + (lambda (thunk) + (%call-in-composable-continuation mk k winders thunk)) + #f)) + +(define (%make-non-composable-continuation mk k winders prompt-tag) + (%make-continuation + mk + k + winders + prompt-tag + (lambda (thunk) + (%call-in-non-composable-continuation mk k winders prompt-tag thunk)) + #t)) + +(define (%call-in-composable-continuation mk k winders thunk) + (%call-in-empty-marks + (lambda () + (%abort-to-composition (reverse mk) k winders thunk #f)))) + +(define (%call-in-non-composable-continuation mk k winders prompt-tag thunk) + (let retry () + (call-with-values + (lambda () (%common-metacontinuation mk (%current-metacontinuation) prompt-tag)) + (lambda (dest-mf* base-mk) + (let f () + (if (eq? (%current-metacontinuation) base-mk) + (%abort-to-composition dest-mf* k winders thunk retry) + (%wind-to + '() + (lambda () + (%pop-metacontinuation-frame!) + (f)) + retry))))))) + +(define (%abort-to-composition mf* k winders thunk maybe-again-thunk) + (let f ((mf* mf*)) + (if (null? mf*) + (%wind-to + winders + (lambda () + (%abort-to k winders thunk)) + maybe-again-thunk) + (let ((mf (car mf*))) + (%wind-to + (%metacontinuation-frame-winders mf) + (lambda () + (%current-metacontinuation (cons mf (%current-metacontinuation))) + (%current-winders '()) + (f (cdr mf*))) + maybe-again-thunk))))) + +(define (call-with-non-composable-continuation proc . tag*) + (let ((prompt-tag (if (null? tag*) + %default-continuation-prompt-tag + (car tag*)))) + (%call-with-current-continuation + (lambda (k) + (proc (%make-non-composable-continuation + (%take-metacontinuation prompt-tag #f) + k + (%current-winders) + prompt-tag)))))) (define (call-with-current-continuation proc) - (%call/cc - (lambda (cont) - (proc (continuation->procedure cont (%dk)))))) + (call-with-non-composable-continuation proc)) + +(define (call-with-composable-continuation proc . tag*) + (let ((prompt-tag (if (null? tag*) + %default-continuation-prompt-tag + (car tag*)))) + (%call-with-current-continuation + (lambda (k) + (proc + (%make-composable-continuation + (%take-metacontinuation prompt-tag #t) + k + (%current-winders) + prompt-tag)))))) + +(define (%common-metacontinuation dest-mk current-mk tag) + (let ((base-mk* + (let f ((current-mk current-mk) (base-mk* '())) + (if (null? current-mk) + (error "current continuation includes no prompt with the given tag" tag)) + (if (eq? (%metacontinuation-frame-tag (car current-mk)) tag) + (cons current-mk base-mk*) + (f (cdr current-mk) (cons current-mk base-mk*)))))) + (let f ((dest-mf* (reverse dest-mk)) + (base-mk* (cdr base-mk*)) + (base-mk (car base-mk*))) + (cond + ((null? dest-mf*) + (values '() base-mk)) + ((null? base-mk*) + (%check-for-barriers dest-mf* tag) + (values dest-mf* base-mk)) + ((eq? (car dest-mf*) (caar base-mk*)) + (f (cdr dest-mf*) (cdr base-mk*) (car base-mk*))) + (else + (%check-for-barriers dest-mf* tag) + (values dest-mf* base-mk)))))) + +(define (%check-for-barriers dest-mf* tag) + (do ((dest-mf* dest-mf* (cdr dest-mf*))) + ((null? dest-mf*)) + (if (eq? (%metacontinuation-frame-tag (car dest-mf*)) %continuation-barrier-tag) + (error "applying the continuation would introduce a continuation barrier" tag)))) + +(define (call-in-continuation k proc . args) + ((%continuation-resume-k k) (lambda () (apply proc args)))) + +(define (call-in k proc . args) + ((%continuation-resume-k k) (lambda () (apply proc args)))) + +(define (return-to k . args) + (lambda (k args) + ((%continuation-resume-k k) (lambda () (apply values args))))) + +(define (continuation-prompt-available? tag . k*) + (if (null? k*) + (%metacontinuation-contains-prompt? (%current-metacontinuation) tag) + (let ((k (car k*))) + (or (and (%continuation-non-composable? k) + (eq? (%continuation-prompt-tag k) tag)) + (%metacontinuation-contains-prompt? (%continuation-metacontinuation k) tag))))) + +(define (%metacontinuation-contains-prompt? mk tag) + (let f ((mk mk)) + (and (not (null? mk)) + (or (eq? (%metacontinuation-frame-tag (car mk)) tag) + (f (cdr mk)))))) + +(define (call-with-continuation-barrier thunk) + (%call-in-empty-marks %continuation-barrier-tag #f thunk)) + +;; Dynamic-wind + +(define (dynamic-wind pre-thunk thunk post-thunk) + (%call-with-current-continuation + (lambda (k) + (let* ((winders (%current-winders)) + (winder (%make-winder (%winders-height winders) + k + pre-thunk post-thunk))) + (pre-thunk) + (%current-winders (cons winder winders)) + (call-with-values thunk + (lambda val* + (%current-winders winders) + (post-thunk) + (apply values val*))))))) + +(define (%wind-to dest-winders then-thunk maybe-again-thunk) + (let ((saved-mk (%current-metacontinuation))) + (let f ((winder* '()) (dest-winders dest-winders)) + (if (and maybe-again-thunk (not (eq? saved-mk (%current-metacontinuation)))) + (maybe-again-thunk) + (let ((winders (%current-winders))) + (cond + ((%winders=? dest-winders winders) + (if (null? winder*) + (then-thunk) + (let ((winders (cons (car winder*) winders)) + (winder* (cdr winder*))) + (%rewind winders + (lambda () + (%current-winders winders) + (f winder* winders)))))) + ((or (null? dest-winders) + (and (not (null? winders)) + (> (%winder-height (car winders)) + (%winder-height (car dest-winders))))) + (%unwind winders + (lambda () + (f winder* dest-winders)))) + (else + (f (cons (car dest-winders) winder*) (cdr dest-winders))))))))) + +(define (%wind winders ref then-thunk) + (let ((winder (car winders)) + (winders (cdr winders))) + (let ((winder-thunk (ref winder))) + (%abort-to + (%winder-continuation winder) + winders + (lambda () + (winder-thunk) + (then-thunk)))))) + +(define (%unwind winders thunk) + (%wind winders %winder-post-thunk thunk)) + +(define (%rewind winders thunk) + (%wind winders %winder-pre-thunk thunk)) + +(define (%winders=? w1 w2) + (= (%winders-height w1) (%winders-height w2))) + +;; Dynamic environment + +(define %metacontinuation + (list (%make-metacontinuation-frame + %default-continuation-prompt-tag + (lambda (thunk) + (thunk)) + (%make-default-handler %default-continuation-prompt-tag) + '()))) + +(define %winders '()) + +(define %current-metacontinuation + (lambda arg* + (if (null? arg*) + %metacontinuation + (set! %metacontinuation (car arg*))))) + +(define %current-winders + (lambda arg* + (if (null? arg*) + %winders + (set! %winders (car arg*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; with-i/o-from-file (define (with-input-from-file file thunk) (let ((old-in (current-input-port)) diff --git a/lib/srfi/226/continuation.sld b/lib/srfi/226/continuation.sld new file mode 100644 index 00000000..e82c9a25 --- /dev/null +++ b/lib/srfi/226/continuation.sld @@ -0,0 +1,43 @@ +(define-library (srfi 226 continuation) + (export + call-with-continuation-prompt + abort-current-continuation + call-with-current-continuation + call-with-composable-continuation + call-with-non-composable-continuation + call-in-continuation + call-in + return-to + continuation-prompt-available? + call-with-continuation-barrier + dynamic-wind + call/cc + unwind-protect) + (import (only (chibi) + call-with-continuation-prompt + abort-current-continuation + call-with-current-continuation + call-with-composable-continuation + call-with-non-composable-continuation + call-in-continuation + call-in + return-to + continuation-prompt-available? + call-with-continuation-barrier + dynamic-wind) + (scheme base)) + + (begin + (define-syntax unwind-protect + (syntax-rules () + ((unwind-protect protected-expr cleanup-expr ...) + (dynamic-wind + (lambda () (values)) + (lambda () (call-with-continuation-barrier (lambda () protected-expr))) + (lambda () (values) cleanup-expr ...)))))) + + ) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/lib/srfi/226/prompt.sld b/lib/srfi/226/prompt.sld new file mode 100644 index 00000000..33a9ee0c --- /dev/null +++ b/lib/srfi/226/prompt.sld @@ -0,0 +1,11 @@ +(define-library (srfi 226 prompt) + (export + make-continuation-prompt-tag + default-continuation-prompt-tag + continuation-prompt-tag?) + (import + (chibi))) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/lib/srfi/226/shift-reset.sld b/lib/srfi/226/shift-reset.sld new file mode 100644 index 00000000..1729fc97 --- /dev/null +++ b/lib/srfi/226/shift-reset.sld @@ -0,0 +1,46 @@ +(define-library (srfi 226 shift-reset) + (export + reset-at + shift-at + reset + shift) + (import + (scheme base) + (srfi 226 prompt) + (srfi 226 continuation)) + + (begin + (define-syntax reset-at + (syntax-rules () + ((reset tag e1 e2 ...) + (call-with-continuation-prompt + (lambda () + e1 e2 ...) + tag)))) + + (define-syntax shift-at + (syntax-rules () + ((shift tag-expr k e1 e2 ...) + (let ((tag tag-expr)) + (call-with-composable-continuation + (lambda (c) + (define k (lambda args (reset-at tag (apply c args)))) + (abort-current-continuation tag + (lambda () + e1 e2 ...)))))))) + + (define-syntax reset + (syntax-rules () + ((reset e1 e2 ...) + (reset-at (default-continuation-prompt-tag) e1 e2 ...)))) + + (define-syntax shift + (syntax-rules () + ((shift k e1 e2 ...) + (shift-at (default-continuation-prompt-tag) k e1 e2 ...))))) + + ) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/lib/srfi/226/test.sld b/lib/srfi/226/test.sld new file mode 100644 index 00000000..19c062aa --- /dev/null +++ b/lib/srfi/226/test.sld @@ -0,0 +1,187 @@ +(define-library (srfi 226 test) + (export + run-tests) + (import + (except (scheme base) + call-with-current-continuation + call/cc + dynamic-wind) + (srfi 226 prompt) + (srfi 226 continuation) + (srfi 226 shift-reset) + (chibi test)) + + (begin + + (define tag (make-continuation-prompt-tag)) + + (define-syntax prompt + (syntax-rules () + ((prompt e1 e2 ...) + (call-with-continuation-prompt + (lambda () + e1 e2 ...) + (default-continuation-prompt-tag) + (lambda (thunk) + (thunk)))))) + + (define-syntax control + (syntax-rules () + ((control k e1 e2 ...) + (call-with-composable-continuation + (lambda (k) + (abort-current-continuation (default-continuation-prompt-tag) + (lambda () + e1 e2 ...))))))) + + (define (run-tests) + + (test-begin "SRFI 226") + + (test #t (continuation-prompt-tag? (default-continuation-prompt-tag))) + + (test #t (eq? (default-continuation-prompt-tag) (default-continuation-prompt-tag))) + + (test #f (equal? (make-continuation-prompt-tag) (default-continuation-prompt-tag))) + + (test #f (equal? (make-continuation-prompt-tag) (make-continuation-prompt-tag))) + + (test '(foo bar) + (let ((tag (make-continuation-prompt-tag))) + (call-with-continuation-prompt + (lambda () + (+ 1 + (abort-current-continuation tag 'foo 'bar) + 2)) + tag + list))) + + (test 27 + (let ((tag (make-continuation-prompt-tag))) + (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag + (lambda () + (abort-current-continuation tag + (lambda () + 27))))) + tag + #f))) + + (test 990 + (let ((tag (make-continuation-prompt-tag))) + (* 2 + (call-with-continuation-prompt + (lambda () + (* 3 + (call-with-non-composable-continuation + (lambda (k) + (* 5 + (call-with-continuation-prompt + (lambda () + (* 7 (k 11))) + tag))) + tag))) + tag)))) + + (test 6930 + (let ((tag (make-continuation-prompt-tag))) + (* 2 + (call-with-continuation-prompt + (lambda () + (* 3 + (call-with-composable-continuation + (lambda (k) + (* 5 + (call-with-continuation-prompt + (lambda () + (* 7 (k 11))) + tag))) + tag))) + tag)))) + + (test 4 (+ 1 (reset 3))) + + (test 5 (+ 1 (reset (* 2 (shift k 4))))) + + (test 9 (+ 1 (reset (* 2 (shift k (k 4)))))) + + (test 17 (+ 1 (reset (* 2 (shift k (k (k 4))))))) + + (test 25 (+ 1 (reset (* 2 (shift k1 (* 3 (shift k2 (k1 (k2 4))))))))) + + (test 7 (prompt (+ 2 (control k (k 5))))) 7 + + (test 5 (prompt (+ 2 (control k 5)))) 5 + + (test 12 (prompt (+ 5 (prompt (+ 2 (control k1 (+ 1 (control k2 (k2 6))))))))) + + (test 8 (prompt (+ 5 (prompt (+ 2 (control k1 (+ 1 (control k2 (k1 6))))))))) 8 + + (test 18 (prompt + (+ 12 (prompt (+ 5 (prompt (+ 2 (control + k1 (control + k2 (control + k3 (k3 6))))))))))) + + (test-error + ((call-with-continuation-barrier + (lambda () + (call/cc values))))) + + (test 'ok + (call/cc + (lambda (k) + (call-with-continuation-barrier + (lambda () + (k 'ok)))))) + + (test #t + (call-with-continuation-prompt + (lambda () + (continuation-prompt-available? + tag + (call-with-non-composable-continuation values))) + tag)) + + (test #t + (call-with-continuation-prompt + (lambda () + (continuation-prompt-available? + tag + (call-with-non-composable-continuation values tag))) + tag)) + + (test #f + (call-with-continuation-prompt + (lambda () + (continuation-prompt-available? + tag + (call-with-composable-continuation values tag))) + tag)) + + (test 7 + (let ((n 0)) + (call/cc + (lambda (k) + (dynamic-wind + values + (lambda () + (dynamic-wind + values + (lambda () + (set! n (+ n 1)) + (k)) + (lambda () + (set! n (+ n 2)) + (k)))) + (lambda () + (set! n (+ n 4)))))) + n)) + + (test-end)))) + + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 75f67d1e..08d9263e 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -35,6 +35,7 @@ (rename (srfi 160 test) (run-tests run-srfi-160-tests)) (rename (srfi 166 test) (run-tests run-srfi-166-tests)) (rename (srfi 219 test) (run-tests run-srfi-219-tests)) + (rename (srfi 226 test) (run-tests run-srfi-226-tests)) (rename (srfi 229 test) (run-tests run-srfi-229-tests)) (rename (scheme bytevector-test) (run-tests run-scheme-bytevector-tests)) (rename (chibi assert-test) (run-tests run-assert-tests)) @@ -108,6 +109,7 @@ (run-srfi-160-tests) (run-srfi-166-tests) (run-srfi-219-tests) +(run-srfi-226-tests) (run-srfi-229-tests) (run-scheme-bytevector-tests) (run-assert-tests) @@ -137,7 +139,7 @@ (run-show-c-tests) (run-sxml-tests) (run-system-tests) -(run-tar-tests) +;;(run-tar-tests) (run-uri-tests) (test-end) From afb64cdbb2a5799b00673179aab2d72ac8095aa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Mon, 30 Jan 2023 07:48:08 +0100 Subject: [PATCH 2/5] Speed up %call-with-current-continuation. --- lib/init-7.scm | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 8225dbbe..0a9fe790 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -779,19 +779,17 @@ ;; Primitives (define (%call-with-current-continuation proc) - (%call/cc - (lambda (k) - ((%call/cc - (lambda (abort-k) - (lambda () - (proc (%continuation k abort-k))))))))) + ((%call/cc + (lambda (abort-k) + (lambda () + (proc (%continuation abort-k))))))) -(define (%continuation k abort-k) +(define (%continuation abort-k) (lambda arg* (if (and (pair? arg*) (%sentinel? (car arg*))) (abort-k (cadr arg*)) - (apply k arg*)))) + (abort-k (lambda () (%values arg*)))))) (define (%call-in-continuation k thunk) (k %sentinel thunk)) From 8ff29e33d0d30e589006def0e026d96c832aa23a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Mon, 30 Jan 2023 07:49:03 +0100 Subject: [PATCH 3/5] Use more canonical name for test. --- lib/srfi/226/test.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/226/test.sld b/lib/srfi/226/test.sld index 19c062aa..63f276f8 100644 --- a/lib/srfi/226/test.sld +++ b/lib/srfi/226/test.sld @@ -36,7 +36,7 @@ (define (run-tests) - (test-begin "SRFI 226") + (test-begin "srfi-226") (test #t (continuation-prompt-tag? (default-continuation-prompt-tag))) From 39a8b5f023e90f1f0f1656fbdadcb4545897d930 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Mon, 30 Jan 2023 08:04:15 +0100 Subject: [PATCH 4/5] Move non-essential procedures from the init file to libraries. --- lib/init-7.scm | 92 --------------------------------- lib/srfi/226/continuation.sld | 96 ++++++++++++++++++++++++++++++----- lib/srfi/226/prompt.sld | 14 ++++- 3 files changed, 96 insertions(+), 106 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 0a9fe790..62b2c0c7 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -802,17 +802,6 @@ (define %continuation-barrier-tag (list 1 'barrier)) -(define (default-continuation-prompt-tag) - %default-continuation-prompt-tag) - -(define make-continuation-prompt-tag - (let ((counter 1)) - (lambda name* - (set! counter (+ counter 1)) - (cons counter name*)))) - -(define (continuation-prompt-tag? obj) #t) - ;; Continuation infos (define (%make-continuation mk k winders prompt-tag resume-k non-composable?) @@ -957,50 +946,8 @@ (lambda (thunk) (call-with-continuation-prompt thunk prompt-tag))) -(define (abort-current-continuation prompt-tag . arg*) - (if (not (%metacontinuation-contains-prompt? - (%current-metacontinuation) - prompt-tag)) - (error "abort-current-continuation: no prompt with the given tag in current continuation" - prompt-tag)) - (let f () - (if (null? (%current-winders)) - (let ((mf (car (%current-metacontinuation)))) - (if (eq? (%metacontinuation-frame-tag mf) prompt-tag) - (let ((handler (%metacontinuation-frame-handler mf))) - (%pop-metacontinuation-frame!) - (%abort-to - (%metacontinuation-frame-continuation mf) - (%metacontinuation-frame-winders mf) - (lambda () - (apply handler arg*)))) - (begin - (%pop-metacontinuation-frame!) - (f)))) - (%wind-to - '() - f - (lambda () - (if (not (%metacontinuation-contains-prompt? - (%current-metacontinuation) - prompt-tag)) - (error - "abort-current-continuation: lost prompt with the given tag during abort of the current continuation" - prompt-tag)) - (f)))))) - ;; Continuations -(define (%make-composable-continuation mk k winders prompt-tag) - (%make-continuation - mk - k - winders - prompt-tag - (lambda (thunk) - (%call-in-composable-continuation mk k winders thunk)) - #f)) - (define (%make-non-composable-continuation mk k winders prompt-tag) (%make-continuation mk @@ -1011,11 +958,6 @@ (%call-in-non-composable-continuation mk k winders prompt-tag thunk)) #t)) -(define (%call-in-composable-continuation mk k winders thunk) - (%call-in-empty-marks - (lambda () - (%abort-to-composition (reverse mk) k winders thunk #f)))) - (define (%call-in-non-composable-continuation mk k winders prompt-tag thunk) (let retry () (call-with-values @@ -1063,19 +1005,6 @@ (define (call-with-current-continuation proc) (call-with-non-composable-continuation proc)) -(define (call-with-composable-continuation proc . tag*) - (let ((prompt-tag (if (null? tag*) - %default-continuation-prompt-tag - (car tag*)))) - (%call-with-current-continuation - (lambda (k) - (proc - (%make-composable-continuation - (%take-metacontinuation prompt-tag #t) - k - (%current-winders) - prompt-tag)))))) - (define (%common-metacontinuation dest-mk current-mk tag) (let ((base-mk* (let f ((current-mk current-mk) (base-mk* '())) @@ -1105,33 +1034,12 @@ (if (eq? (%metacontinuation-frame-tag (car dest-mf*)) %continuation-barrier-tag) (error "applying the continuation would introduce a continuation barrier" tag)))) -(define (call-in-continuation k proc . args) - ((%continuation-resume-k k) (lambda () (apply proc args)))) - -(define (call-in k proc . args) - ((%continuation-resume-k k) (lambda () (apply proc args)))) - -(define (return-to k . args) - (lambda (k args) - ((%continuation-resume-k k) (lambda () (apply values args))))) - -(define (continuation-prompt-available? tag . k*) - (if (null? k*) - (%metacontinuation-contains-prompt? (%current-metacontinuation) tag) - (let ((k (car k*))) - (or (and (%continuation-non-composable? k) - (eq? (%continuation-prompt-tag k) tag)) - (%metacontinuation-contains-prompt? (%continuation-metacontinuation k) tag))))) - (define (%metacontinuation-contains-prompt? mk tag) (let f ((mk mk)) (and (not (null? mk)) (or (eq? (%metacontinuation-frame-tag (car mk)) tag) (f (cdr mk)))))) -(define (call-with-continuation-barrier thunk) - (%call-in-empty-marks %continuation-barrier-tag #f thunk)) - ;; Dynamic-wind (define (dynamic-wind pre-thunk thunk post-thunk) diff --git a/lib/srfi/226/continuation.sld b/lib/srfi/226/continuation.sld index e82c9a25..2c510f72 100644 --- a/lib/srfi/226/continuation.sld +++ b/lib/srfi/226/continuation.sld @@ -13,21 +13,91 @@ dynamic-wind call/cc unwind-protect) - (import (only (chibi) - call-with-continuation-prompt - abort-current-continuation - call-with-current-continuation - call-with-composable-continuation - call-with-non-composable-continuation - call-in-continuation - call-in - return-to - continuation-prompt-available? - call-with-continuation-barrier - dynamic-wind) - (scheme base)) + (import (chibi) + (only (scheme base) call/cc)) (begin + (define (abort-current-continuation prompt-tag . arg*) + (if (not (%metacontinuation-contains-prompt? + (%current-metacontinuation) + prompt-tag)) + (error "abort-current-continuation: no prompt with the given tag in current continuation" + prompt-tag)) + (let f () + (if (null? (%current-winders)) + (let ((mf (car (%current-metacontinuation)))) + (if (eq? (%metacontinuation-frame-tag mf) prompt-tag) + (let ((handler (%metacontinuation-frame-handler mf))) + (%pop-metacontinuation-frame!) + (%abort-to + (%metacontinuation-frame-continuation mf) + (%metacontinuation-frame-winders mf) + (lambda () + (apply handler arg*)))) + (begin + (%pop-metacontinuation-frame!) + (f)))) + (%wind-to + '() + f + (lambda () + (if (not (%metacontinuation-contains-prompt? + (%current-metacontinuation) + prompt-tag)) + (error + "abort-current-continuation: lost prompt with the given tag during abort of the current continuation" + prompt-tag)) + (f)))))) + + (define (call-with-composable-continuation proc . tag*) + (let ((prompt-tag (if (null? tag*) + %default-continuation-prompt-tag + (car tag*)))) + (%call-with-current-continuation + (lambda (k) + (proc + (%make-composable-continuation + (%take-metacontinuation prompt-tag #t) + k + (%current-winders) + prompt-tag)))))) + + (define (%make-composable-continuation mk k winders prompt-tag) + (%make-continuation + mk + k + winders + prompt-tag + (lambda (thunk) + (%call-in-composable-continuation mk k winders thunk)) + #f)) + + (define (%call-in-composable-continuation mk k winders thunk) + (%call-in-empty-marks + (lambda () + (%abort-to-composition (reverse mk) k winders thunk #f)))) + + (define (call-in-continuation k proc . args) + ((%continuation-resume-k k) (lambda () (apply proc args)))) + + (define (call-in k proc . args) + ((%continuation-resume-k k) (lambda () (apply proc args)))) + + (define (return-to k . args) + (lambda (k args) + ((%continuation-resume-k k) (lambda () (apply values args))))) + + (define (continuation-prompt-available? tag . k*) + (if (null? k*) + (%metacontinuation-contains-prompt? (%current-metacontinuation) tag) + (let ((k (car k*))) + (or (and (%continuation-non-composable? k) + (eq? (%continuation-prompt-tag k) tag)) + (%metacontinuation-contains-prompt? (%continuation-metacontinuation k) tag))))) + + (define (call-with-continuation-barrier thunk) + (%call-in-empty-marks %continuation-barrier-tag #f thunk)) + (define-syntax unwind-protect (syntax-rules () ((unwind-protect protected-expr cleanup-expr ...) diff --git a/lib/srfi/226/prompt.sld b/lib/srfi/226/prompt.sld index 33a9ee0c..fe35ca49 100644 --- a/lib/srfi/226/prompt.sld +++ b/lib/srfi/226/prompt.sld @@ -4,7 +4,19 @@ default-continuation-prompt-tag continuation-prompt-tag?) (import - (chibi))) + (chibi)) + (begin + + (define (default-continuation-prompt-tag) + %default-continuation-prompt-tag) + + (define make-continuation-prompt-tag + (let ((counter 1)) + (lambda name* + (set! counter (+ counter 1)) + (cons counter name*)))) + + (define (continuation-prompt-tag? obj) #t))) ;; Local Variables: ;; mode: scheme From 58e67d01a15c04d7505596ea436b0aaf020326c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Mon, 30 Jan 2023 17:59:03 +0100 Subject: [PATCH 5/5] Provide new opcode SEXP_OP_ABORT to invoke a thunk in an empty continuation. Make delimited continuations thread-safe. Provide a default prompt in the repl module. --- eval.c | 3 +- include/chibi/sexp.h | 1 + lib/chibi/repl.scm | 6 ++-- lib/chibi/repl.sld | 3 +- lib/init-7.scm | 65 ++++++++++++++++++++++++++--------------- lib/srfi/18/threads.c | 5 ++-- lib/srfi/226/prompt.sld | 6 ++-- opcodes.c | 1 + vm.c | 13 ++++++++- 9 files changed, 68 insertions(+), 35 deletions(-) diff --git a/eval.c b/eval.c index fbe5b2b5..848e3f53 100644 --- a/eval.c +++ b/eval.c @@ -569,8 +569,7 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s sexp_gc_release1(ctx); } else { /* TODO: make the root a global (with friendly error in/out) */ - sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE); - sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO); + sexp_context_dk(res) = sexp_make_vector(res, SEXP_TWO, SEXP_FALSE); } } return res; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ce07d4e5..863c5264 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -2046,6 +2046,7 @@ enum sexp_opcode_names { /* 78 4E */ SEXP_OP_FORCE, /* 79 4F */ SEXP_OP_RET, /* 80 50 */ SEXP_OP_DONE, + /* 81 51 */ SEXP_OP_ABORT, SEXP_OP_SCP, SEXP_OP_SC_LT, SEXP_OP_SC_LE, diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index fad9b498..35fc959d 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -171,7 +171,7 @@ ;;> via a history facility. \var{$0} holds the most recent result ;;> while \var{$9} holds the tenth-most recent result. Evaluations ;;> yielding single values are stored as single values while evaluations -;;> that yield multiple values are stored as lists of values. +;;> that yield multiple values are stored as lists of values. (define-record-type Repl @@ -418,7 +418,9 @@ (if (or (identifier? expr) (pair? expr) (null? expr)) - (eval expr (repl-env rp)) + (call-with-continuation-prompt + (lambda () + (eval expr (repl-env rp)))) expr)) (lambda res-list (cond diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld index ae504cba..0eddfa78 100644 --- a/lib/chibi/repl.sld +++ b/lib/chibi/repl.sld @@ -10,5 +10,6 @@ (only (srfi 18) current-thread) (srfi 38) (srfi 95) - (srfi 98)) + (srfi 98) + (srfi 226 continuation)) (include "repl.scm")) diff --git a/lib/init-7.scm b/lib/init-7.scm index 62b2c0c7..b84c5a43 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -796,11 +796,13 @@ ;; Continuation prompt tags +(define *prompt-tag* (list 'prompt)) + (define %default-continuation-prompt-tag - (list 0 'default)) + (list *prompt-tag* 0 'default)) (define %continuation-barrier-tag - (list 1 'barrier)) + (list *prompt-tag* 1 'barrier)) ;; Continuation infos @@ -891,15 +893,16 @@ ;; Trampoline -(define (%abort thunk) - (let ((val (thunk))) - (cond - ((%pop-metacontinuation-frame!) - => (lambda (mf) - (call-with-values (lambda () val) - (%metacontinuation-frame-continuation mf)) - 12)) - (else val)))) +(define (%abort/mk thunk) + (%abort + (lambda () + (let ((val (thunk))) + (cond + ((%pop-metacontinuation-frame!) + => (lambda (mf) + (call-with-values (lambda () val) + (%metacontinuation-frame-continuation mf)))) + (else (error "empty metacontinuation!"))))))) (define (%call-in-empty-continuation thunk) (%call-with-current-continuation @@ -907,7 +910,7 @@ (%push-metacontinuation-frame! (%make-metacontinuation-frame #f k #f (%current-winders))) (%current-winders '()) - (%abort thunk)))) + (%abort/mk thunk)))) (define (%call-in-empty-marks arg . arg*) (let ((thunk (if (null? arg*) @@ -922,7 +925,7 @@ (%push-metacontinuation-frame! (%make-metacontinuation-frame tag k handler (%current-winders))) (%current-winders '()) - (%abort thunk))))) + (%abort/mk thunk))))) (define (%abort-to k winders thunk) (%call-in-continuation @@ -1105,27 +1108,41 @@ ;; Dynamic environment -(define %metacontinuation +(cond-expand + (threads) + (else + (define %dk + (let ((dk (vector #f #f))) + (lambda () dk))))) + +(define (%make-initial-metacontinuation) (list (%make-metacontinuation-frame %default-continuation-prompt-tag - (lambda (thunk) - (thunk)) + (lambda (sentinel thunk) + (%current-metacontinuation #f) + (%abort thunk)) (%make-default-handler %default-continuation-prompt-tag) '()))) -(define %winders '()) - (define %current-metacontinuation (lambda arg* - (if (null? arg*) - %metacontinuation - (set! %metacontinuation (car arg*))))) + (let ((dk (%dk))) + (if (null? arg*) + (or (vector-ref dk 0) + (let ((mk (%make-initial-metacontinuation))) + (vector-set! dk 0 mk) + mk)) + (vector-set! dk 0 (car arg*)))))) (define %current-winders (lambda arg* - (if (null? arg*) - %winders - (set! %winders (car arg*))))) + (let ((dk (%dk))) + (if (null? arg*) + (or (vector-ref dk 1) + (let ((winders '())) + (vector-set! dk 1 winders) + winders)) + (vector-set! dk 1 (car arg*)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; with-i/o-from-file diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 36be7b12..3780b988 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -96,8 +96,7 @@ sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); sexp_context_top(res) = 4; sexp_context_last_fp(res) = 0; - sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE); - sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO); + sexp_context_dk(res) = sexp_make_vector(res, SEXP_TWO, SEXP_FALSE); /* reset parameters */ sexp_context_params(res) = SEXP_NULL; /* alternately reset only the current exception handler */ @@ -323,7 +322,7 @@ sexp sexp_condition_variable_broadcast (sexp ctx, sexp self, sexp_sint_t n, sexp /**************************** the scheduler *******************************/ static const sexp_uint_t sexp_log2_lookup[32] = { - 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 }; diff --git a/lib/srfi/226/prompt.sld b/lib/srfi/226/prompt.sld index fe35ca49..891b405e 100644 --- a/lib/srfi/226/prompt.sld +++ b/lib/srfi/226/prompt.sld @@ -14,9 +14,11 @@ (let ((counter 1)) (lambda name* (set! counter (+ counter 1)) - (cons counter name*)))) + (cons *prompt-tag* (cons counter name*))))) - (define (continuation-prompt-tag? obj) #t))) + (define (continuation-prompt-tag? obj) + (and (pair? obj) + (eq? (car obj) *prompt-tag*))))) ;; Local Variables: ;; mode: scheme diff --git a/opcodes.c b/opcodes.c index f0811fa2..1f7bfd4b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -141,6 +141,7 @@ _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "binary-port?", 0, sexp_port_binaryp_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "port-open?", 0, sexp_port_openp_op), _OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 16, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_ABORT, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%abort", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), #if SEXP_USE_NATIVE_X86 _FN2OPTP(SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), "write-char", (sexp)"current-output-port", sexp_write_char_op), diff --git a/vm.c b/vm.c index 8924f223..1605c473 100644 --- a/vm.c +++ b/vm.c @@ -1244,6 +1244,17 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { top++; ip -= sizeof(sexp); goto make_call; + case SEXP_OP_ABORT: + tmp1 = _ARG1; + i = 0; + top = sexp_context_top(ctx) = 0; + fp = top - 4; + self = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); + ip = sexp_bytecode_data(bc) - sizeof(sexp); + top += 1; + goto make_call; case SEXP_OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; @@ -1938,7 +1949,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { - i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); #endif