From 051c813cf7519a2105d6e88ef17bd6eed65abb01 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 13 Jan 2018 13:30:07 -0800 Subject: [PATCH] Eliminate tagging strategies altogether. The structure of the tagged data belongs outside of the core code. --- src/runtime/compound-predicate.scm | 14 ++++------- src/runtime/parametric-predicate.scm | 8 +++---- src/runtime/predicate-lattice.scm | 4 ++-- src/runtime/predicate-metadata.scm | 20 ++++++---------- src/runtime/predicate-tagging.scm | 36 +++++++--------------------- src/runtime/runtime.pkg | 10 ++++---- 6 files changed, 30 insertions(+), 62 deletions(-) diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index 9ce38d74a..77fa568fe 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -29,15 +29,11 @@ USA. (declare (usual-integrations)) -(define (make-compound-tag datum-test 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 (make-compound-tag predicate operator operands) + (make-tag (cons operator (map tag-name operands)) + predicate + 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 2193cac66..cf4955220 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -39,11 +39,9 @@ USA. (define (parametric-predicate-bindings predicate) (parametric-tag-bindings (predicate->tag predicate))) -(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 (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))) diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm index b183ad2d0..c74c9f978 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 tagging-strategy:never any-object? 'conjoin '())) + (make-compound-tag any-object? 'conjoin '())) (define-deferred the-bottom-tag - (%make-compound-tag tagging-strategy:never no-object? 'disjoin '())) + (make-compound-tag no-object? 'disjoin '())) (define tag<=-cache) (define tag<=-overrides) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 93b5de164..804e0570b 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -44,11 +44,9 @@ USA. (named-lambda (register-predicate! predicate name . keylist) (guarantee keyword-list? keylist 'register-predicate!) (let ((tag - (tagging-strategy:never predicate - (lambda (predicate tagger) - (make-tag name predicate tagger 'register-predicate! - (get-keyword-value keylist 'extra) - (get-keyword-value keylist 'description)))))) + (make-tag name predicate '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 '<=)) @@ -57,9 +55,6 @@ USA. (define (predicate-name predicate) (tag-name (predicate->tag predicate 'predicate-name))) -(define (predicate-tagger predicate) - (tag-tagger (predicate->tag predicate 'predicate-tagger))) - (define (predicate-description predicate) (let ((tag (get-predicate-tag predicate #f))) (if tag @@ -95,15 +90,16 @@ USA. (predicate-description predicate)) caller)) -(define (make-tag name predicate tagger caller #!optional extra description) +(define (make-tag name predicate caller #!optional extra description) (guarantee tag-name? name caller) (guarantee unary-procedure? predicate caller) + (if (predicate? predicate) + (error "Can't assign multiple tags to the same predicate:" predicate)) (if (not (default-object? description)) (guarantee string? description caller)) (let ((tag (%make-tag name predicate - tagger (if (default-object? extra) #f extra) (if (default-object? description) (delay (object->description name)) @@ -129,11 +125,10 @@ USA. (write object port)))) (define-record-type - (%make-tag name predicate tagger extra description subsets supersets) + (%make-tag name predicate extra description subsets supersets) tag? (name tag-name) (predicate tag->predicate) - (tagger tag-tagger) (extra tag-extra) (description %tag-description) (subsets tag-subsets) @@ -288,7 +283,6 @@ USA. (register-predicate! stack-address? 'stack-address) (register-predicate! thread-mutex? 'thread-mutex) (register-predicate! undefined-value? 'undefined-value) - (register-predicate! unicode-char? 'unicode-char '<= bitless-char?) (register-predicate! unicode-code-point? 'unicode-code-point '<= index-fixnum?) (register-predicate! unicode-scalar-value? 'unicode-scalar-value diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index fd8cce3c3..129e920c5 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -43,38 +43,20 @@ USA. (%tagged-object-datum object) object)) -;;;; Tagging strategies +(define (predicate-tagger predicate) + (%tag-tagger (predicate->tag predicate 'predicate-tagger) predicate)) -(define (tagging-strategy:never predicate make-tag) +(define (tag-tagger tag) + (%tag-tagger tag (tag->predicate tag))) - (define (tagger object #!optional tagger-name) - (guarantee predicate object tagger-name) - object) - - (define tag - (make-tag predicate tagger)) - - tag) - -(define (tagging-strategy:optional datum-test make-tag) - - (define (predicate object) - (if (%tagged-object? object) - (tag<= (%tagged-object-tag object) tag) - (datum-test object))) - - (define (tagger datum #!optional tagger-name) +(define (%tag-tagger tag predicate) + (lambda (datum #!optional tagger-name) (if (tag<= (object->tag datum) tag) - datum + datum (begin - (guarantee datum-test datum tagger-name) - (%make-tagged-object tag datum)))) - - (define tag - (make-tag predicate tagger)) + (guarantee predicate datum tagger-name) + (%make-tagged-object tag datum))))) - tag) - (define primitive-tags) (define primitive-tag-methods) (add-boot-init! diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 2111df025..767d115a8 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1825,7 +1825,6 @@ USA. guarantee-list-of predicate-description predicate-name - predicate-tagger set-predicate<=!) (export (runtime) event:predicate-metadata @@ -1838,7 +1837,6 @@ USA. tag-description tag-extra tag-name - tag-tagger tag?)) (define-package (runtime predicate-lattice) @@ -1875,7 +1873,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") @@ -1910,11 +1908,11 @@ USA. (parent (runtime)) (export () object->datum - object->predicate) + object->predicate + predicate-tagger) (export (runtime) object->tag - tagging-strategy:never - tagging-strategy:optional)) + tag-tagger)) (define-package (runtime predicate-dispatch) (files "predicate-dispatch") -- 2.25.1