home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / contin.scm < prev    next >
Text File  |  1999-02-23  |  6KB  |  168 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: contin.scm,v 14.10 1999/02/24 04:44:04 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Continuations
  23. ;;; package: (runtime continuation)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (call-with-current-continuation receiver)
  28.   (call/cc (ucode-primitive call-with-current-continuation 1)
  29.        'REENTRANT
  30.        receiver))
  31.  
  32. ;;; The following is not properly tail recursive because it builds the
  33. ;;; extra frame that invokes cont on the result.  This is done to
  34. ;;; guarantee that the continuation is still valid, since the
  35. ;;; continuation invocation code is the code that maintains this
  36. ;;; state.  Note that any other way of verifying this information
  37. ;;; would also add a continuation frame to the stack!
  38.  
  39. (define (non-reentrant-call-with-current-continuation receiver)
  40.   (call/cc (ucode-primitive non-reentrant-call-with-current-continuation 1)
  41.        'UNUSED
  42.        (lambda (cont) (cont (receiver cont)))))
  43.  
  44. (define (call/cc primitive type receiver)
  45.   (primitive
  46.    (lambda (control-point)
  47.      (let ((continuation
  48.         (make-continuation type
  49.                    control-point
  50.                    (get-dynamic-state)
  51.                    (get-thread-event-block))))
  52.        (%%within-continuation
  53.     continuation
  54.     (lambda () (receiver continuation)))))))
  55.  
  56. (define-integrable (%%within-continuation continuation thunk)
  57.   ((ucode-primitive within-control-point 2)
  58.    (continuation/control-point continuation)
  59.    thunk))
  60.  
  61. (define (%within-continuation continuation thread-switch? thunk)
  62.   (%%within-continuation
  63.    continuation
  64.    (let ((restore-state (state-restoration-procedure continuation)))
  65.      (lambda ()
  66.        (restore-state thread-switch?)
  67.        (thunk)))))
  68.  
  69. (define (invocation-method/reentrant continuation value)
  70.   (%%within-continuation
  71.    continuation
  72.    (let ((restore-state (state-restoration-procedure continuation)))
  73.      (lambda ()
  74.        (restore-state #f)
  75.        value))))
  76.  
  77. (define (state-restoration-procedure continuation)
  78.   (let ((dynamic-state (continuation/dynamic-state continuation))
  79.     (block-thread-events?
  80.      (continuation/block-thread-events? continuation)))
  81.     (lambda (thread-switch?)
  82.       (set-dynamic-state! dynamic-state thread-switch?)
  83.       (set-thread-event-block! block-thread-events?))))
  84.  
  85. ;;; These two are correctly locked for multiprocessing, but not for
  86. ;;; multiprocessors.
  87.  
  88. (define (within-continuation continuation thunk)
  89.   (if (not (continuation? continuation))
  90.       (error:wrong-type-argument continuation "continuation"
  91.                  'WITHIN-CONTINUATION))
  92.   (if (without-interrupts
  93.        (lambda ()
  94.      (let ((method (continuation/invocation-method continuation)))
  95.        (if (eq? method invocation-method/reentrant)
  96.            #t
  97.            (and (eq? method invocation-method/unused)
  98.             (begin
  99.               (set-continuation/invocation-method!
  100.                continuation
  101.                invocation-method/used)
  102.               #t))))))
  103.       (%within-continuation continuation #f thunk)
  104.       (error "Reentering used continuation" continuation)))
  105.  
  106. (define (invocation-method/unused continuation value)
  107.   (if (eq? (without-interrupts
  108.         (lambda ()
  109.           (let ((method (continuation/invocation-method continuation)))
  110.         (set-continuation/invocation-method! continuation
  111.                              invocation-method/used)
  112.         method)))
  113.        invocation-method/unused)
  114.       (invocation-method/reentrant continuation value)
  115.       (invocation-method/used continuation value)))
  116.  
  117. (define (invocation-method/used continuation value)
  118.   value
  119.   (error "Reentering used continuation" continuation))
  120.  
  121. (define (make-continuation type control-point dynamic-state
  122.                block-thread-events?)
  123.   (make-entity
  124.    (case type
  125.      ((REENTRANT) invocation-method/reentrant)
  126.      ((UNUSED) invocation-method/unused)
  127.      ((USED) invocation-method/used)
  128.      (else (error "Illegal continuation type" type)))
  129.    (make-%continuation control-point dynamic-state block-thread-events?)))
  130.  
  131. (define (continuation/type continuation)
  132.   (let ((invocation-method (continuation/invocation-method continuation)))
  133.     (cond ((eq? invocation-method invocation-method/reentrant) 'REENTRANT)
  134.       ((eq? invocation-method invocation-method/unused) 'UNUSED)
  135.       ((eq? invocation-method invocation-method/used) 'USED)
  136.       (else (error "Illegal invocation-method" invocation-method)))))
  137.  
  138. (define (continuation? object)
  139.   (and (entity? object)
  140.        (if (%continuation? (entity-extra object))
  141.        #t
  142.        (continuation? (entity-procedure object)))))
  143.  
  144. (define (guarantee-continuation continuation)
  145.   (if (not (continuation? continuation))
  146.       (error:wrong-type-argument continuation "continuation" #f))
  147.   continuation)
  148.  
  149. (define-integrable (continuation/invocation-method continuation)
  150.   (entity-procedure continuation))
  151.  
  152. (define-integrable (set-continuation/invocation-method! continuation method)
  153.   (set-entity-procedure! continuation method))
  154.  
  155. (define-integrable (continuation/control-point continuation)
  156.   (%continuation/control-point (entity-extra continuation)))
  157.  
  158. (define-integrable (continuation/dynamic-state continuation)
  159.   (%continuation/dynamic-state (entity-extra continuation)))
  160.  
  161. (define-integrable (continuation/block-thread-events? continuation)
  162.   (%continuation/block-thread-events? (entity-extra continuation)))
  163.  
  164. (define-structure (%continuation (constructor make-%continuation)
  165.                  (conc-name %continuation/))
  166.   (control-point #f read-only #t)
  167.   (dynamic-state #f read-only #t)
  168.   (block-thread-events? #f read-only #t))