From 13a780d0926d5bee5493dcfbd2192b41b8c50864 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 15 Jan 2018 22:40:57 -0800 Subject: [PATCH] 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. --- src/runtime/compound-predicate.scm | 37 ++--- src/runtime/parametric-predicate.scm | 39 +++-- src/runtime/predicate-lattice.scm | 26 ++-- src/runtime/predicate-metadata.scm | 151 +++++++++++++------- src/runtime/runtime.pkg | 34 ++--- tests/check.scm | 4 +- tests/runtime/test-parametric-predicate.scm | 1 - tests/runtime/test-predicate-metadata.scm | 6 +- 8 files changed, 178 insertions(+), 120 deletions(-) diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index 77fa568fe..6841f6e45 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -29,14 +29,21 @@ USA. (declare (usual-integrations)) -(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. (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)) -(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 cf4955220..87ce1eeab 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -29,22 +29,21 @@ USA. (declare (usual-integrations)) -(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))) ;;;; 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 d85f92139..9d1df8520 100644 --- 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 215e51e4d..862c8e6b1 100644 --- 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)) - -(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))))) + +(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 - (%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))) (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 4d6755998..aca1ac29a 100644 --- 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 8a7dc81c2..87650c323 100644 --- 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 09de85a0d..873dce8c0 100644 --- 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 6bc23219a..8754007f4 100644 --- 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 () -- 2.25.1