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 / cgen.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  236 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: cgen.scm,v 4.4 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: Generate SCode from Expression
  23. ;;; package: (scode-optimizer cgen)
  24.  
  25. (declare (usual-integrations)
  26.      (automagic-integrations)
  27.      (open-block-optimizations)
  28.      (eta-substitution)
  29.      (integrate-external "object"))
  30.  
  31. (define *sf-associate*
  32.   (lambda (new old)
  33.     old new
  34.     false))
  35.  
  36. (define (cgen/output old new)
  37.   (*sf-associate* new (and old (object/scode old)))
  38.   new)
  39.  
  40. (define (cgen/external quotation)
  41.   (fluid-let ((flush-declarations? true))
  42.     (cgen/output quotation
  43.          (cgen/top-level quotation))))
  44.  
  45. (define (cgen/external-with-declarations expression)
  46.   (fluid-let ((flush-declarations? false))
  47.     (cgen/expression (list false) expression)))
  48.  
  49. (define (cgen/top-level quotation)
  50.   (let ((block (quotation/block quotation))
  51.     (expression (quotation/expression quotation)))
  52.     (let ((result (cgen/expression (list block) expression)))
  53.       (if (open-block? expression)
  54.       result
  55.       (cgen/declaration (block/declarations block) result)))))
  56.  
  57. (define (cgen/declaration declarations expression)
  58.   (let ((declarations (maybe-flush-declarations declarations)))
  59.     (if (null? declarations)
  60.     expression
  61.     (make-declaration declarations expression))))
  62.  
  63. (define flush-declarations?)
  64.  
  65. (define (maybe-flush-declarations declarations)
  66.   (if (null? declarations)
  67.       '()
  68.       (let ((declarations (declarations/original declarations)))
  69.     (if flush-declarations?
  70.         (let loop ((declarations declarations))
  71.           (cond ((null? declarations) '())
  72.             ((declarations/known? (car declarations))
  73.              (loop (cdr declarations)))
  74.             (else
  75.              (if (not (known-compiler-declaration? (car declarations)))
  76.              (warn "Unused declaration" (car declarations)))
  77.              (cons (car declarations) (loop (cdr declarations))))))
  78.         declarations))))
  79.  
  80. (define *known-compiler-declarations*
  81.   ;; Declarations which are not handled by SF but are known to be handled
  82.   ;; by the compiler so SF ignores then silently.
  83.   '(IGNORE-REFERENCE-TRAPS IGNORE-ASSIGNMENT-TRAPS))
  84.  
  85. (define (known-compiler-declaration? declaration)
  86.   (memq (car declaration) *known-compiler-declarations*))
  87.  
  88. (define (cgen/expressions interns expressions)
  89.   (map (lambda (expression)
  90.      (cgen/expression interns expression))
  91.        expressions))
  92.  
  93. (declare (integrate-operator cgen/expression))
  94.  
  95. (define (cgen/expression interns expression)
  96.   ((expression/method dispatch-vector expression) interns expression))
  97.  
  98. (define dispatch-vector
  99.   (expression/make-dispatch-vector))
  100.  
  101. (define %define-method/cgen
  102.   (expression/make-method-definer dispatch-vector))
  103.  
  104. (define-integrable (define-method/cgen type handler)
  105.   (%define-method/cgen type
  106.    (lambda (interns expression)
  107.      (cgen/output expression (handler interns expression)))))
  108.  
  109. (define (cgen/variable interns variable)
  110.   (cdr (or (assq variable (cdr interns))
  111.        (let ((association
  112.           (cons variable (make-variable (variable/name variable)))))
  113.          (set-cdr! interns (cons association (cdr interns)))
  114.          association))))
  115.  
  116. (define-method/cgen 'ACCESS
  117.   (lambda (interns expression)
  118.     (make-access (cgen/expression interns (access/environment expression))
  119.          (access/name expression))))
  120.  
  121. (define-method/cgen 'ASSIGNMENT
  122.   (lambda (interns expression)
  123.     (make-assignment-from-variable
  124.      (cgen/variable interns (assignment/variable expression))
  125.      (cgen/expression interns (assignment/value expression)))))
  126.  
  127. (define-method/cgen 'COMBINATION
  128.   (lambda (interns expression)
  129.     (make-combination
  130.      (cgen/expression interns (combination/operator expression))
  131.      (cgen/expressions interns (combination/operands expression)))))
  132.  
  133. (define-method/cgen 'CONDITIONAL
  134.   (lambda (interns expression)
  135.     (make-conditional
  136.      (cgen/expression interns (conditional/predicate expression))
  137.      (cgen/expression interns (conditional/consequent expression))
  138.      (cgen/expression interns (conditional/alternative expression)))))
  139.  
  140. (define-method/cgen 'CONSTANT
  141.   (lambda (interns expression)
  142.     interns ; is ignored
  143.     (constant/value expression)))
  144.  
  145. (define-method/cgen 'DECLARATION
  146.   (lambda (interns expression)
  147.     (cgen/declaration (declaration/declarations expression)
  148.               (cgen/expression interns
  149.                        (declaration/expression expression)))))
  150.  
  151. (define-method/cgen 'DELAY
  152.   (lambda (interns expression)
  153.     (make-delay (cgen/expression interns (delay/expression expression)))))
  154.  
  155. (define-method/cgen 'DISJUNCTION
  156.   (lambda (interns expression)
  157.     (make-disjunction
  158.      (cgen/expression interns (disjunction/predicate expression))
  159.      (cgen/expression interns (disjunction/alternative expression)))))
  160.  
  161. (define-method/cgen 'IN-PACKAGE
  162.   (lambda (interns expression)
  163.     (make-in-package
  164.      (cgen/expression interns (in-package/environment expression))
  165.      (cgen/top-level (in-package/quotation expression)))))
  166.  
  167. (define-method/cgen 'PROCEDURE
  168.   (lambda (interns procedure)
  169.     interns ; ignored
  170.     (make-lambda* (procedure/name procedure)
  171.           (map variable/name (procedure/required procedure))
  172.           (map variable/name (procedure/optional procedure))
  173.           (let ((rest (procedure/rest procedure)))
  174.             (and rest (variable/name rest)))
  175.           (let ((block (procedure/block procedure)))
  176.             (make-open-block
  177.              '()
  178.              (maybe-flush-declarations (block/declarations block))
  179.              (cgen/expression (list block)
  180.                       (procedure/body procedure)))))))
  181.  
  182. (define-method/cgen 'OPEN-BLOCK
  183.   (lambda (interns expression)
  184.     interns ; is ignored
  185.     (let ((block (open-block/block expression)))
  186.       (make-open-block '()
  187.                (maybe-flush-declarations (block/declarations block))
  188.                (cgen/body (list block) expression)))))
  189.  
  190. (define (cgen/body interns open-block)
  191.   (make-sequence
  192.    (let loop
  193.        ((variables (open-block/variables open-block))
  194.     (values (open-block/values open-block))
  195.     (actions (open-block/actions open-block)))
  196.      (cond ((null? variables) (cgen/expressions interns actions))
  197.        ((null? actions) (error "Extraneous auxiliaries"))
  198.        ((eq? (car actions) open-block/value-marker)
  199.         (cons (make-definition (variable/name (car variables))
  200.                    (cgen/expression interns (car values)))
  201.           (loop (cdr variables) (cdr values) (cdr actions))))
  202.        (else
  203.         (cons (cgen/expression interns (car actions))
  204.           (loop variables values (cdr actions))))))))
  205.  
  206. (define-method/cgen 'QUOTATION
  207.   (lambda (interns expression)
  208.     interns ; ignored
  209.     (make-quotation (cgen/top-level expression))))
  210.  
  211. (define-method/cgen 'REFERENCE
  212.   (lambda (interns expression)
  213.     (cgen/variable interns (reference/variable expression))))
  214.  
  215. (define-method/cgen 'SEQUENCE
  216.   (lambda (interns expression)
  217.     (let ((actions
  218.        (if flush-declarations?
  219.            (remove-references (sequence/actions expression))
  220.            (sequence/actions expression))))
  221.       (if (null? (cdr actions))
  222.       (cgen/expression interns (car actions))
  223.       (make-sequence (cgen/expressions interns actions))))))
  224.  
  225. (define (remove-references actions)
  226.   (if (null? (cdr actions))
  227.       actions
  228.       (let ((rest (remove-references (cdr actions))))
  229.     (if (reference? (car actions))
  230.         rest
  231.         (cons (car actions) rest)))))
  232.  
  233. (define-method/cgen 'THE-ENVIRONMENT
  234.   (lambda (interns expression)
  235.     interns expression ; ignored
  236.     (make-the-environment)))