From: Chris Hanson Date: Fri, 12 Jan 2018 07:47:18 +0000 (-0800) Subject: Simplify the story of tagging strategy. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~376 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=32f0609ad7ab6d4a355e17aada1ad93195262e69;p=mit-scheme.git Simplify the story of tagging strategy. It's still not quite right, but it is at least somewhat closer. --- diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index 2c3cb2b10..9ce38d74a 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -30,11 +30,14 @@ USA. (declare (usual-integrations)) (define (make-compound-tag datum-test operator operands) - (make-tag (cons operator (map tag-name operands)) - datum-test - predicate-tagging-strategy:optional - operator - (make-compound-tag-extra operator operands))) + (%make-compound-tag tagging-strategy:optional datum-test operator operands)) + +(define (%make-compound-tag tagging-strategy datum-test operator operands) + (tagging-strategy datum-test + (lambda (predicate tagger) + (make-tag (cons operator (map tag-name operands)) + predicate tagger operator + (make-compound-tag-extra operator operands))))) (define (tag-is-compound? tag) (compound-tag-extra? (tag-extra tag))) diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm index 8721e23cc..2193cac66 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -39,12 +39,11 @@ USA. (define (parametric-predicate-bindings predicate) (parametric-tag-bindings (predicate->tag predicate))) -(define (make-parametric-tag name datum-test tagging-strategy template bindings) - (make-tag name - datum-test - tagging-strategy - 'make-predicate-template - (make-parametric-tag-extra template bindings))) +(define (make-parametric-tag name datum-test template bindings) + (tagging-strategy:optional datum-test + (lambda (predicate tagger) + (make-tag name predicate tagger 'make-predicate-template + (make-parametric-tag-extra template bindings))))) (define (tag-is-parametric? tag) (parametric-tag-extra? (tag-extra tag))) @@ -63,12 +62,11 @@ USA. ;;;; Templates -(define (make-predicate-template name pattern tagging-strategy make-data-test) +(define (make-predicate-template name pattern make-data-test) (guarantee template-pattern? pattern 'make-predicate-template) (letrec* ((instantiator - (make-instantiator name pattern make-data-test tagging-strategy - (lambda () template))) + (make-instantiator name pattern make-data-test (lambda () template))) (template (%make-predicate-template name pattern @@ -94,8 +92,7 @@ USA. (instantiator template-instantiator) (predicate predicate-template-predicate)) -(define (make-instantiator name pattern make-data-test tagging-strategy - get-template) +(define (make-instantiator name pattern make-data-test get-template) (lambda (patterned-tags caller) (letrec ((tag (make-parametric-tag @@ -109,7 +106,6 @@ USA. patterned-tags tag->predicate caller)) - tagging-strategy (get-template) (match-template-pattern pattern patterned-tags @@ -284,7 +280,6 @@ USA. (predicate-template-constructor (make-predicate-template 'is-list-of '((? elt-predicate)) - predicate-tagging-strategy:optional (lambda (elt-predicate) (lambda (object) (list-of-type? object elt-predicate)))))) @@ -292,7 +287,6 @@ USA. (predicate-template-constructor (make-predicate-template 'is-non-empty-list-of '((? elt-predicate)) - predicate-tagging-strategy:optional (lambda (elt-predicate) (lambda (object) (and (pair? object) @@ -302,7 +296,6 @@ USA. (predicate-template-constructor (make-predicate-template 'is-non-empty-list-of '((? car-predicate) (? cdr-predicate)) - predicate-tagging-strategy:optional (lambda (car-predicate cdr-predicate) (lambda (object) (and (pair? object) diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm index c74c9f978..b183ad2d0 100644 --- a/src/runtime/predicate-lattice.scm +++ b/src/runtime/predicate-lattice.scm @@ -92,10 +92,10 @@ USA. (define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag)) (define-deferred the-top-tag - (make-compound-tag any-object? 'conjoin '())) + (%make-compound-tag tagging-strategy:never any-object? 'conjoin '())) (define-deferred the-bottom-tag - (make-compound-tag no-object? 'disjoin '())) + (%make-compound-tag tagging-strategy:never no-object? 'disjoin '())) (define tag<=-cache) (define tag<=-overrides) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index c7312291a..a592d8a85 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -44,12 +44,11 @@ USA. (named-lambda (register-predicate! predicate name . keylist) (guarantee keyword-list? keylist 'register-predicate!) (let ((tag - (make-tag name - predicate - predicate-tagging-strategy:never - 'register-predicate! - (get-keyword-value keylist 'extra) - (get-keyword-value keylist 'description)))) + (tagging-strategy:never predicate + (lambda (predicate tagger) + (make-tag name predicate tagger 'register-predicate! + (get-keyword-value keylist 'extra) + (get-keyword-value keylist 'description)))))) (for-each (lambda (superset) (set-tag<=! tag (predicate->tag superset))) (get-keyword-values keylist '<=)) @@ -61,12 +60,6 @@ USA. (define (predicate-tagger predicate) (tag-tagger (predicate->tag predicate 'predicate-tagger))) -(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))) - (define (predicate-description predicate) (let ((tag (get-predicate-tag predicate #f))) (if tag @@ -102,26 +95,23 @@ USA. (predicate-description predicate)) caller)) -(define (make-tag name datum-test tagging-strategy caller - #!optional extra description) +(define (make-tag name predicate tagger caller #!optional extra description) (guarantee tag-name? name caller) - (guarantee unary-procedure? datum-test caller) + (guarantee unary-procedure? predicate caller) (if (not (default-object? description)) (guarantee string? description caller)) - (tagging-strategy name datum-test - (lambda (predicate tagger untagger) - (let ((tag - (%make-tag name - predicate - tagger - untagger - (if (default-object? extra) #f extra) - (if (default-object? description) #f description) - tagging-strategy - (make-key-weak-eq-hash-table) - (make-key-weak-eq-hash-table)))) - (set-predicate-tag! predicate tag) - tag)))) + (let ((tag + (%make-tag name + predicate + tagger + (if (default-object? extra) #f extra) + (if (default-object? description) + (delay (object->description name)) + (delay description)) + (make-key-weak-eq-hash-table) + (make-key-weak-eq-hash-table)))) + (set-predicate-tag! predicate tag) + tag)) (define (tag-name? object) (or (symbol? object) @@ -133,17 +123,19 @@ USA. (tag-name? elt))) (cdr object))))) +(define (object->description object) + (call-with-output-string + (lambda (port) + (write object port)))) + (define-record-type - (%make-tag name predicate tagger untagger extra description - tagging-strategy subsets supersets) + (%make-tag name predicate tagger extra description subsets supersets) tag? (name tag-name) (predicate tag->predicate) (tagger tag-tagger) - (untagger tag-untagger) (extra tag-extra) (description %tag-description) - (tagging-strategy tag-tagging-strategy) (subsets tag-subsets) (supersets tag-supersets)) @@ -153,13 +145,7 @@ USA. (list (tag-name tag))))) (define (tag-description tag) - (or (%tag-description tag) - (object->description (tag-name tag)))) - -(define (object->description object) - (call-with-output-string - (lambda (port) - (write object port)))) + (force (%tag-description tag))) (define (get-tag-subsets tag) (hash-table-keys (tag-subsets tag))) diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index be76f2e4b..f1d918a70 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -66,45 +66,18 @@ USA. ;;;; Tagging strategies -(define (predicate-tagging-strategy:never name predicate make-tag) - (declare (ignore name)) +(define (tagging-strategy:never predicate make-tag) (define (tagger object #!optional tagger-name) (guarantee predicate object tagger-name) object) - (define (untagger object #!optional untagger-name) - (guarantee predicate object untagger-name) - object) - - (define tag - (make-tag predicate tagger untagger)) - - tag) - -(define (predicate-tagging-strategy:always name datum-test make-tag) - - (define (predicate object) - (and (tagged-object? object) - (tag<= (%tagged-object-tag object) tag) - (datum-test (%tagged-object-datum object)))) - - (define (tagger datum #!optional tagger-name) - (if (not (datum-test datum)) - (error:wrong-type-argument datum (string "datum for " name) - tagger-name)) - (%make-tagged-object tag datum)) - - (define (untagger object #!optional untagger-name) - (guarantee predicate object untagger-name) - (%tagged-object-datum object)) - (define tag - (make-tag predicate tagger untagger)) + (make-tag predicate tagger)) tag) -(define (predicate-tagging-strategy:optional name datum-test make-tag) +(define (tagging-strategy:optional datum-test make-tag) (define (predicate object) (or (tagged-object-test object) @@ -116,20 +89,13 @@ USA. (datum-test (%tagged-object-datum object)))) (define (tagger datum #!optional tagger-name) - (if (not (datum-test datum)) - (error:wrong-type-argument datum (string "datum for " name) - tagger-name)) + (guarantee datum-test datum tagger-name) (if (tag<= (object->tag datum) tag) datum (%make-tagged-object tag datum))) - (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 untagger-name)))) - (define tag - (make-tag predicate tagger untagger)) + (make-tag predicate tagger)) tag) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f473420c4..32fdf1b7b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1817,8 +1817,6 @@ USA. predicate-description predicate-name predicate-tagger - predicate-tagging-strategy - predicate-untagger set-predicate<=!) (export (runtime) event:predicate-metadata @@ -1832,8 +1830,6 @@ USA. tag-extra tag-name tag-tagger - tag-tagging-strategy - tag-untagger tag?)) (define-package (runtime predicate-lattice) @@ -1870,7 +1866,7 @@ USA. compound-tag-operator tag-is-compound?) (export (runtime predicate-lattice) - make-compound-tag)) + %make-compound-tag)) (define-package (runtime parametric-predicate) (files "parametric-predicate") @@ -1904,15 +1900,14 @@ USA. (files "predicate-tagging") (parent (runtime)) (export () - predicate-tagging-strategy:always - predicate-tagging-strategy:never - predicate-tagging-strategy:optional object->datum object->predicate) (export (runtime) object->tag tagged-object-datum - tagged-object-tag)) + tagged-object-tag + tagging-strategy:never + tagging-strategy:optional)) (define-package (runtime predicate-dispatch) (files "predicate-dispatch") diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm index ea4128d2b..576986262 100644 --- a/tests/runtime/test-compound-predicate.scm +++ b/tests/runtime/test-compound-predicate.scm @@ -72,23 +72,12 @@ USA. (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 (tagger datum))) - (assert-true (predicate 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) - (assert-!eq datum object)) - (else - (if (predicate<= (object->predicate datum) predicate) - (assert-eq datum object) - (assert-!eq datum object)))))) - data) + (let ((tagger (predicate-tagger predicate))) + (for-each (lambda (datum) + (let ((object (tagger datum))) + (assert-true (predicate object)) + (assert-eq datum (object->datum object)))) + data) (for-each (lambda (non-datum) (assert-type-error (lambda () (tagger non-datum)))) non-data))) \ No newline at end of file diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm index 20f368535..542164889 100644 --- a/tests/runtime/test-parametric-predicate.scm +++ b/tests/runtime/test-parametric-predicate.scm @@ -29,9 +29,7 @@ USA. (declare (usual-integrations)) (define (make-template name pattern) - (make-predicate-template name pattern - predicate-tagging-strategy:always - (lambda args args any-object?))) + (make-predicate-template name pattern (lambda args args any-object?))) (define-test 'parametric-predicate-one-parameter (lambda () diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm index 648370ae0..6bc23219a 100644 --- a/tests/runtime/test-predicate-metadata.scm +++ b/tests/runtime/test-predicate-metadata.scm @@ -58,23 +58,12 @@ USA. (test-tagging string? '("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 (tagger datum))) - (assert-true (predicate 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) - (assert-!eq datum object)) - (else - (if (predicate<= (object->predicate datum) predicate) - (assert-eq datum object) - (assert-!eq datum object)))))) - data) + (let ((tagger (predicate-tagger predicate))) + (for-each (lambda (datum) + (let ((object (tagger datum))) + (assert-true (predicate object)) + (assert-eq datum (object->datum object)))) + data) (for-each (lambda (non-datum) (assert-type-error (lambda () (tagger non-datum)))) non-data))) \ No newline at end of file