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 / sf / copy.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  293 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: copy.scm,v 4.5 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; SCode Optimizer: Copy Expression
  23. ;;; package: (scode-optimizer copy)
  24.  
  25. (declare (usual-integrations)
  26.      (integrate-external "object"))
  27.  
  28. (define root-block)
  29. (define copy/variable/free)
  30. (define copy/declarations)
  31.  
  32. (define (copy/expression/intern block expression)
  33.   (fluid-let ((root-block block)
  34.           (copy/variable/free copy/variable/free/intern)
  35.           (copy/declarations copy/declarations/intern))
  36.     (copy/expression block (environment/make) expression)))
  37.  
  38. (define (copy/expression/extern block expression)
  39.   (fluid-let ((root-block block)
  40.           (copy/variable/free copy/variable/free/extern)
  41.           (copy/declarations copy/declarations/extern))
  42.     (copy/expression block (environment/make) expression)))
  43.  
  44. (define (copy/expressions block environment expressions)
  45.   (map (lambda (expression)
  46.      (copy/expression block environment expression))
  47.        expressions))
  48.  
  49. (define (copy/expression block environment expression)
  50.   ((expression/method dispatch-vector expression)
  51.    block environment expression))
  52.  
  53. (define dispatch-vector
  54.   (expression/make-dispatch-vector))
  55.  
  56. (define define-method/copy
  57.   (expression/make-method-definer dispatch-vector))
  58.  
  59. (define (environment/make)
  60.   '())
  61.  
  62. (define (environment/bind environment variables values)
  63.   (map* environment cons variables values))
  64.  
  65. (define (environment/lookup environment variable if-found if-not)
  66.   (let ((association (assq variable environment)))
  67.     (if association
  68.     (if-found (cdr association))
  69.     (if-not))))
  70.  
  71. (define (environment/rebind block environment variables)
  72.   (environment/bind
  73.    environment
  74.    variables
  75.    (map (lambda (variable)
  76.       (block/lookup-name block (variable/name variable) true))
  77.     variables)))
  78.  
  79. (define (make-renamer environment)
  80.   (lambda (variable)
  81.     (environment/lookup environment variable
  82.       identity-procedure
  83.       (lambda () (error "Variable missing during copy operation:" variable)))))
  84.  
  85. (define (copy/quotation quotation)
  86.   (fluid-let ((root-block false))
  87.     (let ((block (quotation/block quotation))
  88.       (environment (environment/make)))
  89.       (quotation/make (quotation/scode quotation)
  90.               block
  91.               (copy/expression block
  92.                        environment
  93.                        (quotation/expression quotation))))))
  94.  
  95. (define (copy/block parent environment block)
  96.   (let ((result (block/make parent (block/safe? block) '()))
  97.     (old-bound (block/bound-variables-list block)))
  98.     (let ((new-bound
  99.        (map (lambda (variable)
  100.           (let ((new
  101.              (variable/make&bind! result
  102.                           (variable/name variable))))
  103.             (set-variable/flags! new
  104.                      (list-copy (variable/flags variable)))
  105.             new))
  106.         old-bound)))
  107.       (let ((environment (environment/bind environment old-bound new-bound)))
  108.     (set-block/declarations!
  109.      result
  110.      (copy/declarations block environment (block/declarations block)))
  111.     (set-block/flags! result (block/flags block))
  112.     (values result environment)))))
  113.  
  114. (define (copy/variable block environment variable)
  115.   block                    ;ignored
  116.   (environment/lookup environment variable
  117.     identity-procedure
  118.     (lambda () (copy/variable/free variable))))
  119.  
  120. (define (copy/variable/free/intern variable)
  121.   (let ((name (variable/name variable)))
  122.     (let loop ((block root-block))
  123.       (let ((variable* (block/lookup-name block name false)))
  124.     (if (not variable*)
  125.         (error "Unable to find free variable during copy:" name))
  126.     (if (eq? variable variable*)
  127.         variable
  128.         (begin
  129.           (if (not (block/parent block))
  130.           (error "Unable to find free variable during copy:" name))
  131.           (if (not (block/safe? (variable/block variable*)))
  132.           (error "Integration requires renaming unsafe variable:"
  133.              name))
  134.           (set-variable/name!
  135.            variable*
  136.            (string->uninterned-symbol (symbol->string name)))
  137.           (loop (block/parent block))))))))
  138.  
  139. (define (copy/variable/free/extern variable)
  140.   (block/lookup-name root-block (variable/name variable) true))
  141.  
  142. (define (copy/declarations/intern block environment declarations)
  143.   block                    ;ignored
  144.   (if (null? declarations)
  145.       '()
  146.       (declarations/map declarations
  147.     (lambda (variable)
  148.       (environment/lookup environment variable
  149.         identity-procedure
  150.         (lambda () variable)))
  151.     identity-procedure)))
  152.  
  153. (define (copy/declarations/extern block environment declarations)
  154.   (if (null? declarations)
  155.       '()
  156.       (declarations/map declarations
  157.     (lambda (variable)
  158.       (environment/lookup environment variable
  159.         identity-procedure
  160.         (lambda ()
  161.           (block/lookup-name root-block (variable/name variable) true))))
  162.     (lambda (expression)
  163.       (copy/expression block environment expression)))))
  164.  
  165. (define-method/copy 'ACCESS
  166.   (lambda (block environment expression)
  167.     (access/make (access/scode expression)
  168.          (copy/expression block
  169.                   environment
  170.                   (access/environment expression))
  171.          (access/name expression))))
  172.  
  173. (define-method/copy 'ASSIGNMENT
  174.   (lambda (block environment expression)
  175.     (assignment/make
  176.      (assignment/scode expression)
  177.      block
  178.      (copy/variable block environment (assignment/variable expression))
  179.      (copy/expression block environment (assignment/value expression)))))
  180.  
  181. (define-method/copy 'COMBINATION
  182.   (lambda (block environment expression)
  183.     (combination/make
  184.      (combination/scode expression)
  185.      block
  186.      (copy/expression block environment (combination/operator expression))
  187.      (copy/expressions block environment (combination/operands expression)))))
  188.  
  189. (define-method/copy 'CONDITIONAL
  190.   (lambda (block environment expression)
  191.     (conditional/make
  192.      (conditional/scode expression)
  193.      (copy/expression block environment (conditional/predicate expression))
  194.      (copy/expression block environment (conditional/consequent expression))
  195.      (copy/expression block
  196.               environment
  197.               (conditional/alternative expression)))))
  198.  
  199. (define-method/copy 'CONSTANT
  200.   (lambda (block environment expression)
  201.     block environment            ;ignored
  202.     expression))
  203.  
  204. (define-method/copy 'DECLARATION
  205.   (lambda (block environment expression)
  206.     (declaration/make
  207.      (declaration/scode expression)
  208.      (copy/declarations block
  209.             environment
  210.             (declaration/declarations expression))
  211.      (copy/expression block environment (declaration/expression expression)))))
  212.  
  213. (define-method/copy 'DELAY
  214.   (lambda (block environment expression)
  215.     (delay/make
  216.      (delay/scode expression)
  217.      (copy/expression block environment (delay/expression expression)))))
  218.  
  219. (define-method/copy 'DISJUNCTION
  220.   (lambda (block environment expression)
  221.     (disjunction/make
  222.      (disjunction/scode expression)
  223.      (copy/expression block environment (disjunction/predicate expression))
  224.      (copy/expression block
  225.               environment
  226.               (disjunction/alternative expression)))))
  227.  
  228. (define-method/copy 'IN-PACKAGE
  229.   (lambda (block environment expression)
  230.     (in-package/make
  231.      (in-package/scode expression)
  232.      (copy/expression block environment (in-package/environment expression))
  233.      (copy/quotation (in-package/quotation expression)))))
  234.  
  235. (define-method/copy 'PROCEDURE
  236.   (lambda (block environment procedure)
  237.     (call-with-values
  238.     (lambda ()
  239.       (copy/block block environment (procedure/block procedure)))
  240.       (lambda (block environment)
  241.     (let ((rename (make-renamer environment)))
  242.       (procedure/make (procedure/scode procedure)
  243.               block
  244.               (procedure/name procedure)
  245.               (map rename (procedure/required procedure))
  246.               (map rename (procedure/optional procedure))
  247.               (let ((rest (procedure/rest procedure)))
  248.                 (and rest
  249.                  (rename rest)))
  250.               (copy/expression block
  251.                        environment
  252.                        (procedure/body procedure))))))))
  253.  
  254. (define-method/copy 'OPEN-BLOCK
  255.   (lambda (block environment expression)
  256.     (call-with-values
  257.     (lambda ()
  258.       (copy/block block environment (open-block/block expression)))
  259.       (lambda (block environment)
  260.     (open-block/make
  261.      (open-block/scode expression)
  262.      block
  263.      (map (make-renamer environment) (open-block/variables expression))
  264.      (copy/expressions block environment (open-block/values expression))
  265.      (map (lambda (action)
  266.         (if (eq? action open-block/value-marker)
  267.             action
  268.             (copy/expression block environment action)))
  269.           (open-block/actions expression))
  270.      (open-block/optimized expression))))))
  271.  
  272. (define-method/copy 'QUOTATION
  273.   (lambda (block environment expression)
  274.     block environment            ;ignored
  275.     (copy/quotation expression)))
  276.  
  277. (define-method/copy 'REFERENCE
  278.   (lambda (block environment expression)
  279.     (reference/make (reference/scode expression)
  280.             block
  281.             (copy/variable block environment
  282.                    (reference/variable expression)))))
  283.  
  284. (define-method/copy 'SEQUENCE
  285.   (lambda (block environment expression)
  286.     (sequence/make
  287.      (sequence/scode expression)
  288.      (copy/expressions block environment (sequence/actions expression)))))
  289.  
  290. (define-method/copy 'THE-ENVIRONMENT
  291.   (lambda (block environment expression)
  292.     block environment expression    ;ignored
  293.     (error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))