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

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 24dd25d3bdc88c911143f914c7281450b2f5dc08..e467696bb23cd8d1bab6e46dff39a32567639c3f 100644 (file)
--- 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 0c81c6573f9f203002fb8701578be82d2deed1f6..a01851012eed28ac3b8d33141d9492249af8dadd 100644 (file)
--- 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 b4ccd115b2dd426cb96098dff574abb3f52b1477..30f5b82a60c570f8b1e2729fd7f7811e19d32183 100644 (file)
--- 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