From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 May 2018 00:47:08 +0000 (-0700)
Subject: Capture useful pattern with spar-pattern-fixed-point.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~26
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ff5fd917ddadf8f706ed0bee7f4404d6dbb4ce6;p=mit-scheme.git

Capture useful pattern with spar-pattern-fixed-point.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 24dd25d3b..e467696bb 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -621,23 +621,15 @@ USA.
        generate-cond-expand))))
 
 (define (cond-expand-clause-pattern)
-  (define clause-pattern
-    (let ((clause-pattern* (lambda args (apply clause-pattern args))))
-      (spar-or
-	(spar-push-subform-if identifier? spar-arg:form)
-	(spar-subform
-	  (spar-call-with-values list
-	    (spar-or
-	      (spar-and (spar-push-subform-if spar-arg:id=? 'or)
-			(spar* clause-pattern*)
-			(spar-match-null))
-	      (spar-and (spar-push-subform-if spar-arg:id=? 'and)
-			(spar* clause-pattern*)
-			(spar-match-null))
-	      (spar-and (spar-push-subform-if spar-arg:id=? 'not)
-			clause-pattern*
-			(spar-match-null))))))))
-  `(subform (cons (spar ,clause-pattern)
+  `(subform (cons ,(spar-pattern-fixed-point
+		    (lambda (feature-requirement)
+		      `(or id
+			   (subform
+			    (or (cons (or (keep-if id=? or)
+					  (keep-if id=? and))
+				      (* ,feature-requirement))
+				(list (keep-if id=? not)
+				      ,feature-requirement))))))
 		  (* any))))
 
 (define (generate-cond-expand id=? clauses)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0c81c6573..a01851012 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4634,6 +4634,7 @@ USA.
 	  spar-not
 	  spar-opt
 	  spar-or
+	  spar-pattern-fixed-point
 	  spar-push
 	  spar-push-form-if
 	  spar-push-subform
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index b4ccd115b..30f5b82a6 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -577,4 +577,14 @@ USA.
 
 (define (top-level-patterns->spar patterns)
   (spar-and (apply spar-and (map pattern->spar patterns))
-	    (spar-match-null)))
\ No newline at end of file
+	    (spar-match-null)))
+
+(define (spar-pattern-fixed-point procedure)
+  (letrec
+      ((spar
+	(pattern->spar
+	 (procedure
+	  `(spar
+	    ,(lambda (input senv output success failure)
+	       (spar input senv output success failure)))))))
+    `(spar ,spar)))
\ No newline at end of file