← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/compiler/fgopt/delint.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compiler/fgopt/delint.scm
 
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