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 / codwlk.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  199 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: codwlk.scm,v 14.3 1999/01/02 06:11:34 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 Walker
  23. ;;; package: (runtime scode-walker)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (scode-walker (constructor %make-scode-walker)
  28.                 (conc-name scode-walker/))
  29.   (access false read-only true)
  30.   (assignment false read-only true)
  31.   (combination false read-only true)
  32.   (comment false read-only true)
  33.   (conditional false read-only true)
  34.   (constant false read-only true)
  35.   (declaration false read-only true)
  36.   (definition false read-only true)
  37.   (delay false read-only true)
  38.   (disjunction false read-only true)
  39.   (error-combination false read-only true)
  40.   (in-package false read-only true)
  41.   (lambda false read-only true)
  42.   (open-block false read-only true)
  43.   (quotation false read-only true)
  44.   (sequence false read-only true)
  45.   (the-environment false read-only true)
  46.   (unassigned? false read-only true)
  47.   (variable false read-only true))
  48.  
  49. (define (make-scode-walker default alist)
  50.   (let ((alist
  51.      (map (lambda (entry)
  52.         (cons (car entry) (cadr entry)))
  53.           alist)))
  54.     (let ((result
  55.        (let ((lookup
  56.           (lambda (name default)
  57.             (let ((entry (assq name alist)))
  58.               (if entry
  59.               (begin (set! alist (delq! entry alist))
  60.                  (cdr entry))
  61.               default)))))
  62.          (let ((comment-handler (lookup 'COMMENT default))
  63.            (combination-handler (lookup 'COMBINATION default))
  64.            (sequence-handler (lookup 'SEQUENCE default)))
  65.            (%make-scode-walker (lookup 'ACCESS default)
  66.                    (lookup 'ASSIGNMENT default)
  67.                    combination-handler
  68.                    comment-handler
  69.                    (lookup 'CONDITIONAL default)
  70.                    default
  71.                    (lookup 'DECLARATION comment-handler)
  72.                    (lookup 'DEFINITION default)
  73.                    (lookup 'DELAY default)
  74.                    (lookup 'DISJUNCTION default)
  75.                    (lookup 'ERROR-COMBINATION
  76.                        combination-handler)
  77.                    (lookup 'IN-PACKAGE default)
  78.                    (lookup 'LAMBDA default)
  79.                    (lookup 'OPEN-BLOCK sequence-handler)
  80.                    (lookup 'QUOTATION default)
  81.                    sequence-handler
  82.                    (lookup 'THE-ENVIRONMENT default)
  83.                    (lookup 'UNASSIGNED? combination-handler)
  84.                    (lookup 'VARIABLE default))))))
  85.       (if (not (null? alist))
  86.       (error "MAKE-SCODE-WALKER: Unrecognized alist items" alist))
  87.       result)))
  88.  
  89. (define (scode-walk walker expression)
  90.   ((vector-ref dispatch-vector (object-type expression)) walker expression))
  91.  
  92. (define dispatch-vector)
  93.  
  94. (define (initialize-package!)
  95.   (set! dispatch-vector
  96.     (let ((table (make-vector (microcode-type/code-limit) walk/constant)))
  97.       (for-each (lambda (entry)
  98.               (let ((kernel
  99.                  (lambda (name)
  100.                    (vector-set! table
  101.                         (microcode-type name)
  102.                         (cadr entry)))))
  103.             (if (pair? (car entry))
  104.                 (for-each kernel (car entry))
  105.                 (kernel (car entry)))))
  106.             `((ACCESS ,walk/access)
  107.               (ASSIGNMENT ,walk/assignment)
  108.               ((COMBINATION
  109.             COMBINATION-1
  110.             COMBINATION-2
  111.             PRIMITIVE-COMBINATION-0
  112.             PRIMITIVE-COMBINATION-1
  113.             PRIMITIVE-COMBINATION-2
  114.             PRIMITIVE-COMBINATION-3)
  115.                ,walk/combination)
  116.               (COMMENT ,walk/comment)
  117.               (CONDITIONAL ,walk/conditional)
  118.               (DEFINITION ,walk/definition)
  119.               (DELAY ,walk/delay)
  120.               (DISJUNCTION ,walk/disjunction)
  121.               (IN-PACKAGE ,walk/in-package)
  122.               ((LAMBDA LEXPR EXTENDED-LAMBDA) ,walk/lambda)
  123.               (QUOTATION ,walk/quotation)
  124.               ((SEQUENCE-2 SEQUENCE-3) ,walk/sequence)
  125.               (THE-ENVIRONMENT ,walk/the-environment)
  126.               (VARIABLE ,walk/variable)))
  127.       table)))
  128.  
  129. (define (walk/combination walker expression)
  130.   (let ((operator (combination-operator expression)))
  131.     (cond ((and (or (eq? operator (ucode-primitive lexical-unassigned?))
  132.             (absolute-reference-to? operator 'LEXICAL-UNASSIGNED?))
  133.         (let ((operands (combination-operands expression)))
  134.           (and (the-environment? (car operands))
  135.                (symbol? (cadr operands)))))
  136.        (scode-walker/unassigned? walker))
  137.       ((or (eq? operator (ucode-primitive error-procedure))
  138.            (absolute-reference-to? operator 'ERROR-PROCEDURE))
  139.        (scode-walker/error-combination walker))
  140.       (else
  141.        (scode-walker/combination walker)))))
  142.  
  143. (define (walk/comment walker expression)
  144.   (if (declaration? expression)
  145.       (scode-walker/declaration walker)
  146.       (scode-walker/comment walker)))
  147.  
  148. (define (walk/sequence walker expression)
  149.   (if (open-block? expression)
  150.       (scode-walker/open-block walker)
  151.       (scode-walker/sequence walker)))
  152.  
  153. (define (walk/access walker expression)
  154.   expression
  155.   (scode-walker/access walker))
  156.  
  157. (define (walk/assignment walker expression)
  158.   expression
  159.   (scode-walker/assignment walker))
  160.  
  161. (define (walk/conditional walker expression)
  162.   expression
  163.   (scode-walker/conditional walker))
  164.  
  165. (define (walk/constant walker expression)
  166.   expression
  167.   (scode-walker/constant walker))
  168.  
  169. (define (walk/definition walker expression)
  170.   expression
  171.   (scode-walker/definition walker))
  172.  
  173. (define (walk/delay walker expression)
  174.   expression
  175.   (scode-walker/delay walker))
  176.  
  177. (define (walk/disjunction walker expression)
  178.   expression
  179.   (scode-walker/disjunction walker))
  180.  
  181. (define (walk/in-package walker expression)
  182.   expression
  183.   (scode-walker/in-package walker))
  184.  
  185. (define (walk/lambda walker expression)
  186.   expression
  187.   (scode-walker/lambda walker))
  188.  
  189. (define (walk/quotation walker expression)
  190.   expression
  191.   (scode-walker/quotation walker))
  192.  
  193. (define (walk/the-environment walker expression)
  194.   expression
  195.   (scode-walker/the-environment walker))
  196.  
  197. (define (walk/variable walker expression)
  198.   expression
  199.   (scode-walker/variable walker))