From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 16 May 2018 05:32:46 +0000 (-0700)
Subject: Implement GUARD for R7RS.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~36
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ac50ddfe81fe7b763c9b6276c7b096b02311f5eb;p=mit-scheme.git

Implement GUARD for R7RS.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 603a96d3c..c98cbdb0d 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -252,9 +252,7 @@ USA.
    (delay
      (scons-rule
 	 `((* ,cond-clause-pattern)
-	   (or (subform (ignore-if id=? else)
-			(+ any))
-	       (value #f)))
+	   ,cond-else-clause-pattern)
        (lambda (clauses else-actions)
 	 (fold-right expand-cond-clause
 		     (if else-actions
@@ -271,7 +269,15 @@ USA.
 		      (cons (value begin)
 			    (* any))))))
 
+(define cond-else-clause-pattern
+  '(or (subform (ignore-if id=? else)
+		(+ any))
+       (value #f)))
+
 (define (expand-cond-clause clause rest)
+  ((cond-clause-expander scons-if) clause rest))
+
+(define ((cond-clause-expander scons-if) clause rest)
   (let ((predicate (car clause))
 	(type (cadr clause))
 	(actions (cddr clause)))
@@ -287,7 +293,9 @@ USA.
 	   (scons-if predicate
 		     (apply scons-begin actions)
 		     rest)
-	   (scons-or predicate rest)))
+	   (let ((temp (new-identifier 'temp)))
+	     (scons-let (list (list temp predicate))
+	       (scons-if temp temp rest)))))
       (else
        (error "Unknown clause type:" type)))))
 
@@ -387,6 +395,36 @@ USA.
     ((unless condition form ...)
      (if (not condition)
 	 (begin form ...)))))
+
+(define $guard
+  (spar-transformer->runtime
+   (delay
+     (scons-rule `((subform id
+			    (* ,cond-clause-pattern)
+			    ,cond-else-clause-pattern)
+		   (+ any))
+       (lambda (var clauses else-actions body)
+	 (let ((guard-k (new-identifier 'guard-k))
+	       (condition (new-identifier 'condition)))
+	   (scons-call 'call-with-current-continuation
+		       (scons-lambda (list guard-k)
+			 (scons-call 'with-exception-handler
+				     (scons-lambda (list condition)
+				       (scons-let (list (list var condition))
+					 (guard-handler guard-k condition clauses else-actions)))
+				     (apply scons-lambda '() body))))))))))
+
+(define (guard-handler guard-k condition clauses else-actions)
+  (if else-actions
+      (scons-call guard-k
+		  (fold-right expand-cond-clause
+			      (apply scons-begin else-actions)
+			      clauses))
+      (fold-right (cond-clause-expander
+		   (lambda (p c a)
+		     (scons-if p (scons-call guard-k c) a)))
+		  (scons-call 'raise-continuable condition)
+		  clauses)))
 
 ;;;; Quasiquote
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b50141fcf..b1361360a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4760,6 +4760,7 @@ USA.
 	  (define-record-type $define-record-type)
 	  (do $do)			;R7RS
 	  (fluid-let $fluid-let)
+	  (guard $guard)		;R7RS
 	  (let $let)			;R7RS
 	  (let* $let*)			;R7RS
 	  (let*-syntax $let*-syntax)	;R7RS