From 69fe6b8c0de2e7c2edd29c4331e24e0c054773f6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 19 Oct 2019 22:41:51 -0700
Subject: [PATCH] Fix problem with syntaxing of DO.

This wouldn't work correctly in some weird edge cases.  Specifically, it was
trying to detect the 'else and '=> keywords, but comparing them in the syntactic
environment outside of the DO, not the one inside of it.  Fixed by rewriting the
macro to defer the cond-clause processing until the interior environment was
available.
---
 src/runtime/mit-macros.scm         | 22 +++++++++++-----------
 src/runtime/runtime.pkg            |  1 +
 src/runtime/syntax-constructor.scm | 12 ++++++++++--
 3 files changed, 22 insertions(+), 13 deletions(-)

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 4a985e385..79ba7249a 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -344,7 +344,7 @@ USA.
    (delay
      (scons-rule
 	 `((subform (* (subform (list id any (? any)))))
-	   ,cond-clause-pattern
+	   (subform (+ any))
 	   (* any))
        (lambda (bindings test-clause actions)
 	 (let ((loop-name (new-identifier 'do-loop)))
@@ -353,16 +353,16 @@ USA.
 		      (list (car binding)
 			    (cadr binding)))
 		    bindings)
-	     (expand-cond-clause test-clause
-				 (scons-begin
-				   (apply scons-begin actions)
-				   (apply scons-call
-					  loop-name
-					  (map (lambda (binding)
-						 (if (pair? (cddr binding))
-						     (caddr binding)
-						     (car binding)))
-					       bindings)))))))))))
+	     (scons-cond test-clause
+			 (list (scons-close 'else)
+			       (apply scons-begin actions)
+			       (apply scons-call
+				      loop-name
+				      (map (lambda (binding)
+					     (if (pair? (cddr binding))
+						 (caddr binding)
+						 (car binding)))
+					   bindings)))))))))))
 
 (define $case
   (spar-transformer->runtime
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b51baf1c7..0056b3ee4 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4830,6 +4830,7 @@ USA.
 	  scons-begin
 	  scons-call
 	  scons-close
+	  scons-cond
 	  scons-declare
 	  scons-define
 	  scons-delay
diff --git a/src/runtime/syntax-constructor.scm b/src/runtime/syntax-constructor.scm
index 07d924d75..b1b1e9e58 100644
--- a/src/runtime/syntax-constructor.scm
+++ b/src/runtime/syntax-constructor.scm
@@ -78,6 +78,14 @@ USA.
      (cons (close-part close operator)
 	   (close-parts close operands)))))
 
+(define (scons-cond . clauses)
+  (make-open-expr
+   (lambda (close)
+     (cons (close 'cond)
+	   (map (lambda (clause)
+		  (close-parts close clause))
+		clauses)))))
+
 (define (scons-declare . decls)
   (make-open-expr
    (lambda (close)
@@ -96,7 +104,7 @@ USA.
    (lambda (close)
      (list (close 'delay)
 	   (close-part close expr)))))
-
+
 (define (scons-if predicate consequent alternative)
   (make-open-expr
    (lambda (close)
@@ -104,7 +112,7 @@ USA.
 	   (close-part close predicate)
 	   (close-part close consequent)
 	   (close-part close alternative)))))
-
+
 (define (scons-lambda bvl . body-forms)
   (make-open-expr
    (lambda (close)
-- 
2.25.1