Import Upstream version 2a6upstream/2a6

1 files changed, 327 insertions, 0 deletions

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))