diff options
Diffstat (limited to 'r4rsyn.scm')
| -rw-r--r-- | r4rsyn.scm | 542 |
1 files changed, 542 insertions, 0 deletions
diff --git a/r4rsyn.scm b/r4rsyn.scm new file mode 100644 index 0000000..500d68c --- /dev/null +++ b/r4rsyn.scm @@ -0,0 +1,542 @@ +;;; "r4rsyn.scm" R4RS syntax -*-Scheme-*- +;;; Copyright (c) 1989-91 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. + +;;;; R4RS Syntax + +(define scheme-syntactic-environment #f) + +(define (initialize-scheme-syntactic-environment!) + (set! scheme-syntactic-environment + ((compose-macrologies + (make-core-primitive-macrology) + (make-binding-macrology syntactic-binding-theory + 'LET-SYNTAX 'LETREC-SYNTAX 'DEFINE-SYNTAX) + (make-binding-macrology variable-binding-theory + 'LET 'LETREC 'DEFINE) + (make-r4rs-primitive-macrology) + (make-core-expander-macrology) + (make-syntax-rules-macrology)) + root-syntactic-environment))) + +;;;; Core Primitives + +(define (make-core-primitive-macrology) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (define-classifier 'BEGIN + (lambda (form environment definition-environment) + (syntax-check '(KEYWORD * FORM) form) + (make-body-item (classify/subforms (cdr form) + environment + definition-environment)))) + + (define-compiler 'DELAY + (lambda (form environment) + (syntax-check '(KEYWORD EXPRESSION) form) + (output/delay + (compile/subexpression (cadr form) + environment)))) + + (define-compiler 'IF + (lambda (form environment) + (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form) + (output/conditional + (compile/subexpression (cadr form) environment) + (compile/subexpression (caddr form) environment) + (if (null? (cdddr form)) + (output/unspecific) + (compile/subexpression (cadddr form) + environment))))) + + (define-compiler 'QUOTE + (lambda (form environment) + environment ;ignore + (syntax-check '(KEYWORD DATUM) form) + (output/literal-quoted (strip-syntactic-closures (cadr form)))))))) + +;;;; Bindings + +(define (make-binding-macrology binding-theory + let-keyword letrec-keyword define-keyword) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (let ((pattern/let-like + '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM)) + (compile/let-like + (lambda (form environment body-environment output/let) + ;; Force evaluation order. + (let ((bindings + (let loop + ((bindings + (map (lambda (binding) + (cons (car binding) + (classify/subexpression + (cadr binding) + environment))) + (cadr form)))) + (if (null? bindings) + '() + (let ((binding + (binding-theory body-environment + (caar bindings) + (cdar bindings)))) + (if binding + (cons binding (loop (cdr bindings))) + (loop (cdr bindings)))))))) + (output/let (map car bindings) + (map (lambda (binding) + (compile-item/expression (cdr binding))) + bindings) + (compile-item/expression + (classify/body (cddr form) + body-environment))))))) + + (define-compiler let-keyword + (lambda (form environment) + (syntax-check pattern/let-like form) + (compile/let-like form + environment + (internal-syntactic-environment environment) + output/let))) + + (define-compiler letrec-keyword + (lambda (form environment) + (syntax-check pattern/let-like form) + (let ((environment (internal-syntactic-environment environment))) + (reserve-names! (map car (cadr form)) environment) + (compile/let-like form + environment + environment + output/letrec))))) + + (define-classifier define-keyword + (lambda (form environment definition-environment) + (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form) + (syntactic-environment/define! definition-environment + (cadr form) + (make-reserved-name-item)) + (make-definition-item binding-theory + (cadr form) + (make-promise + (lambda () + (classify/subexpression + (caddr form) + environment))))))))) + +;;;; Bodies + +(define (classify/body forms environment) + (let ((environment (internal-syntactic-environment environment))) + (let forms-loop + ((forms forms) + (bindings '())) + (if (null? forms) + (syntax-error "no expressions in body" + "") + (let items-loop + ((items + (item->list + (classify/subform (car forms) + environment + environment))) + (bindings bindings)) + (cond ((null? items) + (forms-loop (cdr forms) + bindings)) + ((definition-item? (car items)) + (items-loop (cdr items) + (let ((binding + (bind-definition-item! environment + (car items)))) + (if binding + (cons binding bindings) + bindings)))) + (else + (let ((body + (make-body-item + (append items + (flatten-body-items + (classify/subforms + (cdr forms) + environment + environment)))))) + (make-expression-item + (lambda () + (output/letrec + (map car bindings) + (map (lambda (binding) + (compile-item/expression (cdr binding))) + bindings) + (compile-item/expression body))) forms))))))))) + +;;;; R4RS Primitives + +(define (make-r4rs-primitive-macrology) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (define (transformer-keyword expander->classifier) + (lambda (form environment definition-environment) + definition-environment ;ignore + (syntax-check '(KEYWORD EXPRESSION) form) + (let ((item + (classify/subexpression (cadr form) + scheme-syntactic-environment))) + (let ((transformer (base:eval (compile-item/expression item)))) + (if (procedure? transformer) + (make-keyword-item + (expander->classifier transformer environment) item) + (syntax-error "transformer not a procedure" + transformer)))))) + + (define-classifier 'TRANSFORMER + ;; "Syntactic Closures" transformer + (transformer-keyword sc-expander->classifier)) + + (define-classifier 'ER-TRANSFORMER + ;; "Explicit Renaming" transformer + (transformer-keyword er-expander->classifier)) + + (define-compiler 'LAMBDA + (lambda (form environment) + (syntax-check '(KEYWORD R4RS-BVL + FORM) form) + (let ((environment (internal-syntactic-environment environment))) + ;; Force order -- bind names before classifying body. + (let ((bvl-description + (let ((rename + (lambda (identifier) + (bind-variable! environment identifier)))) + (let loop ((bvl (cadr form))) + (cond ((null? bvl) + '()) + ((pair? bvl) + (cons (rename (car bvl)) (loop (cdr bvl)))) + (else + (rename bvl))))))) + (output/lambda bvl-description + (compile-item/expression + (classify/body (cddr form) + environment))))))) + + (define-compiler 'SET! + (lambda (form environment) + (syntax-check '(KEYWORD FORM EXPRESSION) form) + (output/assignment + (let loop + ((form (cadr form)) + (environment environment)) + (cond ((identifier? form) + (let ((item + (syntactic-environment/lookup environment form))) + (if (variable-item? item) + (variable-item/name item) + (slib:error "target of assignment not a variable" + form)))) + ((syntactic-closure? form) + (let ((form (syntactic-closure/form form)) + (environment + (filter-syntactic-environment + (syntactic-closure/free-names form) + environment + (syntactic-closure/environment form)))) + (loop form + environment))) + (else + (slib:error "target of assignment not an identifier" + form)))) + (compile/subexpression (caddr form) + environment)))) + + ;; end MAKE-R4RS-PRIMITIVE-MACROLOGY + ))) + +;;;; Core Expanders + +(define (make-core-expander-macrology) + (make-er-expander-macrology + (lambda (define-expander base-environment) + + (let ((keyword (make-syntactic-closure base-environment '() 'DEFINE))) + (define-expander 'DEFINE + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((IDENTIFIER . R4RS-BVL) + FORM) (cdr form)) + `(,keyword ,(caadr form) + (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))) + `(,keyword ,@(cdr form)))))) + + (let ((keyword (make-syntactic-closure base-environment '() 'LET))) + (define-expander 'LET + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM) + (cdr form)) + (let ((name (cadr form)) + (bindings (caddr form))) + `((,(rename 'LETREC) + ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@(cdddr form)))) + ,name) + ,@(map cadr bindings))) + `(,keyword ,@(cdr form)))))) + + (define-expander 'LET* + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((* (IDENTIFIER EXPRESSION)) + FORM) (cdr form)) + (let ((bindings (cadr form)) + (body (cddr form)) + (keyword (rename 'LET))) + (if (null? bindings) + `(,keyword ,bindings ,@body) + (let loop ((bindings bindings)) + (if (null? (cdr bindings)) + `(,keyword ,bindings ,@body) + `(,keyword (,(car bindings)) + ,(loop (cdr bindings))))))) + (ill-formed-syntax form)))) + + (define-expander 'AND + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(* EXPRESSION) (cdr form)) + (let ((operands (cdr form))) + (if (null? operands) + `#T + (let ((if-keyword (rename 'IF))) + (let loop ((operands operands)) + (if (null? (cdr operands)) + (car operands) + `(,if-keyword ,(car operands) + ,(loop (cdr operands)) + #F)))))) + (ill-formed-syntax form)))) + + (define-expander 'OR + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(* EXPRESSION) (cdr form)) + (let ((operands (cdr form))) + (if (null? operands) + `#F + (let ((let-keyword (rename 'LET)) + (if-keyword (rename 'IF)) + (temp (rename 'TEMP))) + (let loop ((operands operands)) + (if (null? (cdr operands)) + (car operands) + `(,let-keyword ((,temp ,(car operands))) + (,if-keyword ,temp + ,temp + ,(loop (cdr operands))))))))) + (ill-formed-syntax form)))) + + (define-expander 'CASE + (lambda (form rename compare) + (if (syntax-match? '(EXPRESSION + (DATUM + EXPRESSION)) (cdr form)) + (letrec + ((process-clause + (lambda (clause rest) + (cond ((null? (car clause)) + (process-rest rest)) + ((and (identifier? (car clause)) + (compare (rename 'ELSE) (car clause)) + (null? rest)) + `(,(rename 'BEGIN) ,@(cdr clause))) + ((list? (car clause)) + `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP) + ',(car clause)) + (,(rename 'BEGIN) ,@(cdr clause)) + ,(process-rest rest))) + (else + (syntax-error "ill-formed clause" clause))))) + (process-rest + (lambda (rest) + (if (null? rest) + (unspecific-expression) + (process-clause (car rest) (cdr rest)))))) + `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form))) + ,(process-clause (caddr form) (cdddr form)))) + (ill-formed-syntax form)))) + + (define-expander 'COND + (lambda (form rename compare) + (letrec + ((process-clause + (lambda (clause rest) + (cond + ((or (not (list? clause)) + (null? clause)) + (syntax-error "ill-formed clause" clause)) + ((and (identifier? (car clause)) + (compare (rename 'ELSE) (car clause))) + (cond + ((or (null? (cdr clause)) + (and (identifier? (cadr clause)) + (compare (rename '=>) (cadr clause)))) + (syntax-error "ill-formed ELSE clause" clause)) + ((not (null? rest)) + (syntax-error "misplaced ELSE clause" clause)) + (else + `(,(rename 'BEGIN) ,@(cdr clause))))) + ((null? (cdr clause)) + `(,(rename 'OR) ,(car clause) ,(process-rest rest))) + ((and (identifier? (cadr clause)) + (compare (rename '=>) (cadr clause))) + (if (and (pair? (cddr clause)) + (null? (cdddr clause))) + `(,(rename 'LET) + ((,(rename 'TEMP) ,(car clause))) + (,(rename 'IF) ,(rename 'TEMP) + (,(caddr clause) ,(rename 'TEMP)) + ,(process-rest rest))) + (syntax-error "ill-formed => clause" clause))) + (else + `(,(rename 'IF) ,(car clause) + (,(rename 'BEGIN) ,@(cdr clause)) + ,(process-rest rest)))))) + (process-rest + (lambda (rest) + (if (null? rest) + (unspecific-expression) + (process-clause (car rest) (cdr rest)))))) + (let ((clauses (cdr form))) + (if (null? clauses) + (syntax-error "no clauses" form) + (process-clause (car clauses) (cdr clauses))))))) + + (define-expander 'DO + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((* (IDENTIFIER EXPRESSION ? EXPRESSION)) + (+ EXPRESSION) + * FORM) + (cdr form)) + (let ((bindings (cadr form))) + `(,(rename 'LETREC) + ((,(rename 'DO-LOOP) + (,(rename 'LAMBDA) + ,(map car bindings) + (,(rename 'IF) ,(caaddr form) + ,(if (null? (cdaddr form)) + (unspecific-expression) + `(,(rename 'BEGIN) ,@(cdaddr form))) + (,(rename 'BEGIN) + ,@(cdddr form) + (,(rename 'DO-LOOP) + ,@(map (lambda (binding) + (if (null? (cddr binding)) + (car binding) + (caddr binding))) + bindings))))))) + (,(rename 'DO-LOOP) ,@(map cadr bindings)))) + (ill-formed-syntax form)))) + + (define-expander 'QUASIQUOTE + (lambda (form rename compare) + (define (descend-quasiquote x level return) + (cond ((pair? x) (descend-quasiquote-pair x level return)) + ((vector? x) (descend-quasiquote-vector x level return)) + (else (return 'QUOTE x)))) + (define (descend-quasiquote-pair x level return) + (cond ((not (and (pair? x) + (identifier? (car x)) + (pair? (cdr x)) + (null? (cddr x)))) + (descend-quasiquote-pair* x level return)) + ((compare (rename 'QUASIQUOTE) (car x)) + (descend-quasiquote-pair* x (+ level 1) return)) + ((compare (rename 'UNQUOTE) (car x)) + (if (zero? level) + (return 'UNQUOTE (cadr x)) + (descend-quasiquote-pair* x (- level 1) return))) + ((compare (rename 'UNQUOTE-SPLICING) (car x)) + (if (zero? level) + (return 'UNQUOTE-SPLICING (cadr x)) + (descend-quasiquote-pair* x (- level 1) return))) + (else + (descend-quasiquote-pair* x level return)))) + (define (descend-quasiquote-pair* x level return) + (descend-quasiquote + (car x) level + (lambda (car-mode car-arg) + (descend-quasiquote + (cdr x) level + (lambda (cdr-mode cdr-arg) + (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE)) + (return 'QUOTE x)) + ((eq? car-mode 'UNQUOTE-SPLICING) + (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg)) + (return 'UNQUOTE car-arg) + (return 'APPEND + (list car-arg + (finalize-quasiquote cdr-mode + cdr-arg))))) + ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg)) + (return 'LIST + (cons (finalize-quasiquote car-mode car-arg) + (map (lambda (element) + (finalize-quasiquote 'QUOTE + element)) + cdr-arg)))) + ((eq? cdr-mode 'LIST) + (return 'LIST + (cons (finalize-quasiquote car-mode car-arg) + cdr-arg))) + (else + (return + 'CONS + (list (finalize-quasiquote car-mode car-arg) + (finalize-quasiquote cdr-mode cdr-arg)))))))))) + (define (descend-quasiquote-vector x level return) + (descend-quasiquote + (vector->list x) level + (lambda (mode arg) + (case mode + ((QUOTE) (return 'QUOTE x)) + ((LIST) (return 'VECTOR arg)) + (else + (return 'LIST->VECTOR + (list (finalize-quasiquote mode arg)))))))) + (define (finalize-quasiquote mode arg) + (case mode + ((QUOTE) `(,(rename 'QUOTE) ,arg)) + ((UNQUOTE) arg) + ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context" arg)) + (else `(,(rename mode) ,@arg)))) + (if (syntax-match? '(EXPRESSION) (cdr form)) + (descend-quasiquote (cadr form) 0 finalize-quasiquote) + (ill-formed-syntax form)))) + +;;; end MAKE-CORE-EXPANDER-MACROLOGY + ))) |