DataMuseum.dk

top - download

    Length: 13916 (0x365c)
    Types: TextFile
    Names: »unsyn.scm.230«

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

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

;;;; UNSYNTAX: SCODE -> S-Expressions

(declare (usual-integrations))
\f


(define unsyntax)
(define make-unsyntax-table)
(define unsyntax-table?)
(define current-unsyntax-table)
(define set-current-unsyntax-table!)
(define with-unsyntax-table)

(let ()

(set! unsyntax
(named-lambda (unsyntax scode #!optional unsyntax-table)
  (let ((object (if (compound-procedure? scode)
		    (procedure-lambda scode)
		    scode)))
    (if (unassigned? unsyntax-table)
	(unsyntax-object object)
	(with-unsyntax-table unsyntax-table
	  (lambda ()
	    (unsyntax-object object)))))))

(define (unsyntax-object object)
  ((unsyntax-dispatcher object) object))

(define (unsyntax-objects objects)
  (if (null? objects)
      '()
      (cons (unsyntax-object (car objects))
	    (unsyntax-objects (cdr objects)))))
\f


;;;; Unsyntax Quanta

(define (unsyntax-QUOTATION quotation)
  `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation))))

(define (unsyntax-constant object)
  `(QUOTE ,object))

(define (unsyntax-VARIABLE-object object)
  (variable-name object))

(define (unsyntax-ACCESS-object object)
  `(ACCESS ,@(unexpand-access object)))

(define (unexpand-access object)
  (if (access? object)
      (access-components object
	(lambda (environment name)
	  `(,name ,@(unexpand-access environment))))
      `(,(unsyntax-object object))))

(define (unsyntax-UNBOUND?-object unbound?)
  `(UNBOUND? ,(unbound?-name unbound?)))

(define (unsyntax-UNASSIGNED?-object unassigned?)
  `(UNASSIGNED? ,(unassigned?-name unassigned?)))

(define (unsyntax-DEFINITION-object definition)
  (definition-components definition unexpand-definition))

(define (unsyntax-ASSIGNMENT-object assignment)
  (assignment-components assignment unexpand-assignment))

(define ((definition-unexpander key lambda-key) name value)
  (if (lambda? value)
      (lambda-components* value
	(lambda (lambda-name required optional rest body)
	  (if (eq? lambda-name name)
	      `(,lambda-key (,name . ,(lambda-list required optional rest))
		 ,@(unsyntax-sequence body))
	      `(,key ,name ,@(unexpand-binding-value value)))))
      `(,key ,name ,@(unexpand-binding-value value))))

(define (unexpand-binding-value value)
  (if (unassigned-object? value)
      '()
      `(,(unsyntax-object value))))

(define unexpand-definition (definition-unexpander 'DEFINE 'DEFINE))
(define unexpand-assignment (definition-unexpander 'SET! 'DEFINE-EXPORT))

(define (unsyntax-COMMENT-object comment)
  (comment-components comment
    (lambda (text expression)
      `(COMMENT ,text ,(unsyntax-object expression)))))

