Implement predicate-{element-{constructor,accessor},testing-strategy}.

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 5ee5fad1188bdfd7aed3b41c5eba2a0bd6e43040..71e00cc900ba3f38eec5a147fd9d6e2957303b3b 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -64,6 +64,15 @@ USA.
 (define (predicate-name predicate)
   (tag-name (predicate->tag predicate 'predicate-name)))
 
+(define (predicate-element-constructor predicate)
+  (tag-element-constructor (predicate->tag predicate 'predicate-constructor)))
+
+(define (predicate-element-accessor predicate)
+  (tag-element-accessor (predicate->tag predicate 'predicate-accessor)))
+
+(define (predicate-tagging-strategy predicate)
+  (tag-tagging-strategy (predicate->tag predicate 'predicate-tagging-strategy)))
+
 (define (predicate-description predicate)
   (let ((tag (get-predicate-tag predicate #f)))
     (if tag
@@ -116,6 +125,7 @@ USA.
                        accessor
                        (if (default-object? extra) #f extra)
                        (if (default-object? description) #f description)
+                       tagging-strategy
                        (make-strong-eq-hash-table)
                        (make-strong-eq-hash-table))))
        (set-predicate-tag! predicate tag)
@@ -128,14 +138,15 @@ USA.
 
 (define-record-type <tag>
     (%make-tag name predicate constructor accessor extra description
-              subsets supersets)
+              tagging-strategy subsets supersets)
     tag?
   (name tag-name)
   (predicate tag->predicate)
-  (constructor tag-constructor)
-  (accessor tag-accessor)
+  (constructor tag-element-constructor)
+  (accessor tag-element-accessor)
   (extra tag-extra)
   (description %tag-description)
+  (tagging-strategy tag-tagging-strategy)
   (subsets tag-subsets)
   (supersets tag-supersets))
 

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 9d17c1babd5e1d39db5dbacdcc5258a69f002264..8479f925c6200c6deb64bf6c9d4ab46d38464965 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -79,12 +79,12 @@ USA.
 
 (define (predicate-tagging-strategy:never name predicate make-tag)
 
-  (define (constructor object #!optional caller)
-    (guarantee predicate object caller)
+  (define (constructor object #!optional constructor-name)
+    (guarantee predicate object constructor-name)
     object)
 
-  (define (accessor object #!optional caller)
-    (guarantee predicate object caller)
+  (define (accessor object #!optional accessor-name)
+    (guarantee predicate object accessor-name)
     object)
 
   (define tag
@@ -99,13 +99,14 @@ USA.
          (tag<= (tagged-object-tag object) tag)
          (datum-test (tagged-object-datum object))))
 
-  (define (constructor datum #!optional caller)
+  (define (constructor datum #!optional constructor-name)
     (if (not (datum-test datum))
-       (error:wrong-type-argument datum (string "datum for " name) caller))
+       (error:wrong-type-argument datum (string "datum for " name)
+                                  constructor-name))
     (make-tagged-object tag datum))
 
-  (define (accessor object #!optional caller)
-    (guarantee predicate object caller)
+  (define (accessor object #!optional accessor-name)
+    (guarantee predicate object accessor-name)
     object)
 
   (define tag
@@ -124,17 +125,18 @@ USA.
         (tag<= (tagged-object-tag object) tag)
         (datum-test (tagged-object-datum object))))
 
-  (define (constructor datum #!optional caller)
+  (define (constructor datum #!optional constructor-name)
     (if (not (datum-test datum))
-       (error:wrong-type-argument datum (string "datum for " name) caller))
-    (if (eq? tag (object->tag datum))
+       (error:wrong-type-argument datum (string "datum for " name)
+                                  constructor-name))
+    (if (tag<= (object->tag datum) tag)
         datum
         (make-tagged-object tag datum)))
 
-  (define (accessor object #!optional caller)
+  (define (accessor object #!optional accessor-name)
     (cond ((tagged-object-test object) (tagged-object-datum object))
          ((datum-test object) object)
-         (else (error:not-a predicate object caller))))
+         (else (error:not-a predicate object accessor-name))))
 
   (define tag
     (make-tag predicate constructor accessor))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8d12e9476b3bf0b174fd5318b653e78d23f277c9..b57672cda1c602fce1e16c67380bbbc5feacb09b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1782,7 +1782,10 @@ USA.
          guarantee-list-of
          no-object?
          predicate-description
+         predicate-element-accessor
+         predicate-element-constructor
          predicate-name
+         predicate-tagging-strategy
          predicate?
          register-predicate!
          set-predicate<=!
@@ -1800,8 +1803,11 @@ USA.
          set-tag<=!
          tag->predicate
          tag-description
+         tag-element-accessor
+         tag-element-constructor
          tag-extra
          tag-name
+         tag-tagging-strategy
          tag?
          top-tag
          top-tag?))

diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm
index 67cec84ea7df5f42f82eba539460ee9bb8378a86..06f04a035801711f6991f3d7a7acb5f5e388ffd6 100644 (file)
--- a/tests/runtime/test-compound-predicate.scm
+++ b/tests/runtime/test-compound-predicate.scm
@@ -57,4 +57,41 @@ USA.
 (define (test-compound-predicate-operations predicate operator operands)
   (assert-true (compound-predicate? predicate))
   (assert-eqv (compound-predicate-operator predicate) operator)
-  (assert-lset= eqv? (compound-predicate-operands predicate) operands))
\ No newline at end of file
+  (assert-lset= eqv? (compound-predicate-operands predicate) operands))
+
+(define-test 'construction
+  (lambda ()
+    (test-element-construction (disjoin)
+                              '() '(41 #t "41" 'foo))
+    (test-element-construction (disjoin number? boolean?)
+                              '(41 #t) '("41" 'foo))
+    (test-element-construction (disjoin number? string?)
+                              '(41 "41") '(#t 'foo))
+    (test-element-construction (conjoin)
+                              '(41 #t "41" 'foo) '())
+    (test-element-construction (conjoin number? boolean?)
+                              '() '(41 #t "41" 'foo))
+    (test-element-construction (conjoin number? string?)
+                              '() '(41 #t "41" 'foo))))
+
+(define (test-element-construction predicate data non-data)
+  (let ((constructor (predicate-element-constructor predicate))
+       (accessor (predicate-element-accessor predicate))
+       (tagging-strategy (predicate-tagging-strategy predicate)))
+    (for-each
+     (lambda (datum)
+       (let ((object (constructor datum)))
+        (assert-true (predicate object))
+        (assert-eq datum (accessor object))
+        (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
+               (assert-eq datum object))
+              ((eqv? tagging-strategy predicate-tagging-strategy:always)
+               (assert-not-eq datum object))
+              (else
+               (if (predicate<= (object->predicate datum) predicate)
+                   (assert-eq datum object)
+                   (assert-not-eq datum object))))))
+     data)
+    (for-each (lambda (non-datum)
+               (assert-type-error (lambda () (constructor non-datum))))
+             non-data)))
\ No newline at end of file

diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm
index 7d9e7a2a42a4b0cd1fcd8bf35d4344f5fd40971b..e381e671f6e2cb57bf0c81dfe6ad37d9f341fd64 100644 (file)
--- a/tests/runtime/test-predicate-metadata.scm
+++ b/tests/runtime/test-predicate-metadata.scm
@@ -49,4 +49,32 @@ USA.
     (assert-eqv (tag->predicate tag) predicate)
     (assert-equal (predicate-name predicate) name)
     (assert-equal (tag-name tag) name)
-    (assert-equal (predicate-description predicate) (tag-description tag))))
\ No newline at end of file
+    (assert-equal (predicate-description predicate) (tag-description tag))))
+
+(define-test 'simple-predicate-constructor
+  (lambda ()
+    (test-element-construction number? '(41) '(foo))
+    (test-element-construction boolean? '(#t) '(foo))
+    (test-element-construction string? '("41") '(foo))))
+
+(define (test-element-construction predicate data non-data)
+  (let ((constructor (predicate-element-constructor predicate))
+       (accessor (predicate-element-accessor predicate))
+       (tagging-strategy (predicate-tagging-strategy predicate)))
+    (for-each
+     (lambda (datum)
+       (let ((object (constructor datum)))
+        (assert-true (predicate object))
+        (assert-eq datum (accessor object))
+        (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
+               (assert-eq datum object))
+              ((eqv? tagging-strategy predicate-tagging-strategy:always)
+               (assert-not-eq datum object))
+              (else
+               (if (predicate<= (object->predicate datum) predicate)
+                   (assert-eq datum object)
+                   (assert-not-eq datum object))))))
+     data)
+    (for-each (lambda (non-datum)
+               (assert-type-error (lambda () (constructor non-datum))))
+             non-data)))
\ No newline at end of file