#| -*-Scheme-*-
-$Id: contin.scm,v 14.13 2005/03/29 05:00:26 cph Exp $
+$Id: contin.scm,v 14.14 2005/07/16 03:44:12 cph Exp $
Copyright 1988,1989,1991,1992,1999,2005 Massachusetts Institute of Technology
;;; package: (runtime continuation)
(declare (usual-integrations))
-\f
+
(define (call-with-current-continuation receiver)
- (call/cc (ucode-primitive call-with-current-continuation 1)
- 'REENTRANT
- receiver))
-
-;;; The following is not properly tail recursive because it builds the
-;;; extra frame that invokes cont on the result. This is done to
-;;; guarantee that the continuation is still valid, since the
-;;; continuation invocation code is the code that maintains this
-;;; state. Note that any other way of verifying this information
-;;; would also add a continuation frame to the stack!
-
-(define (non-reentrant-call-with-current-continuation receiver)
- (call/cc (ucode-primitive non-reentrant-call-with-current-continuation 1)
- 'UNUSED
- (lambda (cont) (cont (receiver cont)))))
-
-(define (call/cc primitive type receiver)
- (primitive
+ ((ucode-primitive call-with-current-continuation 1)
(lambda (control-point)
- (let ((continuation
- (make-continuation type
- control-point
+ (let ((k
+ (make-continuation control-point
(get-dynamic-state)
(get-thread-event-block))))
- (%%within-continuation
- continuation
- (lambda () (receiver continuation)))))))
+ (%within-continuation k (lambda () (receiver k)))))))
+
+(define (within-continuation k thunk)
+ (guarantee-continuation k 'WITHIN-CONTINUATION)
+ (%within-continuation k thunk))
+
+(define (make-continuation control-point dynamic-state block-thread-events?)
+ (make-entity (lambda (k value) (%within-continuation k (lambda () value)))
+ (make-%continuation control-point
+ dynamic-state
+ block-thread-events?)))
-(define-integrable (%%within-continuation continuation thunk)
+(define-integrable (%within-continuation k thunk)
((ucode-primitive within-control-point 2)
- (continuation/control-point continuation)
- thunk))
-
-(define (%within-continuation continuation thread-switch? thunk)
- (%%within-continuation
- continuation
- (let ((restore-state (state-restoration-procedure continuation)))
- (lambda ()
- (restore-state thread-switch?)
- (thunk)))))
-
-(define (invocation-method/reentrant continuation value)
- (%%within-continuation
- continuation
- (let ((restore-state (state-restoration-procedure continuation)))
- (lambda ()
- (restore-state #f)
- value))))
-
-(define (state-restoration-procedure continuation)
- (let ((dynamic-state (continuation/dynamic-state continuation))
- (block-thread-events?
- (continuation/block-thread-events? continuation)))
- (lambda (thread-switch?)
- (set-dynamic-state! dynamic-state thread-switch?)
- (set-thread-event-block! block-thread-events?))))
-\f
-;;; These two are correctly locked for multiprocessing, but not for
-;;; multiprocessors.
-
-(define (within-continuation continuation thunk)
- (if (not (continuation? continuation))
- (error:wrong-type-argument continuation "continuation"
- 'WITHIN-CONTINUATION))
- (if (without-interrupts
- (lambda ()
- (let ((method (continuation/invocation-method continuation)))
- (if (eq? method invocation-method/reentrant)
- #t
- (and (eq? method invocation-method/unused)
- (begin
- (set-continuation/invocation-method!
- continuation
- invocation-method/used)
- #t))))))
- (%within-continuation continuation #f thunk)
- (error "Reentering used continuation" continuation)))
-
-(define (invocation-method/unused continuation value)
- (if (eq? (without-interrupts
- (lambda ()
- (let ((method (continuation/invocation-method continuation)))
- (set-continuation/invocation-method! continuation
- invocation-method/used)
- method)))
- invocation-method/unused)
- (invocation-method/reentrant continuation value)
- (invocation-method/used continuation value)))
-
-(define (invocation-method/used continuation value)
- value
- (error "Reentering used continuation" continuation))
-\f
-(define (make-continuation type control-point dynamic-state
- block-thread-events?)
- (make-entity
- (case type
- ((REENTRANT) invocation-method/reentrant)
- ((UNUSED) invocation-method/unused)
- ((USED) invocation-method/used)
- (else (error "Illegal continuation type" type)))
- (make-%continuation control-point dynamic-state block-thread-events?)))
-
-(define (continuation/type continuation)
- (let ((invocation-method (continuation/invocation-method continuation)))
- (cond ((eq? invocation-method invocation-method/reentrant) 'REENTRANT)
- ((eq? invocation-method invocation-method/unused) 'UNUSED)
- ((eq? invocation-method invocation-method/used) 'USED)
- (else (error "Illegal invocation-method" invocation-method)))))
+ (continuation/control-point k)
+ (lambda ()
+ (set-dynamic-state! (continuation/dynamic-state k) #f)
+ (set-thread-event-block! (continuation/block-thread-events? k))
+ (thunk))))
(define (continuation? object)
(and (entity? object)
(define-guarantee continuation "continuation")
-(define-integrable (continuation/invocation-method continuation)
- (entity-procedure continuation))
-
-(define-integrable (set-continuation/invocation-method! continuation method)
- (set-entity-procedure! continuation method))
-
-(define-integrable (continuation/control-point continuation)
- (%continuation/control-point (entity-extra continuation)))
+(define-integrable (continuation/control-point k)
+ (%continuation/control-point (entity-extra k)))
-(define-integrable (continuation/dynamic-state continuation)
- (%continuation/dynamic-state (entity-extra continuation)))
+(define-integrable (continuation/dynamic-state k)
+ (%continuation/dynamic-state (entity-extra k)))
-(define-integrable (continuation/block-thread-events? continuation)
- (%continuation/block-thread-events? (entity-extra continuation)))
+(define-integrable (continuation/block-thread-events? k)
+ (%continuation/block-thread-events? (entity-extra k)))
(define-structure (%continuation (constructor make-%continuation)
(conc-name %continuation/))
projects / mit-scheme.git / commitdiff