From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 21 May 2018 05:35:26 +0000 (-0700)
Subject: Implement spar-arg:id!=? to handle useful case.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~17
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d9273eccf3dc9d0d0b06567b19a78fcadff5a74d;p=mit-scheme.git

Implement spar-arg:id!=? to handle useful case.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 59d13a93b..3713409d5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4614,6 +4614,7 @@ USA.
 	  spar-arg:close
 	  spar-arg:form
 	  spar-arg:hist
+	  spar-arg:id!=?
 	  spar-arg:id=?
 	  spar-arg:senv
 	  spar-arg:value
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 30f5b82a6..d6c374242 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -157,8 +157,10 @@ USA.
 	((eq? arg spar-arg:close) (make-closer (%input-closing-senv input)))
 	((eq? arg spar-arg:ctx)
 	 (serror-ctx (%input-form input) senv (%input-hist input)))
+	((eq? arg spar-arg:id!=?)
+	 (make-id!=? (%input-closing-senv input) senv (%input-form input)))
 	((eq? arg spar-arg:id=?)
-	 (make-comparer (%input-closing-senv input) senv (%input-form input)))
+	 (make-id=? (%input-closing-senv input) senv (%input-form input)))
 	((eq? arg spar-arg:senv) senv)
 	((eq? arg spar-arg:value) (%output-top output))
 	((eq? arg spar-arg:values) (%output-all output))
@@ -168,21 +170,28 @@ USA.
   (lambda (expr)
     (close-syntax expr closing-senv)))
 
-(define (make-comparer closing-senv use-senv form)
+(define (make-id=? closing-senv use-senv form)
   (lambda (reference #!optional comparand)
     (let ((comparand (if (default-object? comparand) form comparand)))
       (and (identifier? comparand)
 	   (identifier=? closing-senv reference use-senv comparand)))))
 
+(define (make-id!=? closing-senv use-senv form)
+  (lambda (reference #!optional comparand)
+    (let ((comparand (if (default-object? comparand) form comparand)))
+      (and (identifier? comparand)
+	   (not (identifier=? closing-senv reference use-senv comparand))))))
+
 (define-deferred spar-arg:form (string->uninterned-symbol ".form."))
 (define-deferred spar-arg:hist (string->uninterned-symbol ".hist."))
 (define-deferred spar-arg:close (string->uninterned-symbol ".close."))
 (define-deferred spar-arg:ctx (string->uninterned-symbol ".ctx."))
+(define-deferred spar-arg:id!=? (string->uninterned-symbol ".id!=?."))
 (define-deferred spar-arg:id=? (string->uninterned-symbol ".id=?."))
 (define-deferred spar-arg:senv (string->uninterned-symbol ".senv."))
 (define-deferred spar-arg:value (string->uninterned-symbol ".value."))
 (define-deferred spar-arg:values (string->uninterned-symbol ".values."))
-
+
 (define (spar-match predicate . args)
   (lambda (input senv output success failure)
     (if (apply (%subst-arg input senv output predicate)
@@ -523,6 +532,7 @@ USA.
 	  ((form) spar-arg:form)
 	  ((hist) spar-arg:hist)
 	  ((close) spar-arg:close)
+	  ((id!=?) spar-arg:id!=?)
 	  ((id=?) spar-arg:id=?)
 	  ((senv) spar-arg:senv)
 	  ((value) spar-arg:value)