From bb5ba4b9cb5cd7be43ca0497d3d94a5c0e5d6f47 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Mar 2018 23:04:15 -0700
Subject: [PATCH] Implement spar-if and associated pattern.

---
 src/runtime/runtime.pkg       |  1 +
 src/runtime/syntax-parser.scm | 17 ++++++++++++++---
 2 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7276e53f9..8d7ddefb2 100644
--- 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 40a264e0b..4a3976e96 100644
--- 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)))))
 
 ;;;; 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)
-- 
2.25.1