(define (unsyntax-DECLARATION-object declaration)
  (declaration-components declaration
    (lambda (text expression)
      `(LOCAL-DECLARE ,text ,(unsyntax-object expression)))))

(define (unsyntax-SEQUENCE-object sequence)
  `(SEQUENCE ,@(unsyntax-sequence sequence)))

(define (unsyntax-sequence sequence)
  (unsyntax-objects (sequence-actions sequence)))

(define (unsyntax-OPEN-BLOCK-object open-block)
  (open-block-components open-block
    (lambda (auxiliary expression)
      `(OPEN-BLOCK ,auxiliary ,@(unsyntax-sequence expression)))))

(define (unsyntax-DELAY-object object)
  `(DELAY ,(unsyntax-object (delay-expression object))))

(define (unsyntax-IN-PACKAGE-object in-package)
  (in-package-components in-package
    (lambda (environment expression)
      `(IN-PACKAGE ,(unsyntax-object environment)
	 ,@(unsyntax-sequence expression)))))

(define (unsyntax-THE-ENVIRONMENT-object object)
  `(THE-ENVIRONMENT))
\f


(define (unsyntax-CONDITIONAL-object conditional)
  (conditional-components conditional unsyntax-conditional))

(define (unsyntax-conditional predicate consequent alternative)
  (cond ((false? alternative)
	 `(CONJUNCTION ,@(unexpand-conjunction predicate
					       consequent)))
	((conditional? alternative)
	 `(COND ,@(unsyntax-cond-conditional predicate
					     consequent
					     alternative)))
	(else
	 `(IF ,(unsyntax-object predicate)
	      ,(unsyntax-object consequent)
	      ,(unsyntax-object alternative)))))

(define (unsyntax-cond-conditional predicate consequent alternative)
  `((,(unsyntax-object predicate) ,@(unsyntax-sequence consequent))
    ,@(unsyntax-cond-alternative alternative)))

(define (unsyntax-cond-disjunction predicate alternative)
  `((,(unsyntax-object predicate))
    ,@(unsyntax-cond-alternative alternative)))

(define (unsyntax-cond-alternative alternative)
  (cond ((false? alternative)
	 '())
	((disjunction? alternative)
	 (disjunction-components alternative unsyntax-cond-disjunction))
	((conditional? alternative)
	 (conditional-components alternative unsyntax-cond-conditional))
	(else
	 `((ELSE ,@(unsyntax-sequence alternative))))))

(define (unexpand-conjunction predicate consequent)
  (if (conditional? consequent)
      `(,(unsyntax-object predicate)
	,@(conditional-components consequent
	    (lambda (predicate consequent alternative)
	      (if (false? alternative)
		  (unexpand-conjunction predicate consequent)
		  `(,(unsyntax-conditional predicate
					   consequent
					   alternative))))))
      `(,(unsyntax-object predicate)
	,(unsyntax-object consequent))))

(define (unsyntax-DISJUNCTION-object object)
  `(DISJUNCTION ,@(disjunction-components object unexpand-disjunction)))

(define (unexpand-disjunction predicate alternative)
  `(,(unsyntax-object predicate)
    ,@(if (disjunction? alternative)
	  (disjunction-components alternative unexpand-disjunction)
	  `(,(unsyntax-object alternative)))))
\f


;;;; Lambdas

(define (unsyntax-LAMBDA-object lambda)
  (lambda-components* lambda
    (lambda (name required optional rest body)
      (let ((bvl (lambda-list required optional rest))
	    (body (unsyntax-sequence body)))
	(if (eq? name lambda-tag:unnamed)
	    `(LAMBDA ,bvl ,@body)
	    `(NAMED-LAMBDA (,name . ,bvl) ,@body))))))

(define (lambda-list required optional rest)
  (cond ((null? rest)
	 (if (null? optional)
	     required
	     `(,@required ,(access lambda-optional-tag lambda-package)
			  ,@optional)))
	((null? optional)
	 `(,@required . ,rest))
	(else
	 `(,@required ,(access lambda-optional-tag lambda-package)
		      ,@optional . ,rest))))

(define (lambda-components* lambda receiver)
  (lambda-components lambda
    (lambda (name required optional rest auxiliary body)
      (receiver name required optional rest
		(unscan-defines auxiliary body)))))
\f


;;;; Combinations

(define (unsyntax-COMBINATION-object combination)
  (combination-components combination
    (lambda (operator operands)
      (cond ((variable? operator)
	     (let ((name (variable-name operator)))
	       (cond ((eq? name 'ERROR-PROCEDURE)
		      (unsyntax-error-like-form operands 'ERROR))
		     ((eq? name 'BREAKPOINT-PROCEDURE)
		      (unsyntax-error-like-form operands 'BKPT))
		     (else
		      (cons (unsyntax-object operator)
			    (unsyntax-objects operands))))))
	    ((lambda? operator)
	     (lambda-components* operator
	       (lambda (name required optional rest body)
		 (if (conjunction (null? optional)
				  (null? rest))
		     (cond ((disjunction (eq? name lambda-tag:unnamed)
					 (eq? name lambda-tag:let))
			    `(LET ,(unsyntax-let-bindings required operands)
			       ,@(unsyntax-sequence body)))
			   ((eq? name lambda-tag:fluid-let)
			    (unsyntax-fluid-let required operands body))
			   ((eq? name lambda-tag:make-environment)
			    (unsyntax-make-environment required operands body))
			   ((eq? name lambda-tag:make-package)
			    (unsyntax-make-package required operands body))
			   (else
			    `(LET ,name
			       ,(unsyntax-let-bindings required operands)
			       ,@(unsyntax-sequence body))))
		     (cons (unsyntax-object operator)
			   (unsyntax-objects operands))))))
	    (else
	     (cons (unsyntax-object operator)
		   (unsyntax-objects operands)))))))

(define (unsyntax-error-like-form operands name)
  (cons* name
	 (unsyntax-object (first operands))
	 (let ((operand (second operands)))
	   (cond ((conjunction (access? operand)
			       (null? (access-environment operand))
			       (eq? (access-name operand)
				    '*THE-NON-PRINTING-OBJECT*))
		  '())
		 ((combination? operand)
		  (combination-components operand
		    (lambda (operator operands)
		      (if (conjunction (access? operator)
				       (access-components operator
					 (lambda (environment name)
					   (conjunction (eq? name 'LIST)
							(null? environment)))))
			  (unsyntax-objects operands)
			  `(,(unsyntax-object operand))))))
		 (else
		  `(,(unsyntax-object operand)))))))
\f


(define (unsyntax-FLUID-LET names values body)
  (combination-components body
    (lambda (operator operands)
      `(FLUID-LET ,(unsyntax-let-bindings
		    (mapcar extract-transfer-var
			    (lambda-components* (car operands)
			      (lambda (name req opt rest body)
				(sequence-actions body))))
		    (every-other values))
	 ,@(lambda-components* (cadr operands)
	     (lambda (name required optional rest body)
	       (unsyntax-sequence body)))))))

