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 / cref / anfile.scm next >
Text File  |  1999-01-02  |  6KB  |  176 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: anfile.scm,v 1.6 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. ;;;; Free/Bound Variable Analysis
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (analyze-file pathname)
  27.   (analyze/top-level (fasload pathname)))
  28.  
  29. (define (analyze/top-level expression)
  30.   (with-values (lambda () (sort-expressions (process-top-level expression)))
  31.     (lambda (definitions others)
  32.       (let ((definition-analysis
  33.           (map analyze/top-level/definition definitions)))
  34.     (if (not (null? others))
  35.         (cons (vector false
  36.               'EXPRESSION
  37.               (analyze-and-compress (make-sequence others)))
  38.           definition-analysis)
  39.         definition-analysis)))))
  40.  
  41. (define (sort-expressions expressions)
  42.   (if (null? expressions)
  43.       (values '() '())
  44.       (let ((rest (lambda () (sort-expressions (cdr expressions)))))
  45.     (if (block-declaration? (car expressions))
  46.         (rest)
  47.         (with-values rest
  48.           (lambda (definitions others)
  49.         (if (definition? (car expressions))
  50.             (values (cons (car expressions) definitions) others)
  51.             (values definitions (cons (car expressions) others)))))))))
  52.  
  53. (define (process-top-level expression)
  54.   (cond ((comment? expression)
  55.      (process-top-level (comment-expression expression)))
  56.     ((sequence? expression)
  57.      (append-map! process-top-level (sequence-actions expression)))
  58.     (else
  59.      (list expression))))
  60.  
  61. (define (analyze/top-level/definition definition)
  62.   (let ((name (definition-name definition))
  63.     (expression (definition-value definition)))
  64.     (cond ((unassigned-reference-trap? expression)
  65.        (vector name 'UNASSIGNED '#()))
  66.       ((scode-constant? expression)
  67.        (vector name 'CONSTANT '#()))
  68.       (else
  69.        (vector name
  70.            (cond ((lambda? expression) 'LAMBDA)
  71.              ((delay? expression) 'DELAY)
  72.              (else 'EXPRESSION))
  73.            (analyze-and-compress expression))))))
  74.  
  75. (define (analyze-and-compress expression)
  76.   (list->vector (analyze/expression expression)))
  77.  
  78. (define (analyze/expression expression)
  79.   ((scode-walk analyze/dispatch expression) expression))
  80.  
  81. (define (analyze/expressions expressions)
  82.   (if (null? expressions)
  83.       '()
  84.       (eq-set-union (analyze/expression (car expressions))
  85.             (analyze/expressions (cdr expressions)))))
  86.  
  87. (define (analyze/uninteresting expression)
  88.   (if (primitive-procedure? expression) (list expression) '()))
  89.  
  90. (define (analyze/error expression)
  91.   (error "Illegal expression" expression))
  92.  
  93. (define (analyze/access expression)
  94.   (if (access-environment expression)
  95.       (warn "Access to non-global environment:" (unsyntax expression)))
  96.   (list expression))
  97.  
  98. (define (analyze/variable expression)
  99.   (list (variable-name expression)))
  100.  
  101. (define (analyze/assignment expression)
  102.   (eq-set-adjoin (assignment-name expression)
  103.          (analyze/expression (assignment-value expression))))
  104.  
  105. (define (analyze/combination expression)
  106.   (eq-set-union (analyze/expression (combination-operator expression))
  107.         (analyze/expressions (combination-operands expression))))
  108.  
  109. (define (analyze/lambda expression)
  110.   (lambda-components expression
  111.     (lambda (name required optional rest auxiliary declarations body)
  112.       name declarations
  113.       (eq-set-difference (analyze/expression body)
  114.              (append required
  115.                  optional
  116.                  (if rest (list rest) '())
  117.                  auxiliary)))))
  118.  
  119. (define (analyze/error-combination expression)
  120.   (combination-components expression
  121.     (lambda (operator operands)
  122.       (analyze/expressions (list operator (car operands) (cadr operands))))))
  123.  
  124. (define (analyze/delay expression)
  125.   (analyze/expression (delay-expression expression)))
  126.  
  127. (define (analyze/sequence expression)
  128.   (analyze/expressions (sequence-actions expression)))
  129.  
  130. (define (analyze/conditional expression)
  131.   (analyze/expressions (conditional-components expression list)))
  132.  
  133. (define (analyze/disjunction expression)
  134.   (analyze/expressions (disjunction-components expression list)))
  135.  
  136. (define (analyze/comment expression)
  137.   (analyze/expression (comment-expression expression)))
  138.  
  139. (define analyze/dispatch
  140.   (make-scode-walker
  141.    analyze/uninteresting
  142.    `((ACCESS ,analyze/access)
  143.      (ASSIGNMENT ,analyze/assignment)
  144.      (COMBINATION ,analyze/combination)
  145.      (COMMENT ,analyze/comment)
  146.      (CONDITIONAL ,analyze/conditional)
  147.      (DEFINITION ,analyze/error)
  148.      (DELAY ,analyze/delay)
  149.      (DISJUNCTION ,analyze/disjunction)
  150.      (ERROR-COMBINATION ,analyze/error-combination)
  151.      (IN-PACKAGE ,analyze/error)
  152.      (LAMBDA ,analyze/lambda)
  153.      (SEQUENCE ,analyze/sequence)
  154.      (VARIABLE ,analyze/variable))))
  155.  
  156. (define (eq-set-adjoin x y)
  157.   (if (memq x y)
  158.       y
  159.       (cons x y)))
  160.  
  161. (define (eq-set-union x y)
  162.   (if (null? y)
  163.       x
  164.       (let loop ((x x) (y y))
  165.     (if (null? x)
  166.         y
  167.         (loop (cdr x)
  168.           (if (memq (car x) y)
  169.               y
  170.               (cons (car x) y)))))))
  171.  
  172. (define (eq-set-difference x y)
  173.   (let loop ((x x))
  174.     (cond ((null? x) '())
  175.       ((memq (car x) y) (loop (cdr x)))
  176.       (else (cons (car x) (loop (cdr x)))))))