DataMuseum.dk

top - download

    Length: 10850 (0x2a62)
    Types: TextFile
    Names: »xsubst.scm.86«

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

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.
;;;

;;;; Integration of Primitives

(declare (usual-integrations))

;;; This procedure makes a copy of its input, in which all declared
;;; primitive procedure substitutions have been effected, and in which
;;; all variables are maximally shared.

(define integrate-expression
  (let ()

(define (integrate-top-level expression receiver)
  (((integrate-expression expression) (global-environment) (empty-subst))
   (lambda (references side-effects expression*)
     (receiver references
	       side-effects
	       (if (open-block? expression*)
		   (open-block-components expression* unscan-defines)
		   expression*)))))
\f


;;;; Merge
;;;  Warning!  This is a very hairy thing.

;;; This program is structured in a new way.  The basic idea is that
;;; most of the program is concerned with walking over code and
;;; identifying subexpressions, and only a little bit of it cares
;;; about what arguments and values are actually being passed around.

;;; To accomplish this, we start off with the standard code-walking
;;; dispatcher, which identifies each interesting kind of
;;; subexpression and calls the correct integrator on it.  The
;;; integrators, however, aren't supposed to know what their argument
;;; structure is, so the value of an integrator is an "argument
;;; receiver", which, when passed the arguments, produces a "value
;;; transmitter", which, when passed a "value receiver", passes the
;;; values to it.

;;; Well, the most important thing needed is a combinator mechanism,
;;; which is MERGE.  MERGE knows all about the argument and value
;;; structure, and lets its caller know nothing more than that one of
;;; the values is a copy of the input expression.  So MERGE has as its
;;; first argument a combinator which is given all of the
;;; subexpression values to recombine into a new expression.  This new
;;; expression is then tucked back into the value structure invisibly.

(define ((merge combinator . arg-receivers) environment subst)
  (define (collect-values arg-receivers receiver)
    (((car arg-receivers) environment subst)
     (if (null? (cdr arg-receivers))
	 (lambda (references side-effects expression)
	   (receiver references
		     side-effects
		     (list expression)))
	 (lambda (references side-effects expression)
	   (collect-values (cdr arg-receivers)
			   (lambda (references* side-effects* expressions)
			     (receiver (eq?-union references references*)
				       (eq?-union side-effects side-effects*)
				       (cons expression expressions))))))))
  (if (null? arg-receivers)
      (transmit '() '() (combinator))
      (collect-values arg-receivers
		      (lambda (references* side-effects* expressions)
			(transmit references*
				  side-effects*
				  (apply combinator expressions))))))

(define (eq?-union set1 set2)
  ((negative-list-transformer (lambda (element)
				(memq element set2))
			      set2)
   set1))
\f


(define ((bind names values arg-receiver) environment subst)
  (arg-receiver environment (bind-subst names values subst)))

(define (shadow names arg-receiver)
  (let ((differential (negative-list-transformer (lambda (element)
						   (memq element names))
						 '())))
    (lambda (environment subst)
      ((arg-receiver (empty-environment) (shadow-subst names subst))
       (lambda (references side-effects expression)
	 (transmit (differential references)
		   (differential side-effects)
		   expression))))))

(define ((transmit-constant constant) value-receiver)
  (value-receiver '() '() constant))

(define ((transmit-variable variable) value-receiver)
  (value-receiver (list (variable-name variable)) '() variable))

(define ((transmit-assignment-variable variable) value-receiver)
  (value-receiver '() (list (variable-name variable)) variable))

(define ((transmit references side-effects expression) value-receiver)
  (value-receiver references side-effects expression))

(define (integrate-expression expression)
  ((integrate-dispatch expression) expression))

(define (integrate-expressions expressions)
  (apply merge
	 (cons list
	       (mapcar integrate-expression expressions))))
\f


;;;; Integrators

(define (integrate-primitive-integration names values body)
  (bind names values
	(integrate-expression body)))

(define (integrate-constant constant)
  (merge (lambda () constant)))

(define (integrate-variable variable)
  (find variable transmit-constant transmit-variable))

(define (integrate-assignment variable value)
  (merge make-assignment-from-variable
	 (find variable
	       (lambda (constant)
		 (error "Can't integrate assigned variables"
			'INTEGRATE-EXPRESSION
			(variable-name variable)
			constant))
	       transmit-assignment-variable)
	 (integrate-expression value)))

(define (integrate-definition name value)
  (error "Unscanned definition encountered.  (PROCEED) to continue."
	 'INTEGRATE-EXPRESSION
	 name)
  (merge (lambda (value*) (make-definition name value*))
	 (integrate-expression value)))

(define (integrate-lambda pattern bound body)
  (shadow bound
	  (merge (lambda (body*) (make-lambda** pattern bound body*))
		 (integrate-expression body))))

(define (integrate-open-block auxiliary expression)
  (shadow auxiliary
	  (merge (lambda (expression*) (make-open-block auxiliary expression*))
		 (integrate-expression expression))))
\f


(define (integrate-combination operator operands)
  (merge make-combination
	 (integrate-expression operator)
	 (integrate-expressions operands)))

(define (integrate-sequence actions)
  (merge make-sequence
	 (integrate-expressions actions)))

(define (integrate-conditional predicate consequent alternative)
  (merge make-conditional
	 (integrate-expression predicate)
	 (integrate-expression consequent)
	 (integrate-expression alternative)))

(define (integrate-disjunction predicate alternative)
  (merge make-disjunction
	 (integrate-expression predicate)
	 (integrate-expression alternative)))

(define (integrate-comment text expression)
  (merge (lambda (expression*) (make-comment text expression*))
	 (integrate-expression expression)))

(define (integrate-declaration text expression)
  (merge (lambda (expression*) (make-declaration text expression*))
	 (integrate-expression expression)))

(define (integrate-delay expression)
  (merge make-delay
	 (integrate-expression expression)))

(define (integrate-access environment name)
  (merge (lambda (environment*) (make-access environment* name))
	 (integrate-expression environment)))

(define (integrate-in-package environment expression)
  (merge make-in-package
	 (integrate-expression environment)
	 (lambda ((environment subst) receiver)
	   (integrate-top-level expression receiver))))
\f


;;;; Environment Stuff

(define ((find variable if-constant if-variable) environment subst)
  (let ((ass (assq (variable-name variable) subst)))
    (if (conjunction ass (not (eq? (cdr ass) unbound-name-tag)))
	(if-constant (cdr ass))
	(if-variable (environment variable)))))

(define ((global-environment) variable)
  variable)

(define (empty-environment)
  (let ((interns '()))
    (lambda (variable)
      (let ((ass (assq (variable-name variable) interns)))
	(if ass
	    (cdr ass)
	    (sequence (set! interns
			    (cons (cons (variable-name variable) variable)
				  interns))
		      variable))))))

(define (empty-subst)
  '())

(define (bind-subst names values subst)
  (mapcar* subst cons names values))

(define (shadow-subst names subst)
  (mapcar* subst
	   (lambda (name)
	     (cons name unbound-name-tag))
	   names))

(define unbound-name-tag
  '(UNBOUND-NAME))
\f


;;;; Dispatch

(define ((component-integrator components integrator) object)
  (components object integrator))

(define integrate-dispatch
  (make-type-dispatcher
   `((,primitive-integration-type
      ,(component-integrator primitive-integration-components
			     integrate-primitive-integration))
     (,variable-type ,integrate-variable)
     (,assignment-type
      ,(component-integrator assignment-components-with-variable
			     integrate-assignment))
     (,definition-type
      ,(component-integrator definition-components integrate-definition))
     (,lambda-type
      ,(component-integrator lambda-components** integrate-lambda))
     (,open-block-type
      ,(component-integrator open-block-components integrate-open-block))
     (,combination-type
      ,(component-integrator combination-components integrate-combination))
     (,sequence-type
      ,(component-integrator sequence-components integrate-sequence))
     (,conditional-type
      ,(component-integrator conditional-components integrate-conditional))
     (,disjunction-type
      ,(component-integrator disjunction-components integrate-disjunction))
     (,comment-type
      ,(component-integrator comment-components integrate-comment))
     (,declaration-type
      ,(component-integrator declaration-components integrate-declaration))
     (,delay-type
      ,(component-integrator delay-components integrate-delay))
     (,access-type
      ,(component-integrator access-components integrate-access))
     (,in-package-type
      ,(component-integrator in-package-components integrate-in-package)))
   integrate-constant))

integrate-top-level))
\f


;;; Local Modes:
;;; Scheme PRIMITIVE-INTEGRATION-COMPONENTS Indent: 1
;;; Scheme MODIFY-EXPRESSION Indent: 1
;;; Scheme BIND-NAMES Indent: 1
;;; End: