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 / runtime / xeval.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  221 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: xeval.scm,v 1.6 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1989-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 Evaluator extended for compiled-code environments
  23. ;;; package: (runtime extended-scode-eval)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define hook/extended-scode-eval)
  28.  
  29. (define (default/extended-scode-eval expression environment)
  30.   (scode-eval expression environment))
  31.  
  32. (define (extended-scode-eval expression environment)
  33.   (cond ((interpreter-environment? environment)
  34.      (hook/extended-scode-eval expression environment))
  35.     ((scode-constant? expression)
  36.      expression)
  37.     (else
  38.      (with-values (lambda () (split-environment environment))
  39.        (lambda (bound-names interpreter-environment)
  40.          (hook/extended-scode-eval
  41.           (cond ((null? bound-names)
  42.              expression)
  43.             ((or (definition? expression)
  44.              (and (open-block? expression)
  45.                   (open-block-components expression
  46.                 (lambda (names declarations body)
  47.                   declarations body
  48.                   (not (null? names))))))
  49.              (error
  50.               "Can't perform definition in compiled-code environment:"
  51.               (unsyntax expression)))
  52.             (else
  53.              (rewrite/expression expression environment bound-names)))
  54.           interpreter-environment))))))
  55.  
  56. (define (split-environment environment)
  57.   (let ((finish
  58.      (lambda (bound-names environment)
  59.        (values (apply append (reverse! bound-names)) environment))))
  60.     (let loop ((bound-names '()) (environment environment))
  61.       (if (interpreter-environment? environment)
  62.       (finish bound-names environment)
  63.       (let ((bound-names
  64.          (cons (environment-bound-names environment) bound-names)))
  65.         (if (environment-has-parent? environment)
  66.         (loop bound-names (environment-parent environment))
  67.         (finish bound-names
  68.             (make-null-interpreter-environment))))))))
  69.  
  70. (define (difference items items*)
  71.   (list-transform-negative items
  72.     (lambda (item)
  73.       (memq item items*))))
  74.  
  75. (define (environment-which-binds environment name)
  76.   (let loop ((environment environment))
  77.     (if (environment-bound? environment name)
  78.     environment
  79.     (loop
  80.      (if (environment-has-parent? environment)
  81.          (environment-parent environment)
  82.          (error "Environment has no parent:" environment))))))
  83.  
  84. (define (rewrite/expression expression environment bound-names)
  85.   ((scode-walk rewrite-walker expression) expression environment bound-names))
  86.  
  87. (define (rewrite/expressions expressions environment bound-names)
  88.   (map (lambda (expression)
  89.      (rewrite/expression expression environment bound-names))
  90.        expressions))
  91.  
  92. (define rewrite-walker)
  93.  
  94. (define (initialize-package!)
  95.   (set! rewrite-walker
  96.     (make-scode-walker
  97.      rewrite/constant
  98.      `((ACCESS ,rewrite/access)
  99.        (ASSIGNMENT ,rewrite/assignment)
  100.        (COMBINATION ,rewrite/combination)
  101.        (COMMENT ,rewrite/comment)
  102.        (CONDITIONAL ,rewrite/conditional)
  103.        (DELAY ,rewrite/delay)
  104.        (DISJUNCTION ,rewrite/disjunction)
  105.        (IN-PACKAGE ,rewrite/in-package)
  106.        (LAMBDA ,rewrite/lambda)
  107.        (SEQUENCE ,rewrite/sequence)
  108.        (THE-ENVIRONMENT ,rewrite/the-environment)
  109.        (UNASSIGNED? ,rewrite/unassigned?)
  110.        (VARIABLE ,rewrite/variable))))
  111.   (set! hook/extended-scode-eval default/extended-scode-eval)
  112.   unspecific)
  113.  
  114. (define (rewrite/variable expression environment bound-names)
  115.   (let ((name (variable-name expression)))
  116.     (if (memq name bound-names)
  117.     (ccenv-lookup environment name)
  118.     expression)))
  119.  
  120. (define (rewrite/unassigned? expression environment bound-names)
  121.   (let ((name (unassigned?-name expression)))
  122.     (if (memq name bound-names)
  123.     (make-combination (make-absolute-reference 'UNASSIGNED-REFERENCE-TRAP?)
  124.               (list (ccenv-lookup environment name)))
  125.     expression)))
  126.  
  127. (define (ccenv-lookup environment name)
  128.   (make-combination (make-absolute-reference 'ENVIRONMENT-LOOKUP)
  129.             (list (environment-which-binds environment name) name)))
  130.  
  131. (define (rewrite/assignment expression environment bound-names)
  132.   (let ((name (assignment-name expression))
  133.     (value
  134.      (rewrite/expression (assignment-value expression)
  135.                  environment
  136.                  bound-names)))
  137.     (if (memq name bound-names)
  138.     (let ((environment (environment-which-binds environment name)))
  139.       (if (not (environment-assignable? environment name))
  140.           (error
  141.            "Cannot perform assignment to this compiled-code variable:"
  142.            name))
  143.       (make-combination (make-absolute-reference 'ENVIRONMENT-ASSIGN!)
  144.                 (list environment name value)))
  145.     (make-assignment name value))))
  146.  
  147. (define (rewrite/lambda expression environment bound-names)
  148.   (lambda-components expression
  149.     (lambda (name required optional rest auxiliary declarations body)
  150.       (make-lambda
  151.        name required optional rest auxiliary declarations
  152.        (rewrite/expression body
  153.                environment
  154.                (difference bound-names
  155.                        (append required
  156.                            optional
  157.                            auxiliary
  158.                            (if rest (list rest) '()))))))))
  159.  
  160. (define (rewrite/the-environment expression environment bound-names)
  161.   expression environment bound-names
  162.   (error "Can't take (the-environment) of compiled-code environment"))
  163.  
  164. (define (rewrite/access expression environment bound-names)
  165.   (make-access (rewrite/expression (access-environment expression)
  166.                    environment
  167.                    bound-names)
  168.            (access-name expression)))
  169.  
  170. (define (rewrite/combination expression environment bound-names)
  171.   (make-combination (rewrite/expression (combination-operator expression)
  172.                     environment
  173.                     bound-names)
  174.             (rewrite/expressions (combination-operands expression)
  175.                      environment
  176.                      bound-names)))
  177.  
  178. (define (rewrite/comment expression environment bound-names)
  179.   (make-comment (comment-text expression)
  180.         (rewrite/expression (comment-expression expression)
  181.                     environment
  182.                     bound-names)))
  183.  
  184. (define (rewrite/conditional expression environment bound-names)
  185.   (make-conditional (rewrite/expression (conditional-predicate expression)
  186.                     environment
  187.                     bound-names)
  188.             (rewrite/expression (conditional-consequent expression)
  189.                     environment
  190.                     bound-names)
  191.             (rewrite/expression (conditional-alternative expression)
  192.                     environment
  193.                     bound-names)))
  194.  
  195. (define (rewrite/delay expression environment bound-names)
  196.   (make-delay (rewrite/expression (delay-expression expression)
  197.                   environment
  198.                   bound-names)))
  199.  
  200. (define (rewrite/disjunction expression environment bound-names)
  201.   (make-disjunction (rewrite/expression (disjunction-predicate expression)
  202.                     environment
  203.                     bound-names)
  204.             (rewrite/expression (disjunction-alternative expression)
  205.                     environment
  206.                     bound-names)))
  207.  
  208. (define (rewrite/in-package expression environment bound-names)
  209.   (make-in-package (rewrite/expression (in-package-environment expression)
  210.                        environment
  211.                        bound-names)
  212.            (in-package-expression expression)))
  213.  
  214. (define (rewrite/sequence expression environment bound-names)
  215.   (make-sequence (rewrite/expressions (sequence-actions expression)
  216.                       environment
  217.                       bound-names)))
  218.  
  219. (define (rewrite/constant expression environment bound-names)
  220.   environment bound-names
  221.   expression)