diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index a89f2fa..16419c9 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -598,9 +598,8 @@ (fid (current-facet-id))) (lambda args (with-current-facet fid field-table #t - (call-with-continuation-prompt - (lambda () (apply proc args)) - prompt-tag))))) + (call-with-syndicate-effects + (lambda () (apply proc args))))))) (define (schedule-script! #:priority [priority *normal-priority*] terminal? thunk) (if terminal? @@ -727,7 +726,7 @@ ;; children's stop-scripts run before ours. (with-current-facet fid (facet-field-table f) #t (for [(script (in-list (reverse (facet-stop-scripts f))))] - (call-with-continuation-prompt script prompt-tag))) + (call-with-syndicate-effects script))) f))) @@ -823,6 +822,15 @@ (define (syndicate-effects-available?) (continuation-prompt-available? prompt-tag)) +(define (call-with-syndicate-effects thunk) + (call-with-continuation-prompt thunk prompt-tag)) + +(module+ for-module-begin + (provide call-with-syndicate-effects + flush-pending-patch! + current-pending-actions + current-pending-patch)) + (define (suspend-script* where proc) (when (not (in-script?)) (error 'suspend-script diff --git a/racket/syndicate/lang.rkt b/racket/syndicate/lang.rkt index 9560f48..d6451e2 100644 --- a/racket/syndicate/lang.rkt +++ b/racket/syndicate/lang.rkt @@ -4,6 +4,7 @@ (require racket/match) (require "main.rkt") +(require (submod "actor.rkt" for-module-begin)) (provide (rename-out [module-begin #%module-begin]) activate @@ -74,6 +75,16 @@ (define (accumulate-action action action-ids final-forms remaining-forms) (define temp (car (generate-temporaries (list action)))) (accumulate-actions (cons temp action-ids) - (cons #`(define #,temp #,action) final-forms) + (cons #`(define #,temp (capture-actor-actions (lambda () #,action))) + final-forms) remaining-forms)) (accumulate-actions '() '() (syntax->list #'(forms ...))))])) + +(define (capture-actor-actions thunk) + (call-with-syndicate-effects + (lambda () + (parameterize ((current-pending-actions '()) + (current-pending-patch patch-empty)) + (define result (thunk)) + (flush-pending-patch!) + (cons result (current-pending-actions))))))