Implement complement, a predicate inverter.

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 37269a93ddb50f3a3929b2b2dae88a6fb8c37adf..fef70a8f3ef6e733f37e9d2a9b212601cc0aef03 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -55,6 +55,10 @@ USA.
   (and (compound-tag? object)
        (eq? 'conjoin (compound-tag-operator object))))
 
+(define (tag-is-complement? object)
+  (and (compound-tag? object)
+       (eq? 'complement (compound-tag-operator object))))
+
 (add-boot-init!
  (lambda ()
 
@@ -108,6 +112,12 @@ USA.
                  'conjoin
                  predicates))
 
+(define (complement predicate)
+  (make-predicate (lambda (object)
+                   (not (predicate object)))
+                 'complement
+                 (list predicate)))
+
 (define (make-predicate datum-test operator operands)
   (if (every predicate? operands)
       (dispatch-tag->predicate
@@ -157,4 +167,14 @@ USA.
      (make-joinish-memoizer dispatch-tag-is-top?))
 
    (define-compound-operator 'conjoin
-     (make-joinish-memoizer dispatch-tag-is-bottom?))))
\ No newline at end of file
+     (make-joinish-memoizer dispatch-tag-is-bottom?))
+
+   (define-compound-operator 'complement
+     (let ((table (make-key-weak-eqv-hash-table)))
+       (lambda (datum-test operator tags)
+        (hash-table-intern! table
+                            (car tags)
+                            (lambda ()
+                              (make-compound-tag datum-test operator tags))))))
+
+   ))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1511851512cd70d32414e5aa25915fdac75305a9..adf5ee221c22ec54fab14da48263a8765f7ef63c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2032,6 +2032,7 @@ USA.
   (files "compound-predicate")
   (parent (runtime))
   (export ()
+         complement
          conjoin
          conjoin*
          disjoin