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 / delint.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  100 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: delint.scm,v 1.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989, 1990, 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. ;;;; Delete integrated parameters
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (delete-integrated-parameters blocks)
  27.   (for-each
  28.    (lambda (block)
  29.      (if (stack-block? block)
  30.      (delete-integrated-parameters! block)))
  31.    blocks))
  32.  
  33. (define (delete-integrated-parameters! block)
  34.   (let ((deletions '())
  35.     (procedure (block-procedure block)))
  36.     (let ((delete-integrations
  37.        (lambda (get-names set-names!)
  38.          (with-values
  39.          (lambda ()
  40.            (find-integrated-variables (get-names procedure)))
  41.            (lambda (not-integrated integrated)
  42.          (if (not (null? integrated))
  43.              (begin
  44.                (set-names! procedure not-integrated)
  45.                (set! deletions
  46.                  (eq-set-union deletions integrated)))))))))
  47.       (delete-integrations (lambda (procedure)
  48.                  (cdr (procedure-required procedure)))
  49.                (lambda (procedure required)
  50.                  (set-cdr! (procedure-required procedure)
  51.                        required)))
  52.       (delete-integrations procedure-optional set-procedure-optional!))
  53.     (let ((rest (procedure-rest procedure)))
  54.       (if (and rest (variable-unused? rest))
  55.       (begin
  56.         (set! deletions (eq-set-adjoin deletions rest))
  57.         (set-procedure-rest! procedure false))))
  58.     (with-values
  59.     (lambda ()
  60.       (find-integrated-bindings (procedure-names procedure)
  61.                     (procedure-values procedure)))
  62.       (lambda (names vals integrated)
  63.     (set-procedure-names! procedure names)
  64.     (set-procedure-values! procedure vals)
  65.     (set! deletions (eq-set-union deletions integrated))))
  66.     (if (not (null? deletions))
  67.     (set-block-bound-variables!
  68.      block
  69.      (eq-set-difference (block-bound-variables block) deletions)))))
  70.  
  71. (define (find-integrated-bindings names vals)
  72.   (if (null? names)
  73.       (values '() '() '())
  74.       (with-values
  75.       (lambda ()
  76.         (find-integrated-bindings (cdr names) (cdr vals)))
  77.     (lambda (names* values* integrated)
  78.       (if (variable-unused? (car names))
  79.           (values names* values* (cons (car names) integrated))
  80.           (values (cons (car names) names*)
  81.               (cons (car vals) values*)
  82.               integrated))))))
  83.  
  84. (define (find-integrated-variables variables)
  85.   (if (null? variables)
  86.       (values '() '())
  87.       (with-values
  88.       (lambda ()
  89.         (find-integrated-variables (cdr variables)))
  90.     (lambda (not-integrated integrated)
  91.       (if (or (variable-register (car variables))
  92.           (variable-unused? (car variables)))
  93.           (values not-integrated
  94.               (cons (car variables) integrated))
  95.           (values (cons (car variables) not-integrated)
  96.               integrated))))))
  97.  
  98.  
  99.  
  100.