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 / scan.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  186 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: scan.scm,v 14.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. ;;;; Definition Scanner
  23. ;;; package: (runtime scode-scan)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; Scanning of internal definitions is necessary to reduce the number
  28. ;;; of "real auxiliary" variables in the system.  These bindings are
  29. ;;; maintained in alists by the microcode, and cannot be compiled as
  30. ;;; ordinary formals can.
  31.  
  32. ;;; The following support is provided.  SCAN-DEFINES will find the
  33. ;;; top-level definitions in a sequence, and returns an ordered list
  34. ;;; of those names, and a new sequence in which those definitions are
  35. ;;; replaced by assignments.  UNSCAN-DEFINES will invert that.
  36.  
  37. ;;; The Open Block abstraction can be used to store scanned
  38. ;;; definitions in code, which is extremely useful for code analysis
  39. ;;; and transformation.  The supplied procedures, MAKE-OPEN-BLOCK and
  40. ;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
  41. ;;; UNSCAN-DEFINES, respectively.
  42.  
  43. (define-integrable open-block-tag
  44.   ((ucode-primitive string->symbol) "#[open-block]"))
  45.  
  46. (define-integrable sequence-2-type
  47.   (ucode-type sequence-2))
  48.  
  49. (define-integrable sequence-3-type
  50.   (ucode-type sequence-3))
  51.  
  52. (define null-sequence
  53.   '(NULL-SEQUENCE))
  54.  
  55. (define (cons-sequence action seq)
  56.   (cond ((object-type? sequence-2-type seq)
  57.      (&typed-triple-cons sequence-3-type
  58.                  action
  59.                  (&pair-car seq)
  60.                  (&pair-cdr seq)))
  61.     ((eq? seq null-sequence)
  62.      action)
  63.     (else
  64.      (&typed-pair-cons sequence-2-type action seq))))
  65.  
  66. ;;;; Scanning
  67.  
  68. ;;; This depends on the fact that the lambda abstraction will preserve
  69. ;;; the order of the auxiliaries.  That is, giving MAKE-LAMBDA a list
  70. ;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an
  71. ;;; EQUAL?  list.
  72.  
  73. (define (scan-defines expression receiver)
  74.   ((scan-loop expression receiver) '() '() null-sequence))
  75.  
  76. (define (scan-loop expression receiver)
  77.   (cond ((object-type? sequence-2-type expression)
  78.      (scan-loop (&pair-cdr expression)
  79.             (scan-loop (&pair-car expression)
  80.                    receiver)))
  81.     ((object-type? sequence-3-type expression)
  82.      (let ((first (&triple-first expression)))
  83.        (if (and (vector? first)
  84.             (not (zero? (vector-length first)))
  85.             (eq? (vector-ref first 0) open-block-tag))
  86.            (scan-loop
  87.         (&triple-third expression)
  88.         (lambda (names declarations body)
  89.           (receiver (append (vector-ref first 1) names)
  90.                 (append (vector-ref first 2) declarations)
  91.                 body)))
  92.            (scan-loop (&triple-third expression)
  93.               (scan-loop (&triple-second expression)
  94.                      (scan-loop first
  95.                         receiver))))))
  96.     ((definition? expression)
  97.      (definition-components expression
  98.        (lambda (name value)
  99.          (lambda (names declarations body)
  100.            (receiver (cons name names)
  101.              declarations
  102.              (cons-sequence (make-assignment name value)
  103.                     body))))))
  104.     ((block-declaration? expression)
  105.      (lambda (names declarations body)
  106.        (receiver names
  107.              (append (block-declaration-text expression)
  108.                  declarations)
  109.              body)))
  110.     (else
  111.      (lambda (names declarations body)
  112.        (receiver names
  113.              declarations
  114.              (cons-sequence expression body))))))
  115.  
  116. (define (unscan-defines names declarations body)
  117.   (unscan-loop names body
  118.     (lambda (names* body*)
  119.       (if (not (null? names*))
  120.       (error "Extraneous auxiliaries -- get a wizard"
  121.          'UNSCAN-DEFINES
  122.          names*))
  123.       (if (null? declarations)
  124.       body*
  125.       (&typed-pair-cons sequence-2-type
  126.                 (make-block-declaration declarations)
  127.                 body*)))))
  128.  
  129. (define (unscan-loop names body receiver)
  130.   (cond ((null? names) (receiver '() body))
  131.     ((assignment? body)
  132.      (assignment-components body
  133.        (lambda (name value)
  134.          (if (eq? name (car names))
  135.          (receiver (cdr names)
  136.                (make-definition name value))
  137.          (receiver names
  138.                body)))))
  139.     ((object-type? sequence-2-type body)
  140.      (unscan-loop names (&pair-car body)
  141.        (lambda (names* body*)
  142.          (unscan-loop names* (&pair-cdr body)
  143.            (lambda (names** body**)
  144.          (receiver names**
  145.                (&typed-pair-cons sequence-2-type
  146.                          body*
  147.                          body**)))))))
  148.     ((object-type? sequence-3-type body)
  149.      (unscan-loop names (&triple-first body)
  150.        (lambda (names* body*)
  151.          (unscan-loop names* (&triple-second body)
  152.            (lambda (names** body**)
  153.          (unscan-loop names** (&triple-third body)
  154.            (lambda (names*** body***)
  155.              (receiver names***
  156.                    (&typed-triple-cons sequence-3-type
  157.                            body*
  158.                            body**
  159.                            body***)))))))))
  160.     (else
  161.      (receiver names
  162.            body))))
  163.  
  164. ;;;; Open Block
  165.  
  166. (define (make-open-block names declarations body)
  167.   (if (and (null? names)
  168.        (null? declarations))
  169.       body
  170.       (&typed-triple-cons
  171.        sequence-3-type
  172.        (vector open-block-tag names declarations)
  173.        (if (null? names)
  174.        '()
  175.        (make-sequence (map make-definition names)))
  176.        body)))
  177.  
  178. (define (open-block? object)
  179.   (and (object-type? sequence-3-type object)
  180.        (vector? (&triple-first object))
  181.        (eq? (vector-ref (&triple-first object) 0) open-block-tag)))
  182.  
  183. (define (open-block-components open-block receiver)
  184.   (receiver (vector-ref (&triple-first open-block) 1)
  185.         (vector-ref (&triple-first open-block) 2)
  186.         (&triple-third open-block)))