DataMuseum.dk

top - metrics - download

    Length: 6617 (0x19d9)
    Types: TextFile
    Names: »scan.scm.11«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/scan.scm.11« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Definition Scanner

(declare (usual-integrations))
\f


;;; Scanning of internal definitions is necessary to reduce the number
;;; of "real auxiliary" variables in the system.  These bindings are
;;; maintained in alists by the microcode, and cannot be compiled as
;;; ordinary formals can.

;;; The following support is provided.  SCAN-DEFINES will find the
;;; top-level definitions in a sequence, and returns an ordered list
;;; of those names, and a new sequence in which those definitions are
;;; replaced by assignments.  UNSCAN-DEFINES will invert that.

;;; The Open Block abstraction can be used to store scanned
;;; definitions in code, which is extremely useful for code analysis
;;; and transformation.  The supplied procedures, MAKE-OPEN-BLOCK and
;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
;;; UNSCAN-DEFINES, respectively.

(define scan-defines)
(define unscan-defines)
(define make-open-block)
(define open-block?)
(define open-block-components)

(let ((open-block-tag (make-named-tag "OPEN-BLOCK"))
      (sequence-2-type (microcode-type 'SEQUENCE-2))
      (sequence-3-type (microcode-type 'SEQUENCE-3))
      (null-sequence '(NULL-SEQUENCE)))
\f


;;;; Scanning

;;; This depends on the fact that the lambda abstraction will preserve
;;; the order of the auxiliaries.  That is, giving MAKE-LAMBDA a list
;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an
;;; EQUAL?  list.

(set! scan-defines
(named-lambda (scan-defines expression receiver)
  ((scan-loop expression receiver) '() null-sequence)))

(define (scan-loop expression receiver)
  (cond ((primitive-type? sequence-2-type expression)
	 (scan-loop (&pair-cdr expression)
		    (scan-loop (&pair-car expression)
			       receiver)))
	((primitive-type? sequence-3-type expression)
	 (let ((first (&triple-first expression)))
	   (if (conjunction (pair? first) (eq? (car first) open-block-tag))
	       (lambda (auxiliary expression*)
		 (receiver (append (cdr first) auxiliary)
			   (cons-sequence (&triple-third expression)
					  expression*)))
	       (scan-loop (&triple-third expression)
			  (scan-loop (&triple-second expression)
				     (scan-loop first
						receiver))))))
	((definition? expression)
	 (definition-components expression
	   (lambda (name value)
	     (lambda (auxiliary expression*)
	       (receiver (cons name auxiliary)
			 (cons-sequence (make-assignment name value)
					expression*))))))
	(else
	 (lambda (auxiliary expression*)
	   (receiver auxiliary
		     (cons-sequence expression expression*))))))

(define (cons-sequence action sequence)
  (cond ((primitive-type? sequence-2-type sequence)
	 (&typed-triple-cons sequence-3-type
			     action
			     (&pair-car sequence)
			     (&pair-cdr sequence)))
	((eq? sequence null-sequence)
	 action)
	(else
	 (&typed-pair-cons sequence-2-type action sequence))))
\f


(set! unscan-defines
(named-lambda (unscan-defines auxiliary expression)
  (unscan-loop auxiliary expression
    (lambda (auxiliary* expression*)
      (if (not (null? auxiliary*))
	  (error "Extraneous auxiliaries -- get a wizard"
		 'UNSCAN-DEFINES
		 auxiliary*))
      expression*))))

(define (unscan-loop auxiliary expression receiver)
  (cond ((assignment? expression)
	 (assignment-components expression
	   (lambda (name value)
	     (if (eq? name (car auxiliary))
		 (receiver (cdr auxiliary)
			   (make-definition name value))
		 (receiver auxiliary
			   expression)))))
	((primitive-type? sequence-2-type expression)
	 (unscan-loop auxiliary (&pair-car expression)
	   (lambda (auxiliary* expression*)
	     (unscan-loop auxiliary* (&pair-cdr expression)
	       (lambda (auxiliary** expression**)
		 (receiver auxiliary**
			   (&typed-pair-cons sequence-2-type
					     expression*
					     expression**)))))))
	((primitive-type? sequence-3-type expression)
	 (unscan-loop auxiliary (&triple-first expression)
	   (lambda (auxiliary* expression*)
	     (unscan-loop auxiliary* (&triple-second expression)
	       (lambda (auxiliary** expression**)
		 (unscan-loop auxiliary** (&triple-third expression)
		   (lambda (auxiliary*** expression***)
		     (receiver auxiliary***
			       (&typed-triple-cons sequence-3-type
						   expression*
						   expression**
						   expression***)))))))))
	(else
	 (receiver auxiliary
		   expression))))
\f


;;;; Open Block

(set! make-open-block
(named-lambda (make-open-block auxiliary expression)
  (if (null? auxiliary)
      expression
      (&typed-triple-cons
       sequence-3-type
       (cons open-block-tag auxiliary)
       (make-sequence
	(mapcar (lambda (name)
		  (make-definition name (make-unassigned-object)))
		auxiliary))
       expression))))

(set! open-block?
(named-lambda (open-block? object)
  (conjunction (primitive-type? sequence-3-type object)
	       (pair? (&triple-first object))
	       (eq? (car (&triple-first object)) open-block-tag))))

(set! open-block-components
(named-lambda (open-block-components open-block receiver)
  (receiver (cdr (&triple-first open-block))
	    (&triple-third open-block))))

;;; end LET
)