Implement spar-if and associated pattern.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7276e53f92d3fe0f4f82ee36bfc90808b6f6ab7b..8d7ddefb229101536f588fa8f3120f8072b70ced 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4569,6 +4569,7 @@ USA.
          spar-error
          spar-fail
          spar-filter-map-values
+         spar-if
          spar-map-values
          spar-match
          spar-match-elt

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 40a264e0b1207cf81e1dba6a9f91738bde28e650..4a3976e9642ccdfc5abcc11f456e91d2aeb008db 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -329,6 +329,15 @@ USA.
 (define (spar-fail input senv output success failure)
   (declare (ignore input senv output success))
   (failure))
+
+(define (spar-if s1 s2 s3)
+  (lambda (input senv output success failure)
+    (s1 input senv output
+       (lambda (input* senv* output* failure*)
+         (declare (ignore failure*))
+         (s2 input* senv* output* success failure))
+       (lambda ()
+         (s3 input senv output success failure)))))
 \f
 ;;;; Element combinators
 
@@ -452,9 +461,9 @@ USA.
 
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
-    (lambda (:* :+ :call :close :compare :cons :elt :eqv? :form :hist :id? :list
-               :match-elt :match-null :opt :or :push :push-elt :push-elt-if
-               :push-value :senv :seq :symbol? :value)
+    (lambda (:* :+ :call :close :compare :cons :elt :eqv? :form :hist :id? :if
+               :list :match-elt :match-null :opt :or :push :push-elt
+               :push-elt-if :push-value :senv :seq :symbol? :value)
 
       (define (loop pattern)
        (let-syntax
@@ -476,6 +485,7 @@ USA.
                 ('('* * form) (apply :* (map loop (cdr pattern))))
                 ('('+ * form) (apply :+ (map loop (cdr pattern))))
                 ('('? * form) (apply :opt (map loop (cdr pattern))))
+                ('('if form form form) (apply :if (map loop (cdr pattern))))
                 ('('or * form) (apply :or (map loop (cdr pattern))))
                 ('('and * form) (apply :seq (map loop (cdr pattern))))
                 ('('quote form) (:match-elt (:eqv?) (cadr pattern) (:form)))
@@ -550,6 +560,7 @@ USA.
             (const 'spar-arg:form spar-arg:form)
             (const 'spar-arg:hist spar-arg:hist)
             (const 'identifier? identifier?)
+            (proc 'spar-if spar-if)
             (const 'list list)
             (proc 'spar-match-elt spar-match-elt)
             (proc 'spar-match-null spar-match-null)