Import Upstream version 5d6upstream/5d6

1 files changed, 283 insertions, 166 deletions

diff --git a/Macro.scm b/Macro.scm
index 0ddccc1..911098b 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM library with other files
 ;; to produce an executable, this does not by itself cause the
 ;; resulting executable to be covered by the GNU General Public License.
 ;; Your use of that executable is in no way restricted on account of
-;; linking the GUILE library code into it.
+;; linking the SCM library code into it.
 ;;
 ;; This exception does not however invalidate any other reasons why
 ;; the executable file might be covered by the GNU General Public License.
 ;;
 ;; This exception applies only to the code released by the
-;; Free Software Foundation under the name GUILE.  If you copy
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, as the General Public License permits, the exception does
 ;; not apply to the code that you add in this way.  To avoid misleading
 ;; anyone as to the status of such modified files, you must delete
 ;; this exception notice from them.
 ;;
-;; If you write modifications of your own for GUILE, it is your choice
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -56,12 +56,19 @@
   ;; We keep local copies of these standard special forms, otherwise,
   ;; redefining them before they are memoized below can lead to
   ;; infinite recursion.
-  (@let-syntax ((lambda (the-macro lambda))
+  (let-syntax ((lambda (the-macro lambda))
+		(begin (the-macro begin))
+		(quote (the-macro quote))
 		(let (the-macro let))
-		(cond (the-macro cond))
-		(if (the-macro if))
+		(let* (the-macro let*))
+		(letrec (the-macro letrec))
 		(and (the-macro and))
-		(or (the-macro or)))
+		(or (the-macro or))
+		(delay (the-macro delay))
+		(do (the-macro do))
+		(case (the-macro case))
+		(cond (the-macro cond))
+		(quasiquote (the-macro quasiquote)))
     (let ((var-rtd (make-record-type '? '(name rank)))
 	  (e-pat-rtd (make-record-type '... '(pattern vars)))
 	  (rule-rtd (make-record-type 'rule '(pattern inserted template))))
@@ -83,7 +90,8 @@
       (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern))
       (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars))
 
-      (define rule (record-constructor rule-rtd '(pattern inserted template)))
+      (define make-rule
+	(record-constructor rule-rtd '(pattern inserted template)))
       (define rule->pattern (record-accessor rule-rtd 'pattern))
       (define rule->inserted (record-accessor rule-rtd 'inserted))
       (define rule->template (record-accessor rule-rtd 'template))
@@ -92,6 +100,12 @@
 	(if (null? y) x
 	    (append x y)))
 
+      (define (append-if pred x y)
+	(let recur ((x x))
+	  (cond ((null? x) y)
+		((pred (car x)) (cons (car x) (recur (cdr x))))
+		(else (recur (cdr x))))))
+
       (define ellipsis?
 	(let (($... (renamed-identifier '... #f)))
 	  (lambda (x env)
@@ -108,111 +122,130 @@
 		(duplicates? (cdr vars)))))
 
       (define (compile-pattern literals rule-exp env-def)
-	(let recur ((pat (cdar rule-exp))
-		    (vars '())
-		    (rank 0)
-		    (k (lambda (compiled vars)
-			 (let ((dup (duplicates? (map car vars))))
-			   (if dup
-			       (error
-				"syntax-rules: duplicate pattern variable:"
-				dup " in rule " rule-exp)))
-			 (apply rule
-				compiled
-				(rewrite-template
-				 (cadr rule-exp) vars env-def)))))
+	(define (compile1 pat vars rank ell? k)
 	  (cond ((null? pat)
 		 (k pat vars))
 		((identifier? pat)
-		 (let ((lit (memq pat literals)))
-		   (if lit
-		       (k (renamed-identifier pat env-def) vars)
-		       (let ((var (pattern-variable pat rank)))
-			 (k var (cons (cons pat var) vars))))))
-		((pair? pat)
-		 (if (and (pair? (cdr pat))
-			  (ellipsis? (cadr pat) env-def)
-			  (or (null? (cddr pat))
-			      (error "bad ellipsis:" pat)))
-		     (if (ellipsis? (car pat) env-def)
-			 (recur (car pat) vars rank k)
-			 (recur (car pat) '() (+ rank 1)
-				(lambda (comp1 vars1)
-				  (k (list
-				      (ellipsis-pattern comp1 (map cdr vars1)))
-				     (append2 vars1 vars)))))
-		     (recur (car pat) '() rank
-			    (lambda (comp1 vars1)
-			      (recur (cdr pat) vars rank
-				     (lambda (comp2 vars2)
-				       (k (cons comp1 comp2)
-					  (append2 vars1 vars2))))))))
+		 (if (or (memq pat literals)
+			 (and (not ell?) (ellipsis? pat env-def)))
+		     (k (renamed-identifier pat env-def) vars)
+		     (let ((var (pattern-variable pat rank)))
+		       (k var (cons (cons pat var) vars)))))
 		((vector? pat)
-		 (recur (vector->list pat) vars rank
-			(lambda (comp vars)
-			  (k (list->vector comp) vars))))
-		(else
-		 (k pat vars)))))
+		 (compile1 (vector->list pat) vars rank ell?
+			   (lambda (comp vars)
+			     (k (list->vector comp) vars))))
+		((not (pair? pat))
+		 (k pat vars))
+		((and ell? (ellipsis? (car pat) env-def))
+		 (or (and (pair? (cdr pat))
+			  (null? (cddr pat)))
+		     (error "bad ellipsis quote:" pat))
+		 (compile1 (cadr pat) vars rank #f k))
+		((and ell?
+		      (pair? (cdr pat))
+		      (ellipsis? (cadr pat) env-def))
+		 (or (null? (cddr pat))
+		     (error "bad ellipsis:" pat))
+		 (compile1
+		  (car pat) '() (+ rank 1) ell?
+		  (lambda (comp1 vars1)
+		    (k (list
+			(ellipsis-pattern comp1 (map cdr vars1)))
+		       (append2 vars1 vars)))))
+		(else ; pat is a pair
+		 (compile1
+		  (car pat) '() rank ell?
+		  (lambda (comp1 vars1)
+		    (compile1
+		     (cdr pat) vars rank ell?
+		     (lambda (comp2 vars2)
+		       (k (cons comp1 comp2)
+			  (append2 vars1 vars2)))))))))
+	(let ((pat (car rule-exp))
+	      (tmpl (cadr rule-exp)))
+	  (if (identifier? pat)
+	      (apply make-rule #f (rewrite-template tmpl '() env-def))
+	      (compile1
+	       (cdr pat) '() 0 #t
+	       (lambda (compiled vars)
+		 (let ((dup (duplicates? (map car vars))))
+		   (if dup
+		       (error
+			"syntax-rules: duplicate pattern variable:"
+			dup " in rule " rule-exp)
+		       (apply make-rule
+			      (cons #f compiled)
+			      (rewrite-template tmpl vars env-def)))))))))
 
       (define (rewrite-template template vars env-def)
-	(let recur ((tmpl template)
-		    (rank 0)
-		    (inserted '())
-		    (k (lambda (compiled inserted opened)
-			 (list inserted compiled))))
+	(let rewrite1 ((tmpl template)
+		       (rank 0)
+		       (inserted '())
+		       (ell? #t)
+		       (k (lambda (compiled inserted opened)
+			    (list inserted compiled))))
 	  (cond ((null? tmpl)
 		 (k tmpl '() '()))
 		((identifier? tmpl)
 		 (let ((v (assq tmpl vars)))
-		   (if v
-		       (cond ((= rank (pattern-variable->rank (cdr v)))
-			      (k (cdr v) '() (list (cdr v))))
-			     ((> rank (pattern-variable->rank (cdr v)))
-			      (k (cdr v) '() '()))
-			     (else
-			      (error "pattern variable rank mismatch:" tmpl
-				     " in " template)))
-		       (k tmpl (list tmpl) '()))))
-		((pair? tmpl)
-		 (if (and (pair? (cdr tmpl))
-			  (ellipsis? (cadr tmpl) env-def))
-		     (if (and (ellipsis? (car tmpl) env-def)
-			      (or (null? (cddr tmpl))
-				  (error "bad ellipsis:" tmpl)))
-			 ;; (... ...) escape
-			 (k (car tmpl) (list (car tmpl)) '())
-			 (recur (car tmpl) (+ rank 1) '()
-				(lambda (comp1 ins1 op1)
-				  (if (null? op1)
-				      (error "Bad ellipsis:"
-					     tmpl " in template " template))
-				  (recur (cddr tmpl) rank inserted
-					 (lambda (comp2 ins2 op2)
-					   (k (cons
-					       (ellipsis-pattern comp1 op1)
-					       comp2)
-					      (append2 ins1 ins2)
-					      (append2 op1 op2)))))))
-		     (recur (car tmpl) rank '()
-			    (lambda (comp1 ins1 op1)
-			      (recur (cdr tmpl) rank inserted
-				     (lambda (comp2 ins2 op2)
-				       (k (cons comp1 comp2)
-					  (append2 ins1 ins2)
-					  (append2 op1 op2))))))))
+		   (cond ((not v)
+			  (k tmpl (list tmpl) '()))
+			 ((zero? (pattern-variable->rank (cdr v)))
+			  (k (cdr v) '() '()))
+			 ((>= rank (pattern-variable->rank (cdr v)))
+			  (k (cdr v) '() (list (cdr v))))
+			 (else
+			  (error "pattern variable rank mismatch:" tmpl
+				 " in " template)))))
 		((vector? tmpl)
-		 (recur (vector->list tmpl) rank inserted
-			(lambda (compiled inserted opened)
-			  (k (list->vector compiled) inserted opened))))
-		(else
-		 (k tmpl '() '())))))
-
+		 (rewrite1
+		  (vector->list tmpl) rank inserted ell?
+		  (lambda (compiled inserted opened)
+		    (k (list->vector compiled) inserted opened))))
+		((not (pair? tmpl))
+		 (k tmpl '() '()))
+		((and ell? (ellipsis? (car tmpl) env-def))
+		 ;; (... ...) escape
+		 (or (and (pair? (cdr tmpl))
+			  (null? (cddr tmpl)))
+		     (error "Bad ellpsis quote:" tmpl
+			    " in template " template))
+		 (rewrite1 (cadr tmpl) rank inserted #f k))
+		((and ell?
+		      (pair? (cdr tmpl))
+		      (ellipsis? (cadr tmpl) env-def))
+		 (rewrite1
+		  (car tmpl) (+ rank 1) '() ell?
+		  (lambda (comp1 ins1 op1)
+		    (if (null? op1)
+			(error "Bad ellipsis:" tmpl
+			       " in template " template))
+		    (rewrite1
+		     (cddr tmpl) rank inserted ell?
+		     (lambda (comp2 ins2 op2)
+		       (k (cons (ellipsis-pattern comp1 op1)
+				comp2)
+			  (append2 ins1 ins2)
+			  (append-if (lambda (op)
+				       (> (pattern-variable->rank op)
+					  rank))
+				     op1 op2)))))))
+		(else ; tmpl is a pair
+		 (rewrite1
+		  (car tmpl) rank '() ell?
+		  (lambda (comp1 ins1 op1)
+		    (rewrite1
+		     (cdr tmpl) rank inserted ell?
+		     (lambda (comp2 ins2 op2)
+		       (k (cons comp1 comp2)
+			  (append2 ins1 ins2)
+			  (append2 op1 op2))))))))))
 
 ;;; Match EXP to RULE, returning alist of variable bindings or #f.
 
       (define (match rule exp env-use)
-	(let recur ((r (rule->pattern rule))
-		    (x (cdr exp)))
+	(define (match1 r x)
 	  (cond ((null? r)
 		 (and (null? x) '()))
 		((pair? r)
@@ -220,8 +253,8 @@
 		     (and
 		      (list? x)
 		      (let ((pat (ellipsis-pattern->pattern (car r))))
-			(let match1 ((x x)
-				     (vals '()))
+			(let match-list ((x x)
+					 (vals '()))
 			  (if (null? x)
 			      (if (null? vals)
 				  (map list (ellipsis-pattern->vars (car r)))
@@ -230,14 +263,14 @@
 					   (map (lambda (al)
 						  (map cdr al))
 						(reverse vals)))))
-			      (let ((val (recur pat (car x))))
+			      (let ((val (match1 pat (car x))))
 				(and val
-				     (match1 (cdr x) (cons val vals))))))))
+				     (match-list (cdr x) (cons val vals))))))))
 		     (and
 		      (pair? x)
-		      (let ((v1 (recur (car r) (car x))))
+		      (let ((v1 (match1 (car r) (car x))))
 			(and v1
-			     (let ((v2 (recur (cdr r) (cdr x))))
+			     (let ((v2 (match1 (cdr r) (cdr x))))
 			       (and v2 (append2 v1 v2))))))))
 		((identifier? r)		;literal
 		 (and (identifier? x) (identifier-equal? r x env-use) '()))
@@ -245,16 +278,30 @@
 		 (list (cons r x)))
 		((vector? r)
 		 (and (vector? x)
-		      (recur (vector->list r) (vector->list x))))
+		      (match1 (vector->list r) (vector->list x))))
 		(else
-		 (and (equal? r x) '())))))
+		 (and (equal? r x) '()))))
+	(let ((pat (rule->pattern rule)))
+	  (if (pair? pat)
+	      (and (pair? exp)
+		   (match1 (cdr pat) (cdr exp)))
+	      (if (pair? exp) #f '()))))
+
+      (define (substitute-in-template x-use rule vars env-def)
+	(define (length-error pats vals)
+	  (apply error
+		 "syntax-rules: pattern variable length mismatch:\n"
+		 x-use
+		 (map (lambda (name val)
+			`(,(pattern-variable->name
+			    name) -> ,val))
+		      pats vals)))
 
-      (define (substitute-in-template rule vars env-def)
 	(let ((ins (map (lambda (id)
 			  (cons id (renamed-identifier id env-def)))
 			(rule->inserted rule))))
-	  (let recur ((tmpl (rule->template rule))
-		      (vars vars))
+	  (let subst1 ((tmpl (rule->template rule))
+		       (vars vars))
 	    (cond ((null? tmpl)
 		   tmpl)
 		  ((pair? tmpl)
@@ -269,62 +316,75 @@
 			   (if (pair? es)
 			       (if (= n (length (car es)))
 				   (check (cdr es))
-				   (error "syntax-rules: pattern variable length mismatch:"))))
+				   (length-error enames evals))))
 			 (append!
 			  (map (lambda (eval)
-				 (recur etmpl
-					(append!
-					 (map cons enames eval)
-					 vars)))
+				 (subst1 etmpl
+					 (append!
+					  (map cons enames eval)
+					  vars)))
 			       (apply map list evals))
-			  (recur (cdr tmpl) vars)))
-		       (cons (recur (car tmpl) vars)
-			     (recur (cdr tmpl) vars))))
+			  (subst1 (cdr tmpl) vars)))
+		       (cons (subst1 (car tmpl) vars)
+			     (subst1 (cdr tmpl) vars))))
 		  ((identifier? tmpl)
 		   (let ((a (assq tmpl ins)))
 		     (if a (cdr a) tmpl)))
 		  ((pattern-variable? tmpl)
 		   (@copy-tree (cdr (assq tmpl vars))))
 		  ((vector? tmpl)
-		   (list->vector (recur (vector->list tmpl) vars)))
+		   (list->vector (subst1 (vector->list tmpl) vars)))
 		  (else
 		   tmpl)))))
 
       ;; MACRO:COMPILE-SYNTAX-RULES
       (lambda (x-def env-def)
-	(or (and (list? x-def)
-		 (< 2 (length x-def))
-		 (list? (cadr x-def)))
-	    (error "Malformed syntax-rules:" x-def))
-	(let ((literals (cadr x-def)))
-	  (for-each (lambda (x)
-		      (or (identifier? x)
-			  (error "Bad literals list:" x-def)))
-		    literals)
-	  (let ((rules (map (lambda (rule-expr)
-			      (or (and (list? rule-expr)
-				       (= 2 (length rule-expr))
-				       (pair? (car rule-expr)))
-				  (error "Bad rule:" rule-expr))
-			      (compile-pattern literals rule-expr env-def))
-			    (cddr x-def))))
+	(let ((x-def (remove-line-numbers! x-def)))
+	  (or (and (list? x-def)
+		   (< 2 (length x-def))
+		   (list? (cadr x-def)))
+	      (error "Malformed syntax-rules:" x-def))
+	  (let ((literals (cadr x-def)))
+	    (for-each (lambda (x)
+			(or (identifier? x)
+			    (error "Bad literals list:" x-def)))
+		      literals)
+	    (let ((rules (map (lambda (rule-expr)
+				(or (and (list? rule-expr)
+					 (= 2 (length rule-expr))
+					 (let ((pat (car rule-expr)))
+					   (or (pair? pat)
+					       (identifier? pat))))
+				    (error "Bad rule:" rule-expr))
+				(compile-pattern literals rule-expr env-def))
+			      (cddr x-def))))
 
-	    (lambda (x-use env-use)
-	      (let loop ((rules rules))
-		(cond ((null? rules)
-		       (error "macro use does not match definition:"
-			      x-use))
-		      ((match (car rules) x-use env-use)
-		       => (lambda (vars)
-			    (substitute-in-template (car rules) vars env-def)))
-		      (else
-		       (loop (cdr rules))))))))))))
+	      (lambda (x-use env-use)
+		;;FIXME We should use the line numbers.
+		(let ((x-use (remove-line-numbers! x-use)))
+		  (let loop ((rules rules))
+		    (cond ((null? rules)
+			   (error "macro use does not match definition:"
+				  x-use))
+			  ((match (car rules) x-use env-use)
+			   => (lambda (vars)
+				(substitute-in-template
+				 x-use (car rules) vars env-def)))
+			  (else
+			   (loop (cdr rules))))))))))))))
 
-(define syntax-rules
+(define-syntax syntax-rules
   (procedure->syntax
    (lambda (expr env-def)
-     (procedure->memoizing-macro
-      (macro:compile-syntax-rules expr env-def)))))
+     (let ((transformer (macro:compile-syntax-rules expr env-def)))
+       (let loop ((rules (cddr expr)))
+	 (cond ((null? rules)
+		(procedure->memoizing-macro transformer))
+	       ((identifier? (caar rules))
+		(procedure->identifier-macro transformer))
+	       (else
+		(loop (cdr rules)))))))))
+
 
 ;; Explicit renaming macro facility, as in
 ;; W. Clinger, "Hygienic Macros Through Explicit Renaming"
@@ -358,22 +418,79 @@
      (lambda (exp env-def)
        `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def))))))
 
-(define define-syntax
-  (syntax-rules ()
-    ((define-syntax ?name ?val)
-     (define ?name (the-macro ?val)))))
-
-(define-syntax let-syntax
-  (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body)
-		    (@let-syntax
-			((?name (the-macro ?val)) ...) . ?body))))
-
-(define-syntax letrec-syntax
-  (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body)
-		    (@letrec-syntax
-		     ((?name (the-macro ?val)) ...) . ?body))))
-
-;; MACRO:EXPAND would require substantial work.
 (define macro:load load)
 (define macro:eval eval)
+(define (macro:expand . args)
+  (load (in-vicinity (implementation-vicinity) "Macexp"))
+  (apply macro:expand args))
 (provide 'macro)
+
+;; These are not part of the SYNTAX-RULES implementation, but I see
+;; no better place to put them:
+
+;; A debugging utility macro that is easy to grep for.
+(define-syntax @print
+  (syntax-rules (quote)
+    ((_ '?arg)
+     (begin (display '?arg)
+	    (newline)))
+    ((_ ?arg)
+     (begin (display '?arg)
+	    (display " => ")
+	    (let ((x ?arg))
+	      (write x)
+	      (newline)
+	      x)))
+    ((_ ?arg1 ?arg ...)
+     (begin
+       (@print ?arg1)
+       (begin
+	 (display " ")
+	 (@print ?arg))
+       ...))))
+
+(define-syntax @pprint
+  (syntax-rules (quote)
+    ((_ '?arg)
+     (begin (display '?arg)
+	    (newline)))
+    ((_ ?arg)
+     (begin (display '?arg)
+	    (display " => ")
+	    (let ((x ?arg))
+	      (pprint x)
+	      (newline)
+	      x)))
+    ((_ ?arg1 ?arg ...)
+     (begin
+       (@pprint ?arg1)
+       (begin
+	 (display " ")
+	 (@pprint ?arg))
+       ...))))
+
+;; Better run time error reporting than the version in Init*.scm,
+;; also only takes a given car or cdr once.
+(define-syntax destructuring-bind
+  (syntax-rules ()
+    ((_ "PARSE-LLIST" () ?val ?body ?err)
+     (if (null? ?val) ?body (?err '() ?val)))
+    ((_ "PARSE-LLIST" (?name1 . ?rest) ?val ?body ?err)
+     (if (pair? ?val)
+	 (let ((carv (car ?val))
+	       (cdrv (cdr ?val)))
+	   (destructuring-bind "PARSE-LLIST" ?name1 carv
+              (destructuring-bind "PARSE-LLIST" ?rest cdrv ?body ?err)
+	      ?err))
+	 (?err '(?name1 . ?rest) ?val)))
+    ((_ "PARSE-LLIST" ?name ?val ?body ?err)
+     (let ((?name ?val)) ?body))
+    ((_ ?llist ?val ?body1 ?body ...)
+     (let ((err (lambda (pat val)
+		  (slib:error 'destructuring-bind '?llist
+			      val "does not match" pat)))
+	   (val ?val))
+       (destructuring-bind "PARSE-LLIST" ?llist val
+			   ;;Use LET to allow internal DEFINE in body.
+			   (let () ?body1 ?body ...)
+			   err)))))