Refactor tag implementation to use "metatags".

This allows predicate dispatch to differentiate between different kinds of
tags.  Otherwise all tags look the same, even if they are functionally
different.

Of course now it's not possible to differentiate between metatags, because they
all of the same tag; but that shouldn't be a problem.

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 77fa568fe619944cd8713905c07415022df1da34..6841f6e45888141281482cdc872e37f5ccec4dc7 100644 (file)
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -29,14 +29,21 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-compound-tag predicate operator operands)
-  (make-tag (cons operator (map tag-name operands))
-           predicate
-           operator
-           (make-compound-tag-extra operator operands)))
+(define compound-tag-metatag)
+(define compound-tag?)
+(define %make-compound-tag)
+(defer-boot-action 'make-metatag
+  (lambda ()
+    (set! compound-tag-metatag (make-metatag 'compound-tag))
+    (set! compound-tag? (tag->predicate compound-tag-metatag))
+    (set! %make-compound-tag
+         (metatag-constructor compound-tag-metatag 'make-compound-tag))
+    unspecific))
 
-(define (tag-is-compound? tag)
-  (compound-tag-extra? (tag-extra tag)))
+(define (make-compound-tag predicate operator operands)
+  (%make-compound-tag (cons operator (map tag-name operands))
+                     predicate
+                     (make-compound-tag-extra operator operands)))
 
 (define (compound-tag-operator tag)
   (compound-tag-extra-operator (tag-extra tag)))
@@ -51,11 +58,11 @@ USA.
   (operands compound-tag-extra-operands))
 
 (define (tag-is-disjoin? object)
-  (and (tag-is-compound? object)
+  (and (compound-tag? object)
        (eq? 'disjoin (compound-tag-operator object))))
 
 (define (tag-is-conjoin? object)
-  (and (tag-is-compound? object)
+  (and (compound-tag? object)
        (eq? 'conjoin (compound-tag-operator object))))
 
 (add-boot-init!
@@ -75,7 +82,7 @@ USA.
 \f
 (define (compound-predicate? object)
   (and (predicate? object)
-       (tag-is-compound? (predicate->tag object))))
+       (compound-tag? (predicate->tag object))))
 
 (add-boot-init!
  (lambda ()
@@ -119,16 +126,14 @@ USA.
        (map predicate->tag operands)))
       datum-test))
 \f
-(define compound-operator?)
 (define compound-operator-builder)
 (define define-compound-operator)
 (add-boot-init!
  (lambda ()
-   (let ((table (make-hashed-metadata-table)))
-     (set! compound-operator? (table 'has?))
+   (let ((table (make-alist-metadata-table)))
      (set! compound-operator-builder (table 'get))
-     (set! define-compound-operator (table 'put!)))
-   (register-predicate! compound-operator? 'compound-predicate '<= symbol?)))
+     (set! define-compound-operator (table 'put!))
+     unspecific)))
 
 (add-boot-init!
  (lambda ()
@@ -145,7 +150,7 @@ USA.
                (delete-duplicates
                 (append-map
                  (lambda (tag)
-                   (if (and (tag-is-compound? tag)
+                   (if (and (compound-tag? tag)
                             (eq? operator
                                  (compound-tag-operator tag)))
                        (compound-tag-operands tag)

diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index cf4955220a9294b49e27dbd91dce6f7833cd0f1b..87ce1eeab8e310dba20e7a9098e0b7be70841ac0 100644 (file)
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -29,22 +29,21 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (parametric-predicate? object)
-  (and (predicate? object)
-       (tag-is-parametric? (predicate->tag object))))
-
-(define (parametric-predicate-template predicate)
-  (parametric-tag-template (predicate->tag predicate)))
-
-(define (parametric-predicate-bindings predicate)
-  (parametric-tag-bindings (predicate->tag predicate)))
+(define parametric-tag-metatag)
+(define parametric-tag?)
+(define %make-parametric-tag)
+(defer-boot-action 'make-metatag
+  (lambda ()
+    (set! parametric-tag-metatag (make-metatag 'parametric-tag))
+    (set! parametric-tag? (tag->predicate parametric-tag-metatag))
+    (set! %make-parametric-tag
+         (metatag-constructor parametric-tag-metatag 'make-parametric-tag))
+    unspecific))
 
 (define (make-parametric-tag name predicate template bindings)
-  (make-tag name predicate 'make-predicate-template
-           (make-parametric-tag-extra template bindings)))
-
-(define (tag-is-parametric? tag)
-  (parametric-tag-extra? (tag-extra tag)))
+  (%make-parametric-tag name
+                       predicate
+                       (make-parametric-tag-extra template bindings)))
 
 (define (parametric-tag-template tag)
   (parametric-tag-extra-template (tag-extra tag)))
@@ -57,6 +56,16 @@ USA.
     parametric-tag-extra?
   (template parametric-tag-extra-template)
   (bindings parametric-tag-extra-bindings))
+
+(define (parametric-predicate? object)
+  (and (predicate? object)
+       (parametric-tag? (predicate->tag object))))
+
+(define (parametric-predicate-template predicate)
+  (parametric-tag-template (predicate->tag predicate)))
+
+(define (parametric-predicate-bindings predicate)
+  (parametric-tag-bindings (predicate->tag predicate)))
 \f
 ;;;; Templates
 
@@ -251,7 +260,7 @@ USA.
 
 (add-boot-init!
  (lambda ()
-   (define-tag<= tag-is-parametric? tag-is-parametric?
+   (define-tag<= parametric-tag? parametric-tag?
      (lambda (tag1 tag2)
        (and (eqv? (parametric-tag-template tag1)
                  (parametric-tag-template tag2))

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index d85f9213913c2448bb120abb5424205e2b824e74..9d1df8520c79572f6e1ee233c07bd21e3ca0c70d 100644 (file)
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -36,6 +36,10 @@ USA.
 (define (predicate>= predicate1 predicate2)
   (predicate<= predicate2 predicate1))
 
+(define (set-predicate<=! predicate superset)
+  (set-tag<=! (predicate->tag predicate 'set-predicate<=!)
+              (predicate->tag superset 'set-predicate<=!)))
+
 (define (tag= tag1 tag2)
   (guarantee tag? tag1 'tag=)
   (guarantee tag? tag2 'tag=)
@@ -49,6 +53,11 @@ USA.
 (define (tag>= tag1 tag2)
   (tag<= tag2 tag1))
 
+(define (set-tag<=! tag superset)
+  (defer-boot-action 'predicate-relations
+    (lambda ()
+      (set-tag<=! tag superset))))
+
 (define (cached-tag<= tag1 tag2)
   (hash-table-intern! tag<=-cache
                      (cons tag1 tag2)
@@ -105,12 +114,11 @@ USA.
    ;; weak compound keys.
    (set! tag<=-cache (make-equal-hash-table))
    (set! tag<=-overrides '())
-   (add-event-receiver! event:predicate-metadata metadata-event!)))
-
-(define (metadata-event! operator tag . rest)
-  (if (and (eq? operator 'set-tag<=!)
-           (pair? rest))
-      (let ((superset (car rest)))
-        (if (tag>= tag superset)
-            (error "Not allowed to create a superset loop:" tag superset))))
-  (hash-table-clear! tag<=-cache))
\ No newline at end of file
+   (set! set-tag<=!
+        (named-lambda (set-tag<=! tag superset)
+          (if (not (add-tag-superset tag superset))
+              (error "Tag already has this superset:" tag superset))
+          (if (tag>= tag superset)
+              (error "Not allowed to create a superset loop:" tag superset))
+          (hash-table-clear! 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 215e51e4d1762e0c60266873019eea626277c0bf..862c8e6b1df6a14f9ba90fc7ad9f7bdb340e5894 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -37,45 +37,40 @@ USA.
      (set! predicate? (table 'has?))
      (set! get-predicate-tag (table 'get))
      (set! set-predicate-tag! (table 'put!))
-     (set! register-predicate! register-predicate!/after-boot)
      unspecific)))
 
-(define register-predicate!/after-boot
-  (named-lambda (register-predicate! predicate name . keylist)
-    (guarantee keyword-list? keylist 'register-predicate!)
-    (let ((tag
-          (make-tag name predicate 'register-predicate!
-                    (get-keyword-value keylist 'extra))))
-      (for-each (lambda (superset)
-                 (set-tag<=! tag (predicate->tag superset)))
-               (get-keyword-values keylist '<=))
-      tag)))
-
 (define (predicate-name predicate)
   (tag-name (predicate->tag predicate 'predicate-name)))
 
-(define (set-predicate<=! predicate superset)
-  (set-tag<=! (predicate->tag predicate 'set-predicate<=!)
-              (predicate->tag superset 'set-predicate<=!)))
-
 (define (predicate->tag predicate #!optional caller)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
         (error:not-a predicate? predicate caller))
     tag))
-\f
-(define (make-tag name predicate caller #!optional extra)
-  (guarantee tag-name? name caller)
-  (guarantee unary-procedure? predicate caller)
-  (if (predicate? predicate)
-      (error "Can't assign multiple tags to the same predicate:" predicate))
-  (let ((tag
-        (%make-tag name
-                   predicate
-                   (if (default-object? extra) #f extra)
-                   (%make-weak-set))))
-    (set-predicate-tag! predicate tag)
-    tag))
+
+(define (make-metatag name)
+  (guarantee tag-name? name 'make-metatag)
+  (letrec*
+      ((predicate
+       (lambda (object)
+         (and (%record? object)
+              (eq? metatag (%record-ref object 0)))))
+       (metatag (%make-tag metatag-tag name predicate #f)))
+    (set-tag<=! metatag metatag-tag)
+    metatag))
+
+(define (metatag-constructor metatag #!optional caller)
+  (guarantee metatag? metatag 'metatag-constructor)
+  (lambda (name predicate extra)
+    (guarantee tag-name? name caller)
+    (guarantee unary-procedure? predicate caller)
+    (if (predicate? predicate)
+       (error "Can't assign multiple tags to the same predicate:" predicate))
+    (%make-tag metatag name predicate extra)))
+
+(define (metatag? object)
+  (and (%record? object)
+       (eq? metatag-tag (%record-ref object 0))))
 
 (define (tag-name? object)
   (or (symbol? object)
@@ -86,41 +81,93 @@ USA.
                    (or (object-non-pointer? elt)
                        (tag-name? elt)))
                  (cdr object)))))
+\f
+(define metatag-tag)
+(define simple-tag-metatag)
+(define %make-simple-tag)
+(add-boot-init!
+ (lambda ()
+   (set! metatag-tag (%make-tag #f 'metatag metatag? #f))
+   (%record-set! metatag-tag 0 metatag-tag)
+   (set! simple-tag-metatag
+        (make-metatag 'simple-tag))
+   (set! %make-simple-tag
+        (metatag-constructor simple-tag-metatag 'register-predicate!))
+   (run-deferred-boot-actions 'make-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)))
+                      (get-keyword-values keylist '<=))
+            tag)))
+   unspecific))
 
-(define-record-type <tag>
-    (%make-tag name predicate extra supersets)
-    tag?
-  (name tag-name)
-  (predicate tag->predicate)
-  (extra tag-extra)
-  (supersets %tag-supersets))
+(defer-boot-action 'predicate-relations
+  (lambda ()
+    (set-predicate<=! metatag? tag?)))
+
+(define (%make-tag metatag name predicate extra)
+  (let ((tag (%record metatag name predicate extra (%make-weak-set))))
+    (set-predicate-tag! predicate tag)
+    tag))
+
+(define (tag? object)
+  (and (%record? object)
+       (metatag? (%record-ref object 0))))
 
 (define-unparser-method tag?
-  (simple-unparser-method 'tag
-    (lambda (tag)
-      (list (tag-name tag)))))
+  (simple-unparser-method
+   (lambda (tag)
+     (if (metatag? tag) 'metatag 'tag))
+   (lambda (tag)
+     (list (tag-name tag)))))
+
+(define-integrable (%tag-name tag)
+  (%record-ref tag 1))
+
+(define-integrable (%tag->predicate tag)
+  (%record-ref tag 2))
+
+(define-integrable (%tag-extra tag)
+  (%record-ref tag 3))
 
-(define (tag-supersets tag)
-  (%weak-set->list (%tag-supersets tag)))
+(define-integrable (%tag-supersets tag)
+  (%record-ref tag 4))
 
-(define (any-tag-superset predicate tag)
-  (%weak-set-any predicate (%tag-supersets tag)))
+(define (tag-metatag tag)
+  (guarantee tag? tag 'tag-metatag)
+  (%record-ref tag 0))
 
-(define (set-tag<=! tag superset)
-  (guarantee tag? superset 'set-tag<=!)
-  (if (%add-to-weak-set superset (%tag-supersets tag))
-      (event-distributor/invoke! event:predicate-metadata
-                                'set-tag<=! tag superset)
-      (error "Tag already has this superset:" tag superset)))
+(define (tag-name tag)
+  (guarantee tag? tag 'tag-name)
+  (%record-ref tag 1))
 
-(define event:predicate-metadata (make-event-distributor))
+(define (tag->predicate tag)
+  (guarantee tag? tag 'tag->predicate)
+  (%tag->predicate tag))
+
+(define (tag-extra tag)
+  (guarantee tag? tag 'tag-extra)
+  (%tag-extra tag))
+
+(define (any-tag-superset procedure tag)
+  (guarantee tag? tag 'any-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)
+  (%add-to-weak-set superset (%tag-supersets tag)))
 \f
 (add-boot-init!
  (lambda ()
+   (register-predicate! %record? '%record)
+   (register-predicate! %tagged-object? 'tagged-object)
    (register-predicate! predicate? 'predicate)
    (register-predicate! tag-name? 'tag-name)
-   (register-predicate! %record? '%record)
-   (register-predicate! %tagged-object? 'tagged-object)))
+   (register-predicate! tag? 'tag '<= %record?)))
 
 ;;; Registration of standard predicates
 (add-boot-init!

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4d6755998d2f71842daffcb936ed01661fdac741..aca1ac29a8c3f72c744307300374ccf5f469f312 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1842,19 +1842,20 @@ USA.
   (files "predicate-metadata")
   (parent (runtime))
   (export ()
-         predicate-name
-         set-predicate<=!)
+         make-metatag
+         metatag-constructor
+         metatag?
+         predicate-name)
   (export (runtime)
-         any-tag-superset
-         event:predicate-metadata
-         make-tag
          predicate->tag
-         set-tag<=!
          tag->predicate
          tag-extra
          tag-name
-         tag-supersets
-         tag?))
+         tag-metatag
+         tag?)
+  (export (runtime predicate-lattice)
+         any-tag-superset
+         add-tag-superset))
 
 (define-package (runtime predicate-lattice)
   (files "predicate-lattice")
@@ -1863,10 +1864,12 @@ USA.
          any-object?
          predicate<=
          predicate>=
-         no-object?)
+         no-object?
+         set-predicate<=!)
   (export (runtime)
          bottom-tag
          define-tag<=
+         set-tag<=!
          tag-is-bottom?
          tag-is-top?
          tag<=
@@ -1878,17 +1881,10 @@ USA.
   (files "compound-predicate")
   (parent (runtime))
   (export ()
-         compound-predicate-operands
-         compound-predicate-operator
-         compound-predicate?
          conjoin
          conjoin*
          disjoin
          disjoin*)
-  (export (runtime)
-         compound-tag-operands
-         compound-tag-operator
-         tag-is-compound?)
   (export (runtime predicate-lattice)
          make-compound-tag))
 
@@ -1914,11 +1910,7 @@ USA.
           predicate-template-parameter-names
           predicate-template-pattern
           predicate-template-predicate
-          predicate-template?)
-  (export (runtime)
-         parametric-tag-bindings
-         parametric-tag-template
-         tag-is-parametric?))
+          predicate-template?))
 
 (define-package (runtime predicate-tagging)
   (files "predicate-tagging")

diff --git a/tests/check.scm b/tests/check.scm
index 8a7dc81c230f0a25d97f86e95980f9f8c54db705..87650c323ffd4305f4a37970e62363609da7ce29 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -53,7 +53,7 @@ USA.
     "runtime/test-bytevector"
     ("runtime/test-char" (runtime))
     ("runtime/test-char-set" (runtime character-set))
-    ("runtime/test-compound-predicate" (runtime))
+    ("runtime/test-compound-predicate" (runtime compound-predicate))
     "runtime/test-division"
     "runtime/test-dragon4"
     "runtime/test-dynamic-env"
@@ -66,7 +66,7 @@ USA.
     "runtime/test-md5"
     "runtime/test-mime-codec"
     ("runtime/test-parametric-predicate" (runtime parametric-predicate))
-    ("runtime/test-predicate-dispatch" (runtime))
+    ("runtime/test-predicate-dispatch" (runtime predicate-dispatch))
     ("runtime/test-predicate-lattice" (runtime))
     ("runtime/test-predicate-metadata" (runtime))
     "runtime/test-process"

diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm
index 09de85a0d6e9fd7aa241b706cad7e82e60806c2c..873dce8c0e087c85915f14572b61a5fa92f56443 100644 (file)
--- a/tests/runtime/test-parametric-predicate.scm
+++ b/tests/runtime/test-parametric-predicate.scm
@@ -245,7 +245,6 @@ USA.
     (assert-equal (tag-name tag) name)))
 
 (define (test-parametric-predicate-operations predicate template parameters)
-  (assert-false (compound-predicate? predicate))
   (assert-true (parametric-predicate? predicate))
   (assert-eqv (parametric-predicate-template predicate) template)
   (assert-lset= eq?

diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm
index 6bc23219aeab82c960de683ce9ae843fcd170f63..8754007f42668699cb99ecc8dec46d64317ef4b1 100644 (file)
--- a/tests/runtime/test-predicate-metadata.scm
+++ b/tests/runtime/test-predicate-metadata.scm
@@ -33,8 +33,7 @@ USA.
     (let ((np (lambda (object) object #f)))
       (assert-false (predicate? np))
       (assert-type-error (lambda () (predicate->tag np)))
-      (assert-type-error (lambda () (predicate-name np)))
-      (assert-true (string? (predicate-description np))))))
+      (assert-type-error (lambda () (predicate-name np))))))
 
 (define-test 'simple-predicate
   (lambda ()
@@ -48,8 +47,7 @@ USA.
     (assert-true (tag? tag))
     (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))))
+    (assert-equal (tag-name tag) name)))
 
 (define-test 'simple-predicate-tagging
   (lambda ()