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 / chtype.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  134 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: chtype.scm,v 4.3 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988, 1993, 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: Intern object types
  23.  
  24. (declare (usual-integrations)
  25.      (integrate-external "object"))
  26.  
  27. (define (change-type/block block)
  28.   (change-type/object enumeration/random block)
  29.   (block/for-each-bound-variable block
  30.     (lambda (variable)
  31.       (change-type/object enumeration/random variable)))
  32.   (for-each change-type/block (block/children block)))
  33.  
  34. (define (change-type/expressions expressions)
  35.   (for-each change-type/expression expressions))
  36.  
  37. (declare (integrate-operator change-type/expression))
  38.  
  39. (define (change-type/expression expression)
  40.   (change-type/object enumeration/expression expression)
  41.   ((expression/method dispatch-vector expression) expression))
  42.  
  43. (define dispatch-vector
  44.   (expression/make-dispatch-vector))
  45.  
  46. (define define-method/change-type
  47.   (expression/make-method-definer dispatch-vector))
  48.  
  49. (declare (integrate-operator change-type/object))
  50.  
  51. (define (change-type/object enumeration object)
  52.   (set-object/enumerand!
  53.    object
  54.    (enumeration/name->enumerand enumeration
  55.                 (enumerand/name (object/enumerand object)))))
  56.  
  57. (define-method/change-type 'ACCESS
  58.   (lambda (expression)
  59.     (change-type/expression (access/environment expression))))
  60.  
  61. (define-method/change-type 'ASSIGNMENT
  62.   (lambda (expression)
  63.     (change-type/expression (assignment/value expression))))
  64.  
  65. (define-method/change-type 'COMBINATION
  66.   (lambda (expression)
  67.     (change-type/expression (combination/operator expression))
  68.     (change-type/expressions (combination/operands expression))))
  69.  
  70. (define-method/change-type 'CONDITIONAL
  71.   (lambda (expression)
  72.     (change-type/expression (conditional/predicate expression))
  73.     (change-type/expression (conditional/consequent expression))
  74.     (change-type/expression (conditional/alternative expression))))
  75.  
  76. (define-method/change-type 'CONSTANT
  77.   (lambda (expression)
  78.     expression ; ignored
  79.     'DONE))
  80.  
  81. (define-method/change-type 'DECLARATION
  82.   (lambda (expression)
  83.     (change-type/expression (declaration/expression expression))))
  84.  
  85. (define-method/change-type 'DELAY
  86.   (lambda (expression)
  87.     (change-type/expression (delay/expression expression))))
  88.  
  89. (define-method/change-type 'DISJUNCTION
  90.   (lambda (expression)
  91.     (change-type/expression (disjunction/predicate expression))
  92.     (change-type/expression (disjunction/alternative expression))))
  93.  
  94. (define-method/change-type 'IN-PACKAGE
  95.   (lambda (expression)
  96.     (change-type/expression (in-package/environment expression))
  97.     (change-type/quotation (in-package/quotation expression))))
  98.  
  99. (define-method/change-type 'PROCEDURE
  100.   (lambda (expression)
  101.     (change-type/expression (procedure/body expression))))
  102.  
  103. (define-method/change-type 'OPEN-BLOCK
  104.   (lambda (expression)
  105.     (change-type/expressions (open-block/values expression))
  106.     (change-type/open-block-actions (open-block/actions expression))))
  107.  
  108. (define (change-type/open-block-actions actions)
  109.   (cond ((null? actions) 'DONE)
  110.     ((eq? (car actions) open-block/value-marker)
  111.      (change-type/open-block-actions (cdr actions)))
  112.     (else (change-type/expression (car actions))
  113.           (change-type/open-block-actions (cdr actions)))))
  114.  
  115. (define-method/change-type 'QUOTATION
  116.   (lambda (expression)
  117.     (change-type/quotation expression)))
  118.  
  119. (define (change-type/quotation quotation)
  120.   (change-type/expression (quotation/expression quotation)))
  121.  
  122. (define-method/change-type 'REFERENCE
  123.   (lambda (expression)
  124.     expression ; ignored
  125.     'DONE))
  126.  
  127. (define-method/change-type 'SEQUENCE
  128.   (lambda (expression)
  129.     (change-type/expressions (sequence/actions expression))))
  130.  
  131. (define-method/change-type 'THE-ENVIRONMENT
  132.   (lambda (expression)
  133.     expression ; ignored
  134.     'DONE))