(define (every-other list)
  (if (null? list)
      '()
      (cons (car list)
	    (every-other (cddr list)))))

(define (extract-transfer-var assignment)
  (assignment-components assignment
    (lambda (name value)
      (cond ((assignment? value)
	     (assignment-components value
	       (lambda (name value)
		 name)))
	    ((combination? value)
	     (combination-components value
	       (lambda (operator operands)
		 (cond ((eq? operator lexical-assignment)
			`(ACCESS ,(cadr operands)
				 ,@(unexpand-access (car operands))))
		       (else
			(error "Unknown SCODE form" 'FLUID-LET
			       assignment))))))
	    (else
	     (error "Unknown SCODE form" 'FLUID-LET assignment))))))

(define (unsyntax-MAKE-ENVIRONMENT names values body)
  `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body))))

(define (unsyntax-MAKE-PACKAGE names values body)
  `(MAKE-PACKAGE ,(car names)
		 ,(unsyntax-let-bindings (cdr names)
					 (cdr values))
     ,@(except-last-pair (cdr (unsyntax-sequence body)))))

(define (unsyntax-let-bindings names values)
  (mapcar unsyntax-let-binding names values))

(define (unsyntax-let-binding name value)
  `(,name ,@(unexpand-binding-value value)))
\f


;;;; Unsyntax Tables

(define unsyntax-table-tag
  '(UNSYNTAX-TABLE))

(set! make-unsyntax-table
(named-lambda (make-unsyntax-table alist)
  (cons unsyntax-table-tag
	(make-type-dispatcher alist identity-procedure))))

(set! unsyntax-table?
(named-lambda (unsyntax-table? object)
  (conjunction (pair? object)
	       (eq? (car object) unsyntax-table-tag))))

(set! current-unsyntax-table
(named-lambda (current-unsyntax-table)
  *unsyntax-table))

(set! set-current-unsyntax-table!
(named-lambda (set-current-unsyntax-table! table)
  (if (not (unsyntax-table? table))
      (error "Not an unsyntax table" 'SET-CURRENT-UNSYNTAX-TABLE! table))
  (set-table! table)))

(set! with-unsyntax-table
(named-lambda (with-unsyntax-table table thunk)
  (define old-table)
  (if (not (unsyntax-table? table))
      (error "Not an unsyntax table" 'WITH-UNSYNTAX-TABLE table))
  (dynamic-wind (lambda ()
		  (set! old-table (set-table! table)))
		thunk
		(lambda ()
		  (set! table (set-table! old-table))))))

(define unsyntax-dispatcher)
(define *unsyntax-table)

(define (set-table! table)
  (set! unsyntax-dispatcher (cdr table))
  (set! *unsyntax-table table))
\f


;;;; Default Unsyntax Table

(set-table!
 (make-unsyntax-table
  `((,(microcode-type-object 'LIST) ,unsyntax-constant)
    (,symbol-type ,unsyntax-constant)
    (,variable-type ,unsyntax-VARIABLE-object)
    (,unbound?-type ,unsyntax-UNBOUND?-object)
    (,unassigned?-type ,unsyntax-UNASSIGNED?-object)
    (,combination-type ,unsyntax-COMBINATION-object)
    (,quotation-type ,unsyntax-QUOTATION)
    (,access-type ,unsyntax-ACCESS-object)
    (,definition-type ,unsyntax-DEFINITION-object)
    (,assignment-type ,unsyntax-ASSIGNMENT-object)
    (,conditional-type ,unsyntax-CONDITIONAL-object)
    (,disjunction-type ,unsyntax-DISJUNCTION-object)
    (,comment-type ,unsyntax-COMMENT-object)
    (,declaration-type ,unsyntax-DECLARATION-object)
    (,sequence-type ,unsyntax-SEQUENCE-object)
    (,open-block-type ,unsyntax-OPEN-BLOCK-object)
    (,delay-type ,unsyntax-DELAY-object)
    (,in-package-type ,unsyntax-IN-PACKAGE-object)
    (,the-environment-type ,unsyntax-THE-ENVIRONMENT-object)
    (,lambda-type ,unsyntax-LAMBDA-object))))
\f


;;; end LET
)