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 / improvements / comcon.scm next >
Text File  |  2000-03-20  |  3KB  |  70 lines
  1. ;;; This alternative version of `combination/constant!' attempts to
  2. ;;; keep the data structures more consistent.  It doesn't seem to be
  3. ;;; needed yet.
  4.  
  5. (define (combination/constant! combination rvalue)
  6.   (let ((continuation (combination/continuation combination)))
  7.     (for-each (lambda (continuation)
  8.         (set-continuation/combinations!
  9.          continuation
  10.          (delq! combination (continuation/combinations continuation)))
  11.         (set-continuation/returns!
  12.          continuation
  13.          (cons combination (continuation/returns continuation))))
  14.           (rvalue-values continuation))
  15.     (for-each (lambda (operator)
  16.         (if (rvalue/procedure? operator)
  17.             (delete-procedure-application! operator combination)))
  18.           (rvalue-values (combination/operator combination)))
  19.     (maybe-kill-application-procedure! combination)
  20.     (set-application-type! combination 'RETURN)
  21.     (set-application-operator! combination continuation)
  22.     (set-application-operands! combination (list rvalue))
  23.     (let ((push (combination/continuation-push combination)))
  24.       (if (and push (rvalue-known-value continuation))
  25.       (set-virtual-continuation/type! (virtual-return-operator push)
  26.                       continuation-type/effect)))))
  27.  
  28. (define (maybe-kill-application-procedure! application)
  29.   (let ((operator (rvalue-known-value (application-operator application))))
  30.     (if (and operator
  31.          (rvalue/procedure? operator)
  32.          (procedure-always-known-operator? operator)
  33.          (null? (procedure-applications operator)))
  34.     (kill-procedure! operator))))
  35.  
  36. (define (kill-procedure! procedure)
  37.   (set! *procedures* (delq! procedure *procedures*))
  38.   (let ((block (procedure-block procedure)))
  39.     (set! *blocks* (delq! block *blocks*))
  40.     (let ((parent (block-parent block)))
  41.       (set-block-children! parent (delq! block (block-children parent))))
  42.     ;; This should probably be accomplished by a codewalk, but for
  43.     ;; current purposes it's adequate.
  44.     (for-each kill-application! (block-applications block))))
  45.  
  46. (define (kill-application! application)
  47.   (set! *applications* (delq! application *applications*))
  48.   (for-each (lambda (operator)
  49.           (if (rvalue/procedure? operator)
  50.           (delete-procedure-application! operator application)))
  51.         (rvalue-values (application-operator application)))
  52.   (if (application/combination? application)
  53.       (for-each (lambda (continuation)
  54.           (delete-continuation/combination! continuation application))
  55.         (rvalue-values (combination/continuation application))))
  56.   (maybe-kill-application-procedure! application))
  57.  
  58. (define (delete-procedure-application! procedure combination)
  59.   (let ((applications (delq! combination (procedure-applications procedure))))
  60.     (set-procedure-applications! procedure applications)
  61.     (if (null? applications)
  62.     (set-procedure-always-known-operator?! procedure false))))
  63.  
  64. (define (delete-continuation/combination! continuation combination)
  65.   (let ((combinations
  66.      (delq! combination (continuation/combinations continuation))))
  67.     (set-continuation/combinations! continuation combinations)
  68.     (if (and (null? combinations)
  69.          (null? (continuation/returns continuation)))
  70.     (set-procedure-always-known-operator?! continuation false))))