Import Upstream version 2a6upstream/2a6

1 files changed, 96 insertions, 0 deletions

diff --git a/defmacex.scm b/defmacex.scm
new file mode 100644
index 0000000..bdaf020
--- /dev/null
+++ b/defmacex.scm
@@ -0,0 +1,96 @@
+;;;"defmacex.scm" defmacro:expand* for any Scheme dialect.
+;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer.
+;
+;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.  I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;;expand thoroughly, not just topmost expression.  While expanding
+;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec,
+;;;cond, case, do, quasiquote: need to be destructured properly.  (if,
+;;;and, or, begin: don't need special treatment.)
+
+(define (defmacro:iqq e depth)
+  (letrec
+      ((map1 (lambda (f x)
+	       (if (pair? x) (cons (f (car x)) (map1 f (cdr x)))
+		   x)))
+       (iqq (lambda (e depth)
+	      (if (pair? e)
+		  (case (car e)
+		    ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth))))
+		    ((unquote unquote-splicing)
+		     (list (car e) (if (= 1 depth)
+				       (defmacro:expand* (cadr e))
+				       (iqq (cadr e) (+ -1 depth)))))
+		    (else (map1 (lambda (e) (iqq e depth)) e)))
+		  e))))
+    (iqq e depth)))
+
+(define (defmacro:expand* e)
+  (if (pair? e)
+      (let* ((c (macroexpand-1 e)))
+	(if (not (eq? e c))
+	    (defmacro:expand* c)
+	    (case (car e)
+	      ((quote) e)
+	      ((quasiquote) (defmacro:iqq e 0))
+	      ((lambda define set!)
+	       (cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e)))))
+	      ((let)
+	       (let ((b (cadr e)))
+		 (if (symbol? b)	;named let
+		     `(let ,b
+			,(map (lambda (vv)
+				`(,(car vv)
+				  ,(defmacro:expand* (cadr vv))))
+			      (caddr e))
+			,@(map defmacro:expand*
+			       (cdddr e)))
+		     `(let
+			  ,(map (lambda (vv)
+				  `(,(car vv)
+				    ,(defmacro:expand* (cadr vv))))
+				b)
+			,@(map defmacro:expand*
+			       (cddr e))))))
+	      ((let* letrec)
+	       `(,(car e) ,(map (lambda (vv)
+				  `(,(car vv)
+				    ,(defmacro:expand* (cadr vv))))
+				(cadr e))
+			  ,@(map defmacro:expand* (cddr e))))
+	      ((cond)
+	       `(cond
+		 ,@(map (lambda (c)
+			  (map defmacro:expand* c))
+			(cdr e))))
+	      ((case)
+	       `(case ,(defmacro:expand* (cadr e))
+		  ,@(map (lambda (c)
+			   `(,(car c)
+			     ,@(map defmacro:expand* (cdr c))))
+			 (cddr e))))
+	      ((do)
+	       `(do ,(map
+		      (lambda (initsteps)
+			`(,(car initsteps)
+			  ,@(map defmacro:expand*
+				 (cdr initsteps))))
+		      (cadr e))
+		    ,(map defmacro:expand* (caddr e))
+		  ,@(map defmacro:expand* (cdddr e))))
+	      (else (map defmacro:expand* e)))))
+      e))