From e3cecb01609e99c81240d952a505d9ed17736ad1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Mar 2018 01:32:47 -0700
Subject: [PATCH] Implement spar-not.

---
 src/runtime/runtime.pkg       |  1 +
 src/runtime/syntax-parser.scm | 13 ++++++++++++-
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 58707f74f..d7586c4c5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4576,6 +4576,7 @@ USA.
 	  spar-match
 	  spar-match-elt
 	  spar-match-null
+	  spar-not
 	  spar-opt
 	  spar-or
 	  spar-push
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 64f8fa1f7..d48e54f06 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -324,6 +324,15 @@ USA.
 	(lambda ()
 	  (s2 input senv output success failure)))))
 
+(define (spar-not spar)
+  (lambda (input senv output success failure)
+    (spar input senv output
+	  (lambda (input* senv* output* failure*)
+	    (declare (ignore input* senv* output* failure*))
+	    (failure))
+	  (lambda ()
+	    (success input senv output failure)))))
+
 (define (spar-succeed input senv output success failure)
   (success input senv output failure))
 
@@ -471,7 +480,7 @@ USA.
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
     (lambda (:* :+ :and :call :close :compare :cons :elt :eqv? :form :hist :id?
-		:if :list :match-elt :match-null :opt :or :push :push-elt
+		:if :list :match-elt :match-null :not :opt :or :push :push-elt
 		:push-elt-if :push-value :senv :symbol? :value)
 
       (define (loop pattern)
@@ -497,6 +506,7 @@ USA.
 		 ('('if form form form) (apply :if (map loop (cdr pattern))))
 		 ('('or * form) (apply :or (map loop (cdr pattern))))
 		 ('('and * form) (apply :and (map loop (cdr pattern))))
+		 ('('not form) (:not (loop (cadr pattern))))
 		 ('('noise form) (:match-elt (:eqv?) (cadr pattern) (:form)))
 		 ('('noise-keyword identifier)
 		  (:match-elt (:compare) (cadr pattern) (:form)))
@@ -577,6 +587,7 @@ USA.
 	     (const 'list list)
 	     (proc 'spar-match-elt spar-match-elt)
 	     (proc 'spar-match-null spar-match-null)
+	     (proc 'spar-not spar-not)
 	     (flat-proc 'spar-opt spar-opt)
 	     (proc 'spar-or spar-or)
 	     (proc 'spar-push spar-push)
-- 
2.25.1