Rename "tag" to "dispatch-tag" and move bindings to global env.

This name is at least somewhat specific, so it should be OK in global.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index eee490b9112d6c0d81af4af44da8e5e87bb66618..a78024dea8b0c13f0c27ff4441443b744bcf091f 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -57,11 +57,12 @@ USA.
       ((predicate
        (lambda (datum)
          (and (bundle? datum)
-              (tag<= (bundle-interface-tag (bundle-interface datum)) tag))))
+              (dispatch-tag<= (bundle-interface-tag (bundle-interface datum))
+                              tag))))
        (tag
        (begin
          (register-predicate! predicate name '<= bundle?)
-         (predicate->tag predicate))))
+         (predicate->dispatch-tag predicate))))
     tag))
 
 (define (elements? object)
@@ -88,7 +89,7 @@ USA.
   (element-properties %bundle-interface-element-properties))
 
 (define (bundle-interface-predicate interface)
-  (tag->predicate (bundle-interface-tag interface)))
+  (dispatch-tag->predicate (bundle-interface-tag interface)))
 
 (define (bundle-interface-element-names interface)
   (vector->list (%bundle-interface-element-names interface)))

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 13cdd7240416d15180daea520f8ad3887fceaff6..9cc5b72d554d5e8491e01f93c67be0884298f79d 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -29,23 +29,23 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define compound-tag-metatag (make-metatag 'compound-tag))
-(define compound-tag? (tag->predicate compound-tag-metatag))
+(define compound-tag-metatag (make-dispatch-metatag 'compound-tag))
+(define compound-tag? (dispatch-tag->predicate compound-tag-metatag))
 
 (define %make-compound-tag
-  (metatag-constructor compound-tag-metatag 'make-compound-tag))
+  (dispatch-metatag-constructor compound-tag-metatag 'make-compound-tag))
 
 (define (make-compound-tag predicate operator operands)
-  (%make-compound-tag (cons operator (map tag-name operands))
+  (%make-compound-tag (cons operator (map dispatch-tag-name operands))
                      predicate
                      operator
                      operands))
 
 (define-integrable (compound-tag-operator tag)
-  (tag-extra tag 0))
+  (dispatch-tag-extra tag 0))
 
 (define-integrable (compound-tag-operands tag)
-  (tag-extra tag 1))
+  (dispatch-tag-extra tag 1))
 
 (define (tag-is-disjoin? object)
   (and (compound-tag? object)
@@ -58,21 +58,21 @@ USA.
 (add-boot-init!
  (lambda ()
 
-   (define-tag<= tag? tag-is-disjoin?
+   (define-dispatch-tag<= dispatch-tag? tag-is-disjoin?
      (lambda (tag1 tag2)
        (any (lambda (component2)
-             (tag<= tag1 component2))
+             (dispatch-tag<= tag1 component2))
            (compound-tag-operands tag2))))
 
-   (define-tag<= tag-is-conjoin? tag?
+   (define-dispatch-tag<= tag-is-conjoin? dispatch-tag?
      (lambda (tag1 tag2)
        (any (lambda (component1)
-             (tag<= component1 tag2))
+             (dispatch-tag<= component1 tag2))
            (compound-tag-operands tag1))))))
 \f
 (define (compound-predicate? object)
   (and (predicate? object)
-       (compound-tag? (predicate->tag object))))
+       (compound-tag? (predicate->dispatch-tag object))))
 
 (add-boot-init!
  (lambda ()
@@ -80,10 +80,11 @@ USA.
                        '<= predicate?)))
 
 (define (compound-predicate-operator predicate)
-  (compound-tag-operator (predicate->tag predicate)))
+  (compound-tag-operator (predicate->dispatch-tag predicate)))
 
 (define (compound-predicate-operands predicate)
-  (map tag->predicate (compound-tag-operands (predicate->tag predicate))))
+  (map dispatch-tag->predicate
+       (compound-tag-operands (predicate->dispatch-tag predicate))))
 
 (define (disjoin . predicates)
   (disjoin* predicates))
@@ -109,11 +110,11 @@ USA.
 
 (define (make-predicate datum-test operator operands)
   (if (every predicate? operands)
-      (tag->predicate
+      (dispatch-tag->predicate
        ((compound-operator-builder operator)
        datum-test
        operator
-       (map predicate->tag operands)))
+       (map predicate->dispatch-tag operands)))
       datum-test))
 \f
 (define compound-operator-builder)
@@ -153,7 +154,7 @@ USA.
                   (memoizer datum-test operator tags)))))))
 
    (define-compound-operator 'disjoin
-     (make-joinish-memoizer tag-is-top?))
+     (make-joinish-memoizer dispatch-tag-is-top?))
 
    (define-compound-operator 'conjoin
-     (make-joinish-memoizer tag-is-bottom?))))
\ No newline at end of file
+     (make-joinish-memoizer dispatch-tag-is-bottom?))))
\ No newline at end of file

diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 149c23a39bcbc3a6e0ec12de84d04ca72a03711c..46d41b7d5960087b2af95067c506420cc8b1c6e9 100644 (file)
--- a/src/runtime/gentag.scm
+++ b/src/runtime/gentag.scm
@@ -60,25 +60,25 @@ USA.
                    (or (object-non-pointer? elt)
                        (tag-name? elt)))
                  (cdr object)))))
-(register-predicate! tag-name? 'tag-name)
+(register-predicate! tag-name? 'dispatch-tag-name)
 
 (define (set-predicate-tag! predicate tag)
   (defer-boot-action 'set-predicate-tag!
     (lambda ()
       (set-predicate-tag! predicate tag))))
 
-(define (tag? object)
+(define (dispatch-tag? object)
   (and (%record? object)
-       (metatag? (%record-ref object 0))))
-(register-predicate! tag? 'tag '<= %record?)
+       (dispatch-metatag? (%record-ref object 0))))
+(register-predicate! dispatch-tag? 'tag '<= %record?)
 
-(define-integrable (%tag-name tag)
+(define-integrable (%dispatch-tag-name tag)
   (%record-ref tag 9))
 
-(define-integrable (%tag->predicate tag)
+(define-integrable (%dispatch-tag->predicate tag)
   (%record-ref tag 10))
 
-(define-integrable (%tag-extra tag)
+(define-integrable (%dispatch-tag-extra tag)
   (%record-ref tag 11))
 
 (define-integrable (%tag-supersets tag)
@@ -103,19 +103,19 @@ USA.
     (lambda ()
       (random modulus state))))
 \f
-(define (make-metatag name)
-  (guarantee tag-name? name 'make-metatag)
+(define (make-dispatch-metatag name)
+  (guarantee tag-name? name 'make-dispatch-metatag)
   (letrec*
       ((predicate
        (lambda (object)
          (and (%record? object)
               (eq? metatag (%record-ref object 0)))))
        (metatag (%make-tag metatag-tag name predicate '#())))
-    (set-tag<=! metatag metatag-tag)
+    (set-dispatch-tag<=! metatag metatag-tag)
     metatag))
 
-(define (metatag-constructor metatag #!optional caller)
-  (guarantee metatag? metatag 'metatag-constructor)
+(define (dispatch-metatag-constructor metatag #!optional caller)
+  (guarantee dispatch-metatag? metatag 'dispatch-metatag-constructor)
   (lambda (name predicate . extra)
     (guarantee tag-name? name caller)
     (guarantee unary-procedure? predicate caller)
@@ -123,60 +123,60 @@ USA.
        (error "Can't assign multiple tags to the same predicate:" name))
     (%make-tag metatag name predicate (list->vector extra))))
 
-(define (metatag? object)
+(define (dispatch-metatag? object)
   (and (%record? object)
        (eq? metatag-tag (%record-ref object 0))))
 
 (define metatag-tag)
 (add-boot-init!
  (lambda ()
-   (set! metatag-tag (%make-tag #f 'metatag metatag? '#()))
+   (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#()))
    (%record-set! metatag-tag 0 metatag-tag)))
 
-(define (set-tag<=! t1 t2)
+(define (set-dispatch-tag<=! t1 t2)
   (defer-boot-action 'predicate-relations
     (lambda ()
-      (set-tag<=! t1 t2))))
+      (set-dispatch-tag<=! t1 t2))))
 \f
-(define (tag-metatag tag)
-  (guarantee tag? tag 'tag-metatag)
+(define (dispatch-tag-metatag tag)
+  (guarantee dispatch-tag? tag 'dispatch-tag-metatag)
   (%record-ref tag 0))
 
-(define (tag-name tag)
-  (guarantee tag? tag 'tag-name)
-  (%tag-name tag))
+(define (dispatch-tag-name tag)
+  (guarantee dispatch-tag? tag 'dispatch-tag-name)
+  (%dispatch-tag-name tag))
 
-(define (tag->predicate tag)
-  (guarantee tag? tag 'tag->predicate)
-  (%tag->predicate tag))
+(define (dispatch-tag->predicate tag)
+  (guarantee dispatch-tag? tag 'dispatch-tag->predicate)
+  (%dispatch-tag->predicate tag))
 
-(define (tag-extra tag index)
-  (guarantee tag? tag 'tag-extra)
-  (vector-ref (%tag-extra tag) index))
+(define (dispatch-tag-extra tag index)
+  (guarantee dispatch-tag? tag 'dispatch-tag-extra)
+  (vector-ref (%dispatch-tag-extra tag) index))
 
-(define (any-tag-superset procedure tag)
-  (guarantee tag? tag 'any-tag-superset)
+(define (any-dispatch-tag-superset procedure tag)
+  (guarantee dispatch-tag? tag 'any-dispatch-tag-superset)
   (%weak-set-any procedure (%tag-supersets tag)))
 
-(define (add-tag-superset tag superset)
-  (guarantee tag? tag 'add-tag-superset)
-  (guarantee tag? superset 'add-tag-superset)
+(define (add-dispatch-tag-superset tag superset)
+  (guarantee dispatch-tag? tag 'add-dispatch-tag-superset)
+  (guarantee dispatch-tag? superset 'add-dispatch-tag-superset)
   (%add-to-weak-set superset (%tag-supersets tag)))
 
 (defer-boot-action 'predicate-relations
   (lambda ()
-    (set-predicate<=! metatag? tag?)))
+    (set-predicate<=! dispatch-metatag? dispatch-tag?)))
 
-(define-unparser-method tag?
+(define-unparser-method dispatch-tag?
   (simple-unparser-method
    (lambda (tag)
-     (if (metatag? tag) 'metatag 'tag))
+     (if (dispatch-metatag? tag) 'metatag 'tag))
    (lambda (tag)
-     (list (tag-name tag)))))
+     (list (dispatch-tag-name tag)))))
 
-(define-pp-describer tag?
+(define-pp-describer dispatch-tag?
   (lambda (tag)
-    (list (list 'metatag (tag-metatag tag))
-         (list 'name (tag-name tag))
-         (list 'predicate (tag->predicate tag))
-         (cons 'extra (vector->list (%tag-extra tag))))))
\ No newline at end of file
+    (list (list 'metatag (dispatch-tag-metatag tag))
+         (list 'name (dispatch-tag-name tag))
+         (list 'predicate (dispatch-tag->predicate tag))
+         (cons 'extra (vector->list (%dispatch-tag-extra tag))))))
\ No newline at end of file

diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index 69e626548dbb6c57259c0a8005b4dd948d64a0fe..9e6fc918b4fc30b71e9be4b795ee8e8473c483f7 100644 (file)
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -29,30 +29,30 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define parametric-tag-metatag (make-metatag 'parametric-tag))
-(define parametric-tag? (tag->predicate parametric-tag-metatag))
+(define parametric-tag-metatag (make-dispatch-metatag 'parametric-tag))
+(define parametric-tag? (dispatch-tag->predicate parametric-tag-metatag))
 
 (define %make-parametric-tag
-  (metatag-constructor parametric-tag-metatag 'make-parametric-tag))
+  (dispatch-metatag-constructor parametric-tag-metatag 'make-parametric-tag))
 
 (define (make-parametric-tag name predicate template bindings)
   (%make-parametric-tag name predicate template bindings))
 
 (define-integrable (parametric-tag-template tag)
-  (tag-extra tag 0))
+  (dispatch-tag-extra tag 0))
 
 (define-integrable (parametric-tag-bindings tag)
-  (tag-extra tag 1))
+  (dispatch-tag-extra tag 1))
 
 (define (parametric-predicate? object)
   (and (predicate? object)
-       (parametric-tag? (predicate->tag object))))
+       (parametric-tag? (predicate->dispatch-tag object))))
 
 (define (parametric-predicate-template predicate)
-  (parametric-tag-template (predicate->tag predicate)))
+  (parametric-tag-template (predicate->dispatch-tag predicate)))
 
 (define (parametric-predicate-bindings predicate)
-  (parametric-tag-bindings (predicate->tag predicate)))
+  (parametric-tag-bindings (predicate->dispatch-tag predicate)))
 \f
 ;;;; Templates
 
@@ -93,17 +93,17 @@ USA.
               (cons name
                     (map-template-pattern pattern
                                           patterned-tags
-                                          tag-name
+                                          dispatch-tag-name
                                           caller))
               (apply make-data-test
                      (map-template-pattern pattern
                                            patterned-tags
-                                           tag->predicate
+                                           dispatch-tag->predicate
                                            caller))
               (get-template)
               (match-template-pattern pattern
                                       patterned-tags
-                                      tag?
+                                      dispatch-tag?
                                       caller))))
       tag)))
 \f
@@ -111,10 +111,10 @@ USA.
   (let ((instantiator (template-instantiator template))
         (pattern (predicate-template-pattern template)))
     (lambda patterned-predicates
-      (tag->predicate
+      (dispatch-tag->predicate
        (instantiator (map-template-pattern pattern
                                           patterned-predicates
-                                          predicate->tag
+                                          predicate->dispatch-tag
                                           caller)
                     caller)))))
 
@@ -131,15 +131,16 @@ USA.
     (let ((valid? (predicate-template-predicate template))
           (convert
            (if (template-pattern-element-single-valued? elt)
-               tag->predicate
-              (lambda (tags) (map tag->predicate tags)))))
+               dispatch-tag->predicate
+              (lambda (tags) (map dispatch-tag->predicate tags)))))
       (lambda (predicate)
        (guarantee valid? predicate caller)
         (convert
          (parameter-binding-value
           (find (lambda (binding)
                   (eqv? name (parameter-binding-name binding)))
-                (parametric-tag-bindings (predicate->tag predicate)))))))))
+                (parametric-tag-bindings
+                (predicate->dispatch-tag predicate)))))))))
 \f
 ;;;; Template patterns
 
@@ -247,7 +248,7 @@ USA.
 
 (add-boot-init!
  (lambda ()
-   (define-tag<= parametric-tag? parametric-tag?
+   (define-dispatch-tag<= parametric-tag? parametric-tag?
      (lambda (tag1 tag2)
        (and (eqv? (parametric-tag-template tag1)
                  (parametric-tag-template tag2))
@@ -257,9 +258,9 @@ USA.
                       (and (= (length tags1) (length tags2))
                            (every (case (parameter-binding-polarity
                                          bind1)
-                                    ((+) tag<=)
-                                    ((-) tag>=)
-                                    (else tag=))
+                                    ((+) dispatch-tag<=)
+                                    ((-) dispatch-tag>=)
+                                    (else dispatch-tag=))
                                   tags1
                                   tags2))))
                   (parametric-tag-bindings tag1)

diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm
index 8d767dc89a09a940981f9ad3fa6c3a9a76613eae..246bc9286754a6bc53e0d5f94171d2918ca58520 100644 (file)
--- a/src/runtime/predicate-dispatch.scm
+++ b/src/runtime/predicate-dispatch.scm
@@ -252,7 +252,9 @@ USA.
         (else (delegate operator))))))
 
 (define (cached-most-specific-handler-set default-handler)
-  (cached-handler-set (most-specific-handler-set default-handler) object->tag))
+  (cached-handler-set (most-specific-handler-set default-handler)
+                     object->dispatch-tag))
 
 (define (cached-chaining-handler-set default-handler)
-  (cached-handler-set (chaining-handler-set default-handler) object->tag))
\ No newline at end of file
+  (cached-handler-set (chaining-handler-set default-handler)
+                     object->dispatch-tag))
\ No newline at end of file

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index 287e7ae2d002c0fd5d47a692b8a1163f6a709d27..c38ee3a27c4e6a0db9c581239922bd63c048f1ea 100644 (file)
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -30,55 +30,55 @@ USA.
 (declare (usual-integrations))
 \f
 (define (predicate<= predicate1 predicate2)
-  (tag<= (predicate->tag predicate1)
-         (predicate->tag predicate2)))
+  (dispatch-tag<= (predicate->dispatch-tag predicate1)
+                 (predicate->dispatch-tag predicate2)))
 
 (define (predicate>= predicate1 predicate2)
   (predicate<= predicate2 predicate1))
 
 (define (set-predicate<=! predicate superset)
-  (set-tag<=! (predicate->tag predicate 'set-predicate<=!)
-              (predicate->tag superset 'set-predicate<=!)))
+  (set-dispatch-tag<=! (predicate->dispatch-tag predicate 'set-predicate<=!)
+                      (predicate->dispatch-tag superset 'set-predicate<=!)))
 
-(define (tag= tag1 tag2)
-  (guarantee tag? tag1 'tag=)
-  (guarantee tag? tag2 'tag=)
+(define (dispatch-tag= tag1 tag2)
+  (guarantee dispatch-tag? tag1 'dispatch-tag=)
+  (guarantee dispatch-tag? tag2 'dispatch-tag=)
   (eq? tag1 tag2))
 
-(define (tag<= tag1 tag2)
-  (guarantee tag? tag1 'tag<=)
-  (guarantee tag? tag2 'tag<=)
-  (cached-tag<= tag1 tag2))
+(define (dispatch-tag<= tag1 tag2)
+  (guarantee dispatch-tag? tag1 'dispatch-tag<=)
+  (guarantee dispatch-tag? tag2 'dispatch-tag<=)
+  (cached-dispatch-tag<= tag1 tag2))
 
-(define (tag>= tag1 tag2)
-  (tag<= tag2 tag1))
+(define (dispatch-tag>= tag1 tag2)
+  (dispatch-tag<= tag2 tag1))
 
-(define (cached-tag<= tag1 tag2)
-  (hash-table-intern! tag<=-cache
+(define (cached-dispatch-tag<= tag1 tag2)
+  (hash-table-intern! dispatch-tag<=-cache
                      (cons tag1 tag2)
-                     (lambda () (uncached-tag<= tag1 tag2))))
+                     (lambda () (uncached-dispatch-tag<= tag1 tag2))))
 
-(define (uncached-tag<= tag1 tag2)
+(define (uncached-dispatch-tag<= tag1 tag2)
   (or (eq? tag1 tag2)
-      (tag-is-bottom? tag1)
-      (tag-is-top? tag2)
-      (and (not (tag-is-top? tag1))
-          (not (tag-is-bottom? tag2))
+      (dispatch-tag-is-bottom? tag1)
+      (dispatch-tag-is-top? tag2)
+      (and (not (dispatch-tag-is-top? tag1))
+          (not (dispatch-tag-is-bottom? tag2))
           (let ((v
                  (find (lambda (v)
                          (and ((vector-ref v 0) tag1)
                               ((vector-ref v 1) tag2)))
-                       tag<=-overrides)))
+                       dispatch-tag<=-overrides)))
             (if v
                 ((vector-ref v 2) tag1 tag2)
-                (any-tag-superset (lambda (tag)
-                                    (cached-tag<= tag tag2))
-                                  tag1))))))
+                (any-dispatch-tag-superset (lambda (tag)
+                                             (cached-dispatch-tag<= tag tag2))
+                                           tag1))))))
 
-(define (define-tag<= test1 test2 handler)
-  (set! tag<=-overrides
+(define (define-dispatch-tag<= test1 test2 handler)
+  (set! dispatch-tag<=-overrides
        (cons (vector test1 test2 handler)
-             tag<=-overrides))
+             dispatch-tag<=-overrides))
   unspecific)
 \f
 (define (any-object? object)
@@ -89,31 +89,34 @@ USA.
   (declare (ignore object))
   #f)
 
-(define (top-tag) the-top-tag)
-(define (bottom-tag) the-bottom-tag)
+(define (top-dispatch-tag) the-top-dispatch-tag)
+(define (bottom-dispatch-tag) the-bottom-dispatch-tag)
 
-(define-integrable (tag-is-top? tag) (eq? the-top-tag tag))
-(define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag))
+(define-integrable (dispatch-tag-is-top? tag)
+  (eq? the-top-dispatch-tag tag))
 
-(define-deferred the-top-tag
+(define-integrable (dispatch-tag-is-bottom? tag)
+  (eq? the-bottom-dispatch-tag tag))
+
+(define-deferred the-top-dispatch-tag
   (make-compound-tag any-object? 'conjoin '()))
 
-(define-deferred the-bottom-tag
+(define-deferred the-bottom-dispatch-tag
   (make-compound-tag no-object? 'disjoin '()))
 
-(define tag<=-cache)
-(define tag<=-overrides)
+(define dispatch-tag<=-cache)
+(define dispatch-tag<=-overrides)
 (add-boot-init!
  (lambda ()
    ;; TODO(cph): should be a weak-key table, but we don't have tables that have
    ;; weak compound keys.
-   (set! tag<=-cache (make-equal-hash-table))
-   (set! tag<=-overrides '())
-   (set! set-tag<=!
-        (named-lambda (set-tag<=! tag superset)
-          (if (not (add-tag-superset tag superset))
+   (set! dispatch-tag<=-cache (make-equal-hash-table))
+   (set! dispatch-tag<=-overrides '())
+   (set! set-dispatch-tag<=!
+        (named-lambda (set-dispatch-tag<=! tag superset)
+          (if (not (add-dispatch-tag-superset tag superset))
               (error "Tag already has this superset:" tag superset))
-          (if (tag>= tag superset)
+          (if (dispatch-tag>= tag superset)
               (error "Not allowed to create a superset loop:" tag superset))
-          (hash-table-clear! tag<=-cache)))
+          (hash-table-clear! dispatch-tag<=-cache)))
    (run-deferred-boot-actions 'predicate-relations)))
\ No newline at end of file

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index ba95d6cf5b4e79d0c3ad3437dfc71a40364edb56..a97e56bf5e2e84382bb004c08a7f1c995cdff994 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -39,9 +39,9 @@ USA.
      (run-deferred-boot-actions 'set-predicate-tag!))))
 
 (define (predicate-name predicate)
-  (tag-name (predicate->tag predicate 'predicate-name)))
+  (dispatch-tag-name (predicate->dispatch-tag predicate 'predicate-name)))
 
-(define (predicate->tag predicate #!optional caller)
+(define (predicate->dispatch-tag predicate #!optional caller)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
         (error:not-a predicate? predicate caller))
@@ -52,16 +52,18 @@ USA.
 (add-boot-init!
  (lambda ()
    (set! simple-tag-metatag
-        (make-metatag 'simple-tag))
+        (make-dispatch-metatag 'simple-tag))
    (set! %make-simple-tag
-        (metatag-constructor simple-tag-metatag 'register-predicate!))
-   (run-deferred-boot-actions 'make-metatag)
+        (dispatch-metatag-constructor simple-tag-metatag 'register-predicate!))
+   (run-deferred-boot-actions 'make-dispatch-metatag)
    (set! register-predicate!
         (named-lambda (register-predicate! predicate name . keylist)
           (guarantee keyword-list? keylist 'register-predicate!)
           (let ((tag (%make-simple-tag name predicate #f)))
             (for-each (lambda (superset)
-                        (set-tag<=! tag (predicate->tag superset)))
+                        (set-dispatch-tag<=!
+                         tag
+                         (predicate->dispatch-tag superset)))
                       (get-keyword-values keylist '<=))
             tag)))
    unspecific))

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 7af96ca48ccff254f4187bb59786cb80a50bad9a..eec437270cb64c9217cb52e24e8d9362ca641d8a 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -30,9 +30,9 @@ USA.
 (declare (usual-integrations))
 \f
 (define (object->predicate object)
-  (tag->predicate (object->tag object)))
+  (dispatch-tag->predicate (object->dispatch-tag object)))
 
-(define (object->tag object)
+(define (object->dispatch-tag object)
   (let ((code (object-type object)))
     (or (vector-ref primitive-tags code)
        ((vector-ref primitive-tag-methods code) object)
@@ -44,14 +44,14 @@ USA.
       object))
 
 (define (predicate-tagger predicate)
-  (%tag-tagger (predicate->tag predicate 'predicate-tagger) predicate))
+  (%tag-tagger (predicate->dispatch-tag predicate 'predicate-tagger) predicate))
 
-(define (tag-tagger tag)
-  (%tag-tagger tag (tag->predicate tag)))
+(define (dispatch-tag-tagger tag)
+  (%tag-tagger tag (dispatch-tag->predicate tag)))
 
 (define (%tag-tagger tag predicate)
   (lambda (datum #!optional tagger-name)
-    (if (tag<= (object->tag datum) tag)
+    (if (dispatch-tag<= (object->dispatch-tag datum) tag)
        datum
        (begin
          (guarantee predicate datum tagger-name)
@@ -63,7 +63,7 @@ USA.
  (lambda ()
    (set! primitive-tags
         (make-vector (microcode-type/code-limit)
-                     (top-tag)))
+                     (top-dispatch-tag)))
    (set! primitive-tag-methods
         (make-vector (microcode-type/code-limit) #f))
    unspecific))
@@ -73,7 +73,7 @@ USA.
    (define (define-primitive-predicate type-name predicate)
      (vector-set! primitive-tags
                  (microcode-type/name->code type-name)
-                 (predicate->tag predicate)))
+                 (predicate->dispatch-tag predicate)))
 
    (define-primitive-predicate 'bignum exact-integer?)
    (define-primitive-predicate 'bytevector bytevector?)
@@ -113,7 +113,7 @@ USA.
    (define-primitive-predicate-method 'constant
      (let* ((constant-tags
             (list->vector
-             (map predicate->tag
+             (map predicate->dispatch-tag
                   (list boolean?
                         undefined-value?
                         undefined-value?
@@ -129,21 +129,21 @@ USA.
         (let ((datum (object-datum object)))
           (if (and (fix:fixnum? datum) (fix:< datum n-tags))
               (vector-ref constant-tags datum)
-              (top-tag))))))
+              (top-dispatch-tag))))))
 
    (define-primitive-predicate-method 'entity
-     (let ((apply-hook-tag (predicate->tag apply-hook?))
-          (entity-tag (predicate->tag entity?)))
+     (let ((apply-hook-tag (predicate->dispatch-tag apply-hook?))
+          (entity-tag (predicate->dispatch-tag entity?)))
        (lambda (object)
         (if (%entity-is-apply-hook? object)
             apply-hook-tag
             entity-tag))))
 
    (define-primitive-predicate-method 'compiled-entry
-     (let ((procedure-tag (predicate->tag compiled-procedure?))
-          (return-tag (predicate->tag compiled-return-address?))
-          (expression-tag (predicate->tag compiled-expression?))
-          (default-tag (predicate->tag compiled-code-address?)))
+     (let ((procedure-tag (predicate->dispatch-tag compiled-procedure?))
+          (return-tag (predicate->dispatch-tag compiled-return-address?))
+          (expression-tag (predicate->dispatch-tag compiled-expression?))
+          (default-tag (predicate->dispatch-tag compiled-code-address?)))
        (lambda (entry)
         (case (system-hunk3-cxr0
                ((ucode-primitive compiled-entry-kind 1) entry))
@@ -153,8 +153,8 @@ USA.
           (else default-tag)))))
 
    (define-primitive-predicate-method 'record
-     (let ((default-tag (predicate->tag %record?)))
+     (let ((default-tag (predicate->dispatch-tag %record?)))
        (lambda (object)
-        (if (tag? (%record-ref object 0))
+        (if (dispatch-tag? (%record-ref object 0))
             (%record-ref object 0)
             default-tag))))))
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index affa2c767950721f31d8f73f2245cdbba9511b9e..eff9a8128c8dc485fed0767d7e0599f8b2e381c9 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -107,10 +107,10 @@ USA.
 (define record-type-type-tag)
 (add-boot-init!
  (lambda ()
-   (set! record-tag-metatag (make-metatag 'record-tag))
-   (set! record-tag? (tag->predicate record-tag-metatag))
+   (set! record-tag-metatag (make-dispatch-metatag 'record-tag))
+   (set! record-tag? (dispatch-tag->predicate record-tag-metatag))
    (set! %make-record-tag
-        (metatag-constructor record-tag-metatag 'make-record-type))
+        (dispatch-metatag-constructor record-tag-metatag 'make-record-type))
    (let* ((field-names
           '#(dispatch-tag name field-names default-inits tag))
          (type
@@ -126,13 +126,13 @@ USA.
 
 (define (record-tag->type-descriptor tag)
   (guarantee record-tag? tag 'record-tag->type-descriptor)
-  (tag-extra tag 0))
+  (dispatch-tag-extra tag 0))
 
 (define (record-type? object)
   (%tagged-record? record-type-type-tag object))
 
 (define-integrable (%record-type-descriptor record)
-  (tag-extra (%record-tag record) 0))
+  (dispatch-tag-extra (%record-tag record) 0))
 
 (define-integrable (%record-type-dispatch-tag record-type)
   (%record-ref record-type 1))
@@ -147,7 +147,7 @@ USA.
   (%record-ref record-type 4))
 
 (define-integrable (%record-type-predicate record-type)
-  (tag->predicate (%record-type-dispatch-tag record-type)))
+  (dispatch-tag->predicate (%record-type-dispatch-tag record-type)))
 
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index af01c32df44aa326326b2f616892b1e902eab8e1..1be5fcac80d73886f9c71d99a8d61772b1f6ead0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1842,7 +1842,7 @@ USA.
   (files "predicate-metadata")
   (parent (runtime))
   (export ()
-         predicate->tag
+         predicate->dispatch-tag
          predicate-name))
 
 (define-package (runtime predicate-lattice)
@@ -1850,19 +1850,19 @@ USA.
   (parent (runtime))
   (export ()
          any-object?
+         bottom-dispatch-tag
+         dispatch-tag-is-bottom?
+         dispatch-tag-is-top?
+         dispatch-tag<=
+         dispatch-tag=
+         dispatch-tag>=
+         no-object?
          predicate<=
          predicate>=
-         no-object?
-         set-predicate<=!)
+         set-predicate<=!
+         top-dispatch-tag)
   (export (runtime)
-         bottom-tag
-         define-tag<=
-         tag-is-bottom?
-         tag-is-top?
-         tag<=
-         tag=
-         tag>=
-         top-tag))
+         define-dispatch-tag<=))
 
 (define-package (runtime compound-predicate)
   (files "compound-predicate")
@@ -1903,12 +1903,11 @@ USA.
   (files "predicate-tagging")
   (parent (runtime))
   (export ()
+         dispatch-tag-tagger
          object->datum
+         object->dispatch-tag
          object->predicate
-         predicate-tagger)
-  (export (runtime)
-         object->tag
-         tag-tagger))
+         predicate-tagger))
 
 (define-package (runtime predicate-dispatch)
   (files "predicate-dispatch")
@@ -5101,19 +5100,18 @@ USA.
   (files "gentag" "gencache")
   (parent (runtime))
   (export ()
-         make-metatag
-         metatag-constructor
-         metatag?)
-  (export (runtime)
-         set-tag<=!
-         tag->predicate
-         tag-extra
-         tag-metatag
-         tag-name
-         tag?)
+         dispatch-metatag-constructor
+         dispatch-metatag?
+         dispatch-tag->predicate
+         dispatch-tag-extra
+         dispatch-tag-metatag
+         dispatch-tag-name
+         dispatch-tag?
+         make-dispatch-metatag
+         set-dispatch-tag<=!)
   (export (runtime predicate-lattice)
-         add-tag-superset
-         any-tag-superset)
+         add-dispatch-tag-superset
+         any-dispatch-tag-superset)
   (export (runtime predicate-metadata)
          set-predicate-tag!))
 

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 3e429782bb3eb7e910c1bc2f84e9056cf1bf0672..a9d0cdd7acb0c4a0dc839054dee915dcbf6bb79f 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -891,8 +891,8 @@ USA.
   (*unparse-with-brackets 'tagged-object object context
     (lambda (context*)
       (*unparse-object (let ((tag (%tagged-object-tag object)))
-                        (if (tag? tag)
-                            (tag-name tag)
+                        (if (dispatch-tag? tag)
+                            (dispatch-tag-name tag)
                             tag))
                       context*)
       (*unparse-string " " context*)

diff --git a/src/sos/class.scm b/src/sos/class.scm
index f4af37585e3db8cbbe0a743d9e06f28bd3d182ef..d734af1cd02eb3492983410f8f7f8650332847bb 100644 (file)
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -74,13 +74,13 @@ USA.
     class))
 
 (define class-metatag
-  (make-metatag 'class-tag))
+  (make-dispatch-metatag 'class-tag))
 
 (define class-tag?
-  (tag->predicate class-metatag))
+  (dispatch-tag->predicate class-metatag))
 
 (define make-class-tag
-  (metatag-constructor class-metatag 'make-class))
+  (dispatch-metatag-constructor class-metatag 'make-class))
 
 (define (make-trivial-subclass superclass . superclasses)
   (make-class (class-name superclass) (cons superclass superclasses) '()))
@@ -338,7 +338,7 @@ USA.
 (define-primitive-class <entity> <procedure>)
 \f
 (define (object-class object)
-  (dispatch-tag->class (object->tag object)))
+  (dispatch-tag->class (object->dispatch-tag object)))
 
 (define (record-type-class type)
   (dispatch-tag->class (record-type-dispatch-tag type)))
@@ -347,7 +347,7 @@ USA.
   (record-type-class (record-type-descriptor record)))
 
 (define (dispatch-tag->class tag)
-  (cond ((class-tag? tag) (tag-extra tag 0))
+  (cond ((class-tag? tag) (dispatch-tag-extra tag 0))
        ((hash-table/get built-in-class-table tag #f))
        ((record-tag? tag)
         (let ((class
@@ -383,7 +383,7 @@ USA.
 (let ((assign-type
        (lambda (predicate class)
         (hash-table/put! built-in-class-table
-                         (predicate->tag predicate)
+                         (predicate->dispatch-tag predicate)
                          class))))
   (assign-type boolean? <boolean>)
   (assign-type char? <char>)

diff --git a/src/sos/generic.scm b/src/sos/generic.scm
index 60099c1496dae73b6a1faf0fb4129680c3e9b8ea..2d0a10faad86d3a3894f1072f9f6b7a4d8862ec0 100644 (file)
--- a/src/sos/generic.scm
+++ b/src/sos/generic.scm
@@ -37,13 +37,13 @@ USA.
        (generator (if (default-object? generator) #f generator)))
     (if (and name (not (symbol? name)))
        (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE))
-    (if tag (guarantee tag? tag 'MAKE-GENERIC-PROCEDURE))
+    (if tag (guarantee dispatch-tag? tag 'MAKE-GENERIC-PROCEDURE))
     (guarantee procedure-arity? arity 'MAKE-GENERIC-PROCEDURE)
     (if (not (fix:> (procedure-arity-min arity) 0))
        (error:bad-range-argument arity 'MAKE-GENERIC-PROCEDURE))
     (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE)
     (let ((record
-          (make-generic-record (predicate->tag generic-procedure?)
+          (make-generic-record (predicate->dispatch-tag generic-procedure?)
                                (procedure-arity-min arity)
                                (procedure-arity-max arity)
                                generator
@@ -197,7 +197,7 @@ USA.
                          (wna args))
                      (loop (cdr args*)
                            (fix:- n 1)
-                           (cons (object->tag (car args*)) tags)))))))
+                           (cons (object->dispatch-tag (car args*)) tags)))))))
           (wna
            (lambda (args)
              (error:wrong-number-of-arguments generic
@@ -209,7 +209,7 @@ USA.
   (let ((record
         (guarantee-generic-procedure procedure
                                      'GENERIC-PROCEDURE-APPLICABLE?))
-       (tags (map object->tag arguments)))
+       (tags (map object->dispatch-tag arguments)))
     (let ((generator (generic-record/generator record))
          (arity-min (generic-record/arity-min record))
          (arity-max (generic-record/arity-max record))
@@ -226,7 +226,7 @@ USA.
   (lambda (a1)
     (let ((procedure
           (probe-cache-1 (generic-record/cache record)
-                         (object->tag a1))))
+                         (object->dispatch-tag a1))))
       (if procedure
          (procedure a1)
          (compute-method-and-store record (list a1))))))
@@ -235,8 +235,8 @@ USA.
   (lambda (a1 a2)
     (let ((procedure
           (probe-cache-2 (generic-record/cache record)
-                         (object->tag a1)
-                         (object->tag a2))))
+                         (object->dispatch-tag a1)
+                         (object->dispatch-tag a2))))
       (if procedure
          (procedure a1 a2)
          (compute-method-and-store record (list a1 a2))))))
@@ -245,9 +245,9 @@ USA.
   (lambda (a1 a2 a3)
     (let ((procedure
           (probe-cache-3 (generic-record/cache record)
-                         (object->tag a1)
-                         (object->tag a2)
-                         (object->tag a3))))
+                         (object->dispatch-tag a1)
+                         (object->dispatch-tag a2)
+                         (object->dispatch-tag a3))))
       (if procedure
          (procedure a1 a2 a3)
          (compute-method-and-store record (list a1 a2 a3))))))
@@ -256,10 +256,10 @@ USA.
   (lambda (a1 a2 a3 a4)
     (let ((procedure
           (probe-cache-4 (generic-record/cache record)
-                         (object->tag a1)
-                         (object->tag a2)
-                         (object->tag a3)
-                         (object->tag a4))))
+                         (object->dispatch-tag a1)
+                         (object->dispatch-tag a2)
+                         (object->dispatch-tag a3)
+                         (object->dispatch-tag a4))))
       (if procedure
          (procedure a1 a2 a3 a4)
          (compute-method-and-store record (list a1 a2 a3 a4))))))
@@ -271,7 +271,7 @@ USA.
                (p p (cdr p))
                (i (generic-record/arity-min record) (fix:- i 1)))
               ((not (fix:> i 0)))
-            (set-cdr! p (list (object->tag (car args)))))
+            (set-cdr! p (list (object->dispatch-tag (car args)))))
           (cdr p))))
     (let ((procedure
           (let ((generator (generic-record/generator record))

diff --git a/src/sos/tvector.scm b/src/sos/tvector.scm
index e66cdd100c79ea927dff64cf323a4ffb64616e5b..2b38f5be4e69430a7948e4ad52ec825163db0729 100644 (file)
--- a/src/sos/tvector.scm
+++ b/src/sos/tvector.scm
@@ -33,17 +33,17 @@ USA.
 ;;; calls to construct and access tagged vectors.
 
 (define (make-tagged-vector tag length)
-  (guarantee tag? tag 'MAKE-TAGGED-VECTOR)
+  (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR)
   (guarantee-index-integer length 'MAKE-TAGGED-VECTOR)
   (%make-record tag (fix:+ length 1) record-slot-uninitialized))
 
 (define (tagged-vector tag . elements)
-  (guarantee tag? tag 'MAKE-TAGGED-VECTOR)
+  (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR)
   (apply %record tag elements))
 
 (define (tagged-vector? object)
   (and (%record? object)
-       (tag? (%record-ref object 0))))
+       (dispatch-tag? (%record-ref object 0))))
 
 (define (tagged-vector-tag vector)
   (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG)
@@ -51,7 +51,7 @@ USA.
 
 (define (set-tagged-vector-tag! vector tag)
   (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!)
-  (guarantee tag? tag 'SET-TAGGED-VECTOR-TAG!)
+  (guarantee dispatch-tag? tag 'SET-TAGGED-VECTOR-TAG!)
   (%record-set! vector 0 tag))
 
 (define (tagged-vector-length vector)

diff --git a/tests/Clean.sh b/tests/Clean.sh
index 3d290a22d92dfc1b7c5b5c3a7d0fb7f67dafaff1..6d483fd1a5ad1a6494d19234210116c5c1e0a5cf 100755 (executable)
--- a/tests/Clean.sh
+++ b/tests/Clean.sh
@@ -10,6 +10,6 @@ COMMAND=${1}
 
 TOPDIR=../src ../src/etc/Clean.sh ${COMMAND}
 
-for SUBDIR in ffi microcode runtime star-parser xml; do
+for SUBDIR in ffi microcode runtime sos star-parser xml; do
     ( cd $SUBDIR; TOPDIR=../../src ../../src/etc/Clean.sh ${COMMAND} )
 done

diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm
index 873dce8c0e087c85915f14572b61a5fa92f56443..092d056ad5b0dab8aa0e61f365a5d9e1ecd65b3e 100644 (file)
--- a/tests/runtime/test-parametric-predicate.scm
+++ b/tests/runtime/test-parametric-predicate.scm
@@ -238,11 +238,11 @@ USA.
 
 (define (test-predicate-operations predicate name)
   (assert-true (predicate? predicate))
-  (let ((tag (predicate->tag predicate)))
-    (assert-true (tag? tag))
-    (assert-eqv (tag->predicate tag) predicate)
+  (let ((tag (predicate->dispatch-tag predicate)))
+    (assert-true (dispatch-tag? tag))
+    (assert-eqv (dispatch-tag->predicate tag) predicate)
     (assert-equal (predicate-name predicate) name)
-    (assert-equal (tag-name tag) name)))
+    (assert-equal (dispatch-tag-name tag) name)))
 
 (define (test-parametric-predicate-operations predicate template parameters)
   (assert-true (parametric-predicate? predicate))

diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm
index 8754007f42668699cb99ecc8dec46d64317ef4b1..f4b8ef4befb07220b854a1250635fba9af3ea580 100644 (file)
--- a/tests/runtime/test-predicate-metadata.scm
+++ b/tests/runtime/test-predicate-metadata.scm
@@ -32,7 +32,7 @@ USA.
   (lambda ()
     (let ((np (lambda (object) object #f)))
       (assert-false (predicate? np))
-      (assert-type-error (lambda () (predicate->tag np)))
+      (assert-type-error (lambda () (predicate->dispatch-tag np)))
       (assert-type-error (lambda () (predicate-name np))))))
 
 (define-test 'simple-predicate
@@ -43,11 +43,11 @@ USA.
 
 (define (test-predicate-operations predicate name)
   (assert-true (predicate? predicate))
-  (let ((tag (predicate->tag predicate)))
-    (assert-true (tag? tag))
-    (assert-eqv (tag->predicate tag) predicate)
+  (let ((tag (predicate->dispatch-tag predicate)))
+    (assert-true (dispatch-tag? tag))
+    (assert-eqv (dispatch-tag->predicate tag) predicate)
     (assert-equal (predicate-name predicate) name)
-    (assert-equal (tag-name tag) name)))
+    (assert-equal (dispatch-tag-name tag) name)))
 
 (define-test 'simple-predicate-tagging
   (lambda ()

diff --git a/tests/sos/test-genmult.scm b/tests/sos/test-genmult.scm
index 2e3d7f22985f2218924f614b856f4b1e637f909b..8cc823da753367dca3b82012989d7a3c6fdb82fc 100644 (file)
--- a/tests/sos/test-genmult.scm
+++ b/tests/sos/test-genmult.scm
@@ -41,14 +41,14 @@ USA.
     ;; Add some named generators (for easier removal).
     (define (bool-generator p tags)
       p                                 ;ignore
-      (if (equal? tags (list (predicate->tag boolean?)))
+      (if (equal? tags (list (predicate->dispatch-tag boolean?)))
           (lambda (x) (cons 'boolean x))
           #f))
     (add-generic-procedure-generator generic bool-generator)
     (assert-equal (generic #t) '(boolean . #t))
     (define (fixnum-generator p tags)
       p                                 ;ignore
-      (if (equal? tags (list (predicate->tag fix:fixnum?)))
+      (if (equal? tags (list (predicate->dispatch-tag fix:fixnum?)))
           (lambda (x) (cons 'fixnum x))
           #f))
     (add-generic-procedure-generator generic fixnum-generator)