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 / compiler / base / contin.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  108 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: contin.scm,v 4.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 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. ;;;; Continuation datatype
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;; Continuations are a subtype of procedures, whose `type' is
  27. ;;; something other than PROCEDURE.
  28.  
  29. (define (make-continuation block continuation type)
  30.   continuation
  31.   (let ((block (make-block block 'CONTINUATION)))
  32.     (let ((required (list (make-value-variable block))))
  33.       (set-block-bound-variables! block required)
  34.       (make-procedure type block 'CONTINUATION required '() false '() '()
  35.               (snode->scfg (make-fg-noop))))))
  36.  
  37. (define-enumeration continuation-type
  38.   (effect predicate procedure push register value))
  39.  
  40. (define-integrable (procedure-continuation? procedure)
  41.   (not (eq? (procedure-type procedure) continuation-type/procedure)))
  42.  
  43. (define (rvalue/continuation? rvalue)
  44.   (and (rvalue/procedure? rvalue)
  45.        (procedure-continuation? rvalue)))
  46.  
  47. (define-integrable continuation/type procedure-type)
  48. (define-integrable set-continuation/type! set-procedure-type!)
  49. (define-integrable continuation/block procedure-block)
  50. (define-integrable continuation/closing-block procedure-closing-block)
  51. (define-integrable continuation/entry-node procedure-entry-node)
  52. (define-integrable set-continuation/entry-node! set-procedure-entry-node!)
  53. (define-integrable continuation/combinations procedure-original-rest)
  54. (define-integrable set-continuation/combinations! set-procedure-original-rest!)
  55. (define-integrable continuation/label procedure-label)
  56. (define-integrable continuation/returns procedure-applications)
  57. (define-integrable set-continuation/returns! set-procedure-applications!)
  58. (define-integrable continuation/ever-known-operator?
  59.   procedure-always-known-operator?)
  60. (define-integrable continuation/offset procedure-closure-offset)
  61. (define-integrable set-continuation/offset! set-procedure-closure-offset!)
  62. (define-integrable continuation/passed-out? procedure-passed-out?)
  63. (define-integrable set-continuation/passed-out?! set-procedure-passed-out?!)
  64. (define-integrable continuation/debugging-info procedure-debugging-info)
  65. (define-integrable set-continuation/debugging-info!
  66.   set-procedure-debugging-info!)
  67.  
  68. (define (continuation/register continuation)
  69.   (or (procedure-register continuation)
  70.       (let ((register (rtl:make-pseudo-register)))
  71.     (set-procedure-register! continuation register)
  72.     register)))
  73.  
  74. (define-integrable (continuation/always-known-operator? continuation)
  75.   (eq? (continuation/ever-known-operator? continuation) 'ALWAYS))
  76.  
  77. (define-integrable (continuation/parameter continuation)
  78.   (car (procedure-original-required continuation)))
  79.  
  80. (define-integrable return-operator/subproblem? rvalue/procedure?)
  81. (define-integrable return-operator/reduction? rvalue/reference?)
  82. (define-integrable reduction-continuation/lvalue reference-lvalue)
  83.  
  84. (define (continuation/frame-size continuation)
  85.   (let ((closing-block (continuation/closing-block continuation)))
  86.     (+ (if (ic-block? closing-block) 1 0)
  87.        (if (and (stack-block? closing-block)
  88.         (stack-block/dynamic-link? closing-block))
  89.        1
  90.        0)
  91.        (if (continuation/always-known-operator? continuation)
  92.        0
  93.        1))))
  94.  
  95. (define (uni-continuation? rvalue)
  96.   (and (rvalue/procedure? rvalue)
  97.        (procedure-arity-correct? rvalue 1)))
  98.  
  99. (define-integrable (uni-continuation/parameter continuation)
  100.   (car (procedure-original-required continuation)))
  101.  
  102. (define (delete-continuation/combination! continuation combination)
  103.   (let ((combinations
  104.      (delq! combination (continuation/combinations continuation))))
  105.     (set-continuation/combinations! continuation combinations)
  106.     (if (and (null? combinations)
  107.          (null? (continuation/returns continuation)))
  108.     (set-procedure-always-known-operator?! continuation false))))