From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- synrul.scm | 327 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 327 insertions(+) create mode 100644 synrul.scm (limited to 'synrul.scm') diff --git a/synrul.scm b/synrul.scm new file mode 100644 index 0000000..c23275f --- /dev/null +++ b/synrul.scm @@ -0,0 +1,327 @@ +;;; "synrul.scm" Rule-based Syntactic Expanders -*-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. + +;;;; Rule-based Syntactic Expanders + +;;; See "Syntactic Extensions in the Programming Language Lisp", by +;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986. +;;; See also "Macros That Work", by William Clinger and Jonathan Rees +;;; (reference? POPL?). This implementation is derived from an +;;; implementation by Kent Dybvig, and includes some ideas from +;;; another implementation by Jonathan Rees. + +;;; The expansion of SYNTAX-RULES references the following keywords: +;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE +;;; and the following procedures: +;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND +;;; ILL-FORMED-SYNTAX +;;; it also uses the anonymous keyword SYNTAX-QUOTE. + +;;; For testing. +;;;(define (run-sr form) +;;; (expand/syntax-rules form (lambda (x) x) eq?)) + +(define (make-syntax-rules-macrology) + (make-er-expander-macrology + (lambda (define-classifier base-environment) + base-environment ;ignore + (define-classifier 'SYNTAX-RULES expand/syntax-rules)))) + +(define (expand/syntax-rules form rename compare) + (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION)) + (cdr form)) + (let ((keywords (cadr form)) + (clauses (cddr form))) + (if (let loop ((keywords keywords)) + (and (pair? keywords) + (or (memq (car keywords) (cdr keywords)) + (loop (cdr keywords))))) + (syntax-error "keywords list contains duplicates" keywords) + (let ((r-form (rename 'FORM)) + (r-rename (rename 'RENAME)) + (r-compare (rename 'COMPARE))) + `(,(rename 'ER-TRANSFORMER) + (,(rename 'LAMBDA) + (,r-form ,r-rename ,r-compare) + ,(let loop ((clauses clauses)) + (if (null? clauses) + `(,(rename 'ILL-FORMED-SYNTAX) ,r-form) + (let ((pattern (caar clauses))) + (let ((sids + (parse-pattern rename compare keywords + pattern r-form))) + `(,(rename 'IF) + ,(generate-match rename compare keywords + r-rename r-compare + pattern r-form) + ,(generate-output rename compare r-rename + sids (cadar clauses) + syntax-error) + ,(loop (cdr clauses)))))))))))) + (ill-formed-syntax form))) + +(define (parse-pattern rename compare keywords pattern expression) + (let loop + ((pattern pattern) + (expression expression) + (sids '()) + (control #f)) + (cond ((identifier? pattern) + (if (memq pattern keywords) + sids + (cons (make-sid pattern expression control) sids))) + ((and (or (zero-or-more? pattern rename compare) + (at-least-one? pattern rename compare)) + (null? (cddr pattern))) + (let ((variable ((make-name-generator) 'CONTROL))) + (loop (car pattern) + variable + sids + (make-sid variable expression control)))) + ((pair? pattern) + (loop (car pattern) + `(,(rename 'CAR) ,expression) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression) + sids + control) + control)) + (else sids)))) + +(define (generate-match rename compare keywords r-rename r-compare + pattern expression) + (letrec + ((loop + (lambda (pattern expression) + (cond ((identifier? pattern) + (if (memq pattern keywords) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) + (,temp) + (,(rename 'IF) + (,(rename 'IDENTIFIER?) ,temp) + (,r-compare ,temp + (,r-rename ,(syntax-quote pattern))) + #f)) + ,expression)) + `#t)) + ((and (zero-or-more? pattern rename compare) + (null? (cddr pattern))) + (do-list (car pattern) expression)) + ((and (at-least-one? pattern rename compare) + (null? (cddr pattern))) + `(,(rename 'IF) (,(rename 'NULL?) ,expression) + #F + ,(do-list (car pattern) expression))) + ((pair? pattern) + (let ((generate-pair + (lambda (expression) + (conjunction + `(,(rename 'PAIR?) ,expression) + (conjunction + (loop (car pattern) + `(,(rename 'CAR) ,expression)) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression))))))) + (if (identifier? expression) + (generate-pair expression) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp)) + ,expression))))) + ((null? pattern) + `(,(rename 'NULL?) ,expression)) + (else + `(,(rename 'EQUAL?) ,expression + (,(rename 'QUOTE) ,pattern)))))) + (do-list + (lambda (pattern expression) + (let ((r-loop (rename 'LOOP)) + (r-l (rename 'L)) + (r-lambda (rename 'LAMBDA))) + `(((,r-lambda + (,r-loop) + (,(rename 'BEGIN) + (,(rename 'SET!) + ,r-loop + (,r-lambda + (,r-l) + (,(rename 'IF) + (,(rename 'NULL?) ,r-l) + #T + ,(conjunction + `(,(rename 'PAIR?) ,r-l) + (conjunction (loop pattern `(,(rename 'CAR) ,r-l)) + `(,r-loop (,(rename 'CDR) ,r-l))))))) + ,r-loop)) + #F) + ,expression)))) + (conjunction + (lambda (predicate consequent) + (cond ((eq? predicate #T) consequent) + ((eq? consequent #T) predicate) + (else `(,(rename 'IF) ,predicate ,consequent #F)))))) + (loop pattern expression))) + +(define (generate-output rename compare r-rename sids template syntax-error) + (let loop ((template template) (ellipses '())) + (cond ((identifier? template) + (let ((sid + (let loop ((sids sids)) + (and (not (null? sids)) + (if (eq? (sid-name (car sids)) template) + (car sids) + (loop (cdr sids))))))) + (if sid + (begin + (add-control! sid ellipses syntax-error) + (sid-expression sid)) + `(,r-rename ,(syntax-quote template))))) + ((or (zero-or-more? template rename compare) + (at-least-one? template rename compare)) + (optimized-append rename compare + (let ((ellipsis (make-ellipsis '()))) + (generate-ellipsis rename + ellipsis + (loop (car template) + (cons ellipsis + ellipses)))) + (loop (cddr template) ellipses))) + ((pair? template) + (optimized-cons rename compare + (loop (car template) ellipses) + (loop (cdr template) ellipses))) + (else + `(,(rename 'QUOTE) ,template))))) + +(define (add-control! sid ellipses syntax-error) + (let loop ((sid sid) (ellipses ellipses)) + (let ((control (sid-control sid))) + (cond (control + (if (null? ellipses) + (syntax-error "missing ellipsis in expansion" #f) + (let ((sids (ellipsis-sids (car ellipses)))) + (cond ((not (memq control sids)) + (set-ellipsis-sids! (car ellipses) + (cons control sids))) + ((not (eq? control (car sids))) + (syntax-error "illegal control/ellipsis combination" + control sids))))) + (loop control (cdr ellipses))) + ((not (null? ellipses)) + (syntax-error "extra ellipsis in expansion" #f)))))) + +(define (generate-ellipsis rename ellipsis body) + (let ((sids (ellipsis-sids ellipsis))) + (let ((name (sid-name (car sids))) + (expression (sid-expression (car sids)))) + (cond ((and (null? (cdr sids)) + (eq? body name)) + expression) + ((and (null? (cdr sids)) + (pair? body) + (pair? (cdr body)) + (eq? (cadr body) name) + (null? (cddr body))) + `(,(rename 'MAP) ,(car body) ,expression)) + (else + `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body) + ,@(map sid-expression sids))))))) + +(define (zero-or-more? pattern rename compare) + (and (pair? pattern) + (pair? (cdr pattern)) + (identifier? (cadr pattern)) + (compare (cadr pattern) (rename '...)))) + +(define (at-least-one? pattern rename compare) +;;; (and (pair? pattern) +;;; (pair? (cdr pattern)) +;;; (identifier? (cadr pattern)) +;;; (compare (cadr pattern) (rename '+))) + pattern rename compare ;ignore + #f) + +(define (optimized-cons rename compare a d) + (cond ((and (pair? d) + (compare (car d) (rename 'QUOTE)) + (pair? (cdr d)) + (null? (cadr d)) + (null? (cddr d))) + `(,(rename 'LIST) ,a)) + ((and (pair? d) + (compare (car d) (rename 'LIST)) + (list? (cdr d))) + `(,(car d) ,a ,@(cdr d))) + (else + `(,(rename 'CONS) ,a ,d)))) + +(define (optimized-append rename compare x y) + (if (and (pair? y) + (compare (car y) (rename 'QUOTE)) + (pair? (cdr y)) + (null? (cadr y)) + (null? (cddr y))) + x + `(,(rename 'APPEND) ,x ,y))) + +(define sid-type + (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION))) + +(define make-sid + (record-constructor sid-type '(NAME EXPRESSION CONTROL))) + +(define sid-name + (record-accessor sid-type 'NAME)) + +(define sid-expression + (record-accessor sid-type 'EXPRESSION)) + +(define sid-control + (record-accessor sid-type 'CONTROL)) + +(define sid-output-expression + (record-accessor sid-type 'OUTPUT-EXPRESSION)) + +(define set-sid-output-expression! + (record-modifier sid-type 'OUTPUT-EXPRESSION)) + +(define ellipsis-type + (make-record-type "ellipsis" '(SIDS))) + +(define make-ellipsis + (record-constructor ellipsis-type '(SIDS))) + +(define ellipsis-sids + (record-accessor ellipsis-type 'SIDS)) + +(define set-ellipsis-sids! + (record-modifier ellipsis-type 'SIDS)) -- cgit v1.2.3