home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / COMPOSE-.S < prev    next >
Text File  |  1992-06-17  |  1KB  |  41 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5.  
  6. (define (compose-continuation proc cont)
  7.   (primitive-catch
  8.     (lambda (k)
  9.       (with-continuation (if cont cont null-continuation)
  10.         (lambda ()
  11.           (proc (primitive-catch
  12.                   (lambda (k2) (with-continuation k (lambda () k2))))))))))
  13.  
  14. ;(define null-continuation #f)
  15.  
  16. (define null-continuation (make-continuation 4 #f)) ;temp kludge
  17. (continuation-set! null-continuation 1 0)
  18. (continuation-set! null-continuation 2
  19.            (make-template (make-code-vector 1 140) #f '())) ;op/trap
  20.  
  21. ;(put 'primitive-catch 'scheme-indent-hook 0)
  22. ;(put 'with-continuation 'scheme-indent-hook 1)
  23.  
  24. ;(define compose-continuation
  25. ;  (let ((tem
  26. ;         (let ((cv (make-code-vector 6 0)))
  27. ;           (code-vector-set! cv 0 op/push) ;push return value
  28. ;           (code-vector-set! cv 1 op/local) ;fetch procedure
  29. ;           (code-vector-set! cv 3 1)    ;over = 1
  30. ;           (code-vector-set! cv 4 op/call)
  31. ;           (code-vector-set! cv 5 1)    ;one argument
  32. ;           (make-template cv 0 '()))))
  33. ;    (lambda (proc parent-cont)
  34. ;      (let ((cont (make-continuation 4 #f)))
  35. ;        (continuation-set! cont 0 parent-cont)
  36. ;        (continuation-set! cont 1 0)    ;pc
  37. ;        (continuation-set! cont 2 tem)  ;template
  38. ;        (continuation-set! cont 3 (vector #f proc)) ;environment
  39. ;        cont))))
  40.  
  41.