;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.44 1987/04/03 00:52:43 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.45 1987/05/19 13:38:56 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define syntax-SET!-form
(spread-arguments
(lambda (name . rest)
- ((syntax-extended-assignment name)
+ ((invert-expression (syntax-expression name))
(expand-binding-value rest)))))
(define syntax-DEFINE-form
(lambda (predicate consequent . rest)
(make-conditional (syntax-expression predicate)
(syntax-expression consequent)
- (cond ((null? rest)
- false)
+ (cond ((null? rest) undefined-conditional-branch)
((null? (cdr rest))
(syntax-expression (car rest)))
(else
(syntax-error "Too many forms" (cdr rest))))))))
+(define syntax-CONJUNCTION-form
+ (spread-arguments
+ (lambda forms
+ (expand-conjunction forms))))
+
+(define syntax-DISJUNCTION-form
+ (spread-arguments
+ (lambda forms
+ (expand-disjunction forms))))
+\f
(define syntax-COND-form
(let ()
(define (process-cond-clauses clause rest)
(if (null? rest)
(syntax-sequence (cdr clause))
(syntax-error "ELSE not last clause" rest)))
- ((null? rest)
- (if (cdr clause)
- (make-conjunction (syntax-expression (car clause))
- (syntax-sequence (cdr clause)))
- (syntax-expression (car clause))))
((null? (cdr clause))
(make-disjunction (syntax-expression (car clause))
- (process-cond-clauses (car rest)
- (cdr rest))))
+ (if (null? rest)
+ undefined-conditional-branch
+ (process-cond-clauses (car rest)
+ (cdr rest)))))
((and (pair? (cdr clause))
(eq? (cadr clause) '=>))
(syntax-expression
`((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '())
,(car clause)
- (DELAY ,@(cddr clause))
- (DELAY (COND ,@rest)))))
+ (LAMBDA () ,@(cddr clause))
+ (LAMBDA ()
+ ,(if (null? rest)
+ undefined-conditional-branch
+ `(COND ,@rest))))))
(else
(make-conditional (syntax-expression (car clause))
(syntax-sequence (cdr clause))
- (process-cond-clauses (car rest)
- (cdr rest))))))
+ (if (null? rest)
+ undefined-conditional-branch
+ (process-cond-clauses (car rest)
+ (cdr rest)))))))
(spread-arguments
(lambda (clause . rest)
(process-cond-clauses clause rest)))))
(define (cond-=>-helper form1-result thunk2 thunk3)
(if form1-result
- ((force thunk2) form1-result)
- (force thunk3)))
-
-(define (make-funcall name . args)
- (make-combination (make-variable name) args))
-\f
-(define syntax-CONJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-conjunction forms))))
-
-(define syntax-DISJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-disjunction forms))))
+ ((thunk2) form1-result)
+ (thunk3)))
\f
;;;; Procedures
(define (syntax-fluid-bindings bindings receiver)
(if (null? bindings)
- (receiver '() '() '() '())
+ (receiver '() '() (list false) (list false))
(syntax-fluid-bindings (cdr bindings)
(lambda (names values transfers-in transfers-out)
(let ((binding (car bindings)))
(if (pair? binding)
- (let ((transfer
- (let ((assignment
- (syntax-extended-assignment (car binding))))
- (lambda (target source)
- (make-assignment
- target
- (assignment
- (make-assignment source
- unassigned-object))))))
+ (let ((transfer
+ (let ((reference (syntax-expression (car binding))))
+ (let ((assignment (invert-expression reference)))
+ (lambda (target source)
+ (make-sequence*
+ (make-assignment target reference)
+ (assignment (make-variable source))
+ (make-assignment source
+ unassigned-object))))))
(value (expand-binding-value (cdr binding)))
(inside-name
(string->uninterned-symbol "INSIDE-PLACEHOLDER"))
\f
;;;; Extended Assignment Syntax
-(define (syntax-extended-assignment expression)
- (invert-expression (syntax-expression expression)))
-
(define (invert-expression target)
(cond ((variable? target)
(invert-variable (variable-name target)))
))))
;;; end SYNTAXER-PACKAGE
-)
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.42 1987/03/17 18:54:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.43 1987/05/19 13:38:31 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define (unsyntax-ASSIGNMENT-object assignment)
(assignment-components assignment
(lambda (name value)
- `(SET! ,name ,(unsyntax-object value)))))
+ `(SET! ,name
+ ,@(if (unassigned-object? value)
+ '()
+ `(,(unsyntax-object value)))))))
(define ((definition-unexpander key lambda-key) name value)
(if (lambda? value)
(define (unsyntax-conditional predicate consequent alternative)
(cond ((false? alternative)
- (if (conditional? consequent)
- `(AND ,@(unexpand-conjunction predicate consequent))
- `(IF ,(unsyntax-object predicate)
- ,(unsyntax-object consequent))))
+ `(AND ,@(unexpand-conjunction predicate consequent)))
+ ((eq? alternative undefined-conditional-branch)
+ `(IF ,(unsyntax-object predicate)
+ ,(unsyntax-object consequent)))
((conditional? alternative)
`(COND ,@(unsyntax-cond-conditional predicate
consequent
,@(unsyntax-cond-alternative alternative)))
(define (unsyntax-cond-alternative alternative)
- (cond ((false? alternative) '())
+ (cond ((eq? alternative undefined-conditional-branch) '())
((disjunction? alternative)
(disjunction-components alternative unsyntax-cond-disjunction))
((conditional? alternative)
(combination-components body
(lambda (operator operands)
`(FLUID-LET ,(unsyntax-let-bindings
- (map extract-transfer-var
- (lambda-components** (car operands)
- (lambda (name req opt rest body)
- (sequence-actions body))))
- (every-other values))
+ (extract-transfer-variables
+ (sequence-actions (lambda-body (car operands))))
+ (let every-other ((values values))
+ (if (null? values)
+ '()
+ (cons (car values) (every-other (cddr 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 (extract-transfer-variables actions)
+ (if (assignment? (car actions))
+ (cons (unsyntax-object (assignment-value (car actions)))
+ (extract-transfer-variables (cdddr actions)))
+ '()))
\f
(define ((unsyntax-deep-or-common-FLUID-LET name prim)
ignored-required ignored-operands body)
projects / mit-scheme.git / commitdiff