From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Mar 2018 08:32:47 +0000 (-0700)
Subject: Implement spar-not.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~176
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e3cecb01609e99c81240d952a505d9ed17736ad1;p=mit-scheme.git

Implement spar-not.
---

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)