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 / fgopt / operan.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  97 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: operan.scm,v 4.8 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 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. ;;;; Operator Analysis
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (operator-analysis procedures applications)
  27.   (for-each (lambda (application)
  28.           (if (eq? (application-type application) 'COMBINATION)
  29.           (analyze/combination application)))
  30.         applications)
  31.   (for-each (lambda (procedure)
  32.           (if (procedure-continuation? procedure)
  33.           (set-continuation/passed-out?!
  34.            procedure
  35.            (continuation-passed-out? procedure))))
  36.         procedures)
  37.   (for-each (lambda (procedure)
  38.           (set-procedure-always-known-operator?!
  39.            procedure
  40.            (if (procedure-continuation? procedure)
  41.            (analyze/continuation procedure)
  42.            (analyze/procedure procedure))))
  43.         procedures))
  44.  
  45. (define (analyze/combination combination)
  46.   (for-each (lambda (continuation)
  47.           (set-continuation/combinations!
  48.            continuation
  49.            (cons combination
  50.              (continuation/combinations continuation))))
  51.         (rvalue-values (combination/continuation combination))))
  52.  
  53. (define (continuation-passed-out? continuation)
  54.   (there-exists? (continuation/combinations continuation)
  55.     (lambda (combination)
  56.       (and (not (combination/simple-inline? combination))
  57.        (let ((operator (combination/operator combination)))
  58.          (or (rvalue-passed-in? operator)
  59.          (there-exists? (rvalue-values operator)
  60.            (lambda (rvalue) (not (rvalue/procedure? rvalue))))))))))
  61.  
  62. (define (analyze/continuation continuation)
  63.   (let ((returns (continuation/returns continuation))
  64.     (combinations (continuation/combinations continuation)))
  65.     (and (or (not (null? returns))
  66.          (not (null? combinations)))
  67.      (3-logic/and
  68.       (and (not (continuation/passed-out? continuation)) 'ALWAYS)
  69.       (3-logic/and
  70.        (for-some? returns
  71.          (lambda (return)
  72.            (eq? (rvalue-known-value (return/operator return))
  73.             continuation)))
  74.        (for-some? combinations
  75.          (lambda (combination)
  76.            (eq? (rvalue-known-value (combination/continuation combination))
  77.             continuation))))))))
  78.  
  79. (define (for-some? items predicate)
  80.   (let loop ((items items) (default false))
  81.     (cond ((null? items) 'ALWAYS)
  82.       ((predicate (car items)) (loop (cdr items) 'SOMETIMES))
  83.       (else default))))
  84.  
  85. (define (3-logic/and x y)
  86.   (cond ((and (eq? x 'ALWAYS) (eq? y 'ALWAYS)) 'ALWAYS)
  87.     ((and (not x) (not y)) false)
  88.     (else 'SOMETIMES)))
  89.  
  90. (define (analyze/procedure procedure)
  91.   (and (not (procedure-passed-out? procedure))
  92.        (let ((combinations (procedure-applications procedure)))
  93.      (and (not (null? combinations))
  94.           (for-all? combinations
  95.         (lambda (combination)
  96.           (eq? (rvalue-known-value (combination/operator combination))
  97.                procedure)))))))