Rename predicate constructor/accessor to tagger/untagger.

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 9f1a037db7f82f385c6a7b691aa9f81756f82208..defaa77630438e94a2837a3855fcca6015809430 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -58,11 +58,11 @@ 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-tagger predicate)
+  (tag-tagger (predicate->tag predicate 'predicate-tagger)))
 
-(define (predicate-element-accessor predicate)
-  (tag-element-accessor (predicate->tag predicate 'predicate-accessor)))
+(define (predicate-untagger predicate)
+  (tag-untagger (predicate->tag predicate 'predicate-untagger)))
 
 (define (predicate-tagging-strategy predicate)
   (tag-tagging-strategy (predicate->tag predicate 'predicate-tagging-strategy)))
@@ -112,12 +112,12 @@ USA.
   (if (not (default-object? description))
       (guarantee string? description caller))
   (tagging-strategy name datum-test
-    (lambda (predicate constructor accessor)
+    (lambda (predicate tagger untagger)
       (let ((tag
             (%make-tag name
                        predicate
-                       constructor
-                       accessor
+                       tagger
+                       untagger
                        (if (default-object? extra) #f extra)
                        (if (default-object? description) #f description)
                        tagging-strategy
@@ -132,13 +132,13 @@ USA.
            (every tag-name? object))))
 
 (define-record-type <tag>
-    (%make-tag name predicate constructor accessor extra description
+    (%make-tag name predicate tagger untagger extra description
               tagging-strategy subsets supersets)
     tag?
   (name tag-name)
   (predicate tag->predicate)
-  (constructor tag-element-constructor)
-  (accessor tag-element-accessor)
+  (tagger tag-tagger)
+  (untagger tag-untagger)
   (extra tag-extra)
   (description %tag-description)
   (tagging-strategy tag-tagging-strategy)

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 8479f925c6200c6deb64bf6c9d4ab46d38464965..a1d36527f8bb31334abdde82d460c30521cc8def 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -78,17 +78,18 @@ USA.
 ;;;; Tagging strategies
 
 (define (predicate-tagging-strategy:never name predicate make-tag)
+  (declare (ignore name))
 
-  (define (constructor object #!optional constructor-name)
-    (guarantee predicate object constructor-name)
+  (define (tagger object #!optional tagger-name)
+    (guarantee predicate object tagger-name)
     object)
 
-  (define (accessor object #!optional accessor-name)
-    (guarantee predicate object accessor-name)
+  (define (untagger object #!optional untagger-name)
+    (guarantee predicate object untagger-name)
     object)
 
   (define tag
-    (make-tag predicate constructor accessor))
+    (make-tag predicate tagger untagger))
 
   tag)
 
@@ -99,18 +100,18 @@ USA.
          (tag<= (tagged-object-tag object) tag)
          (datum-test (tagged-object-datum object))))
 
-  (define (constructor datum #!optional constructor-name)
+  (define (tagger datum #!optional tagger-name)
     (if (not (datum-test datum))
        (error:wrong-type-argument datum (string "datum for " name)
-                                  constructor-name))
+                                  tagger-name))
     (make-tagged-object tag datum))
 
-  (define (accessor object #!optional accessor-name)
-    (guarantee predicate object accessor-name)
-    object)
+  (define (untagger object #!optional untagger-name)
+    (guarantee predicate object untagger-name)
+    (tagged-object-datum object))
 
   (define tag
-    (make-tag predicate constructor tagged-object-datum))
+    (make-tag predicate tagger untagger))
 
   tag)
 
@@ -125,21 +126,21 @@ USA.
         (tag<= (tagged-object-tag object) tag)
         (datum-test (tagged-object-datum object))))
 
-  (define (constructor datum #!optional constructor-name)
+  (define (tagger datum #!optional tagger-name)
     (if (not (datum-test datum))
        (error:wrong-type-argument datum (string "datum for " name)
-                                  constructor-name))
+                                  tagger-name))
     (if (tag<= (object->tag datum) tag)
         datum
         (make-tagged-object tag datum)))
 
-  (define (accessor object #!optional accessor-name)
+  (define (untagger object #!optional untagger-name)
     (cond ((tagged-object-test object) (tagged-object-datum object))
          ((datum-test object) object)
-         (else (error:not-a predicate object accessor-name))))
+         (else (error:not-a predicate object untagger-name))))
 
   (define tag
-    (make-tag predicate constructor accessor))
+    (make-tag predicate tagger untagger))
 
   tag)
 \f

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 67c4e6d328d3e0d0c25cea755e4dfdf20a8ad61b..9c6caa3e6a219c5039d0e6670f0beceed0f40a29 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1890,10 +1890,10 @@ USA.
          guarantee-list-of
          no-object?
          predicate-description
-         predicate-element-accessor
-         predicate-element-constructor
          predicate-name
+         predicate-tagger
          predicate-tagging-strategy
+         predicate-untagger
          predicate?
          register-predicate!
          set-predicate<=!
@@ -1910,11 +1910,11 @@ USA.
          set-tag<=!
          tag->predicate
          tag-description
-         tag-element-accessor
-         tag-element-constructor
          tag-extra
          tag-name
+         tag-tagger
          tag-tagging-strategy
+         tag-untagger
          tag?
          top-tag
          top-tag?))

diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm
index 06f04a035801711f6991f3d7a7acb5f5e388ffd6..26d714aaf000f6dc4f2ff594d3e492026e94e10f 100644 (file)
--- a/tests/runtime/test-compound-predicate.scm
+++ b/tests/runtime/test-compound-predicate.scm
@@ -59,30 +59,24 @@ USA.
   (assert-eqv (compound-predicate-operator predicate) operator)
   (assert-lset= eqv? (compound-predicate-operands predicate) operands))
 
-(define-test 'construction
+(define-test 'tagging
   (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))
+    (test-tagging (disjoin) '() '(41 #t "41" 'foo))
+    (test-tagging (disjoin number? boolean?) '(41 #t) '("41" 'foo))
+    (test-tagging (disjoin number? string?) '(41 "41") '(#t 'foo))
+    (test-tagging (conjoin) '(41 #t "41" 'foo) '())
+    (test-tagging (conjoin number? boolean?) '() '(41 #t "41" 'foo))
+    (test-tagging (conjoin number? string?) '() '(41 #t "41" 'foo))))
+
+(define (test-tagging predicate data non-data)
+  (let ((tagger (predicate-tagger predicate))
+       (untagger (predicate-untagger predicate))
        (tagging-strategy (predicate-tagging-strategy predicate)))
     (for-each
      (lambda (datum)
-       (let ((object (constructor datum)))
+       (let ((object (tagger datum)))
         (assert-true (predicate object))
-        (assert-eq datum (accessor object))
+        (assert-eq datum (untagger object))
         (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
                (assert-eq datum object))
               ((eqv? tagging-strategy predicate-tagging-strategy:always)
@@ -93,5 +87,5 @@ USA.
                    (assert-not-eq datum object))))))
      data)
     (for-each (lambda (non-datum)
-               (assert-type-error (lambda () (constructor non-datum))))
+               (assert-type-error (lambda () (tagger 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 e381e671f6e2cb57bf0c81dfe6ad37d9f341fd64..2bb350085576b17b23af9256af5b81496c2bb6fa 100644 (file)
--- a/tests/runtime/test-predicate-metadata.scm
+++ b/tests/runtime/test-predicate-metadata.scm
@@ -51,21 +51,21 @@ USA.
     (assert-equal (tag-name tag) name)
     (assert-equal (predicate-description predicate) (tag-description tag))))
 
-(define-test 'simple-predicate-constructor
+(define-test 'simple-predicate-tagging
   (lambda ()
-    (test-element-construction number? '(41) '(foo))
-    (test-element-construction boolean? '(#t) '(foo))
-    (test-element-construction string? '("41") '(foo))))
+    (test-tagging number? '(41) '(foo))
+    (test-tagging boolean? '(#t) '(foo))
+    (test-tagging string? '("41") '(foo))))
 
-(define (test-element-construction predicate data non-data)
-  (let ((constructor (predicate-element-constructor predicate))
-       (accessor (predicate-element-accessor predicate))
+(define (test-tagging predicate data non-data)
+  (let ((tagger (predicate-tagger predicate))
+       (untagger (predicate-untagger predicate))
        (tagging-strategy (predicate-tagging-strategy predicate)))
     (for-each
      (lambda (datum)
-       (let ((object (constructor datum)))
+       (let ((object (tagger datum)))
         (assert-true (predicate object))
-        (assert-eq datum (accessor object))
+        (assert-eq datum (untagger object))
         (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
                (assert-eq datum object))
               ((eqv? tagging-strategy predicate-tagging-strategy:always)
@@ -76,5 +76,5 @@ USA.
                    (assert-not-eq datum object))))))
      data)
     (for-each (lambda (non-datum)
-               (assert-type-error (lambda () (constructor non-datum))))
+               (assert-type-error (lambda () (tagger non-datum))))
              non-data)))
\ No newline at end of file