From: Chris Hanson Date: Tue, 17 Jan 2017 22:29:34 +0000 (-0800) Subject: Refactor predicate machinery to use tagging strategies. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~117 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ce7dffed9733bf3b2e14d19984d5c102c0dae090;p=mit-scheme.git Refactor predicate machinery to use tagging strategies. Also: * Rename predicate-template-{instantiator,constructor}. * Add optional caller args to predicate-template-constructor and predicate-template-accessor. --- diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index d104b6626..a5edc25bb 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -29,9 +29,11 @@ USA. (declare (usual-integrations)) -(define (make-compound-tag predicate operator operands) - (make-tag predicate - (cons operator (map tag-name operands)) +(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))) (define (compound-tag? object) diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm index 3cb939f2f..e2e28d61c 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -29,9 +29,21 @@ USA. (declare (usual-integrations)) -(define (make-parametric-tag predicate name template bindings) - (make-tag predicate - name +(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 (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 (tag-is-parametric? tag) @@ -49,100 +61,91 @@ USA. (template parametric-tag-extra-template) (bindings parametric-tag-extra-bindings)) -(define (parametric-predicate? object) - (and (predicate? object) - (tag-is-parametric? (predicate->tag object)))) - -(define (parametric-predicate-template predicate) - (parametric-tag-template (predicate->tag predicate))) +;;;; Templates -(define (parametric-predicate-bindings predicate) - (parametric-tag-bindings (predicate->tag predicate))) +(define (make-predicate-template name pattern tagging-strategy make-data-test) + (guarantee template-pattern? pattern 'make-predicate-template) + (letrec* + ((instantiator + (make-instantiator name pattern make-data-test tagging-strategy + (lambda () template))) + (template + (%make-predicate-template name + pattern + (all-args-memoizer equal? + (lambda patterned-tags + patterned-tags) + instantiator) + (lambda (object) + (and (parametric-predicate? object) + (eqv? template + (parametric-predicate-template + object))))))) + (register-predicate! (predicate-template-predicate template) + (symbol name '-predicate) + '<= parametric-predicate?) + template)) (define-record-type (%make-predicate-template name pattern instantiator predicate) predicate-template? (name predicate-template-name) (pattern predicate-template-pattern) - (instantiator predicate-template-instantiator) + (instantiator template-instantiator) (predicate predicate-template-predicate)) -(define (make-predicate-template name pattern) - (guarantee template-pattern? pattern 'make-predicate-template) - (letrec* - ((instantiator - (make-predicate-template-instantiator - (lambda () template))) - (predicate - (lambda (object) - (and (parametric-predicate? object) - (eqv? (parametric-predicate-template object) - template)))) - (template - (%make-predicate-template - name - pattern - (all-args-memoizer equal? - (lambda parameters parameters) - instantiator) - predicate))) - (register-predicate! predicate (symbol name '-predicate) - '<= parametric-predicate?) - template)) +(define (make-instantiator name pattern make-data-test tagging-strategy + get-template) + (lambda (patterned-tags caller) + (letrec ((tag + (make-parametric-tag + (cons name + (map-template-pattern pattern + patterned-tags + tag-name + caller)) + (make-data-test (lambda () tag)) + tagging-strategy + (get-template) + (match-template-pattern pattern + patterned-tags + tag? + caller)))) + tag))) -(define (make-predicate-template-instantiator get-template) - (lambda parameters - (let ((template (get-template))) - (let ((name (predicate-template-name template)) - (pattern (predicate-template-pattern template))) - (let ((parameters - (map-template-pattern pattern - parameters - predicate->tag))) - (letrec* ((predicate - (lambda (object) - (and (predicate? object) - (tag<= (predicate->tag object) tag)))) - (tag - (make-parametric-tag - predicate - (cons name - (map-template-pattern pattern - parameters - tag-name)) - template - (match-template-pattern pattern - parameters - tag?)))) - predicate)))))) +(define (predicate-template-constructor template #!optional caller) + (let ((instantiator (template-instantiator template)) + (pattern (predicate-template-pattern template))) + (lambda patterned-predicates + (tag->predicate + (instantiator (map-template-pattern pattern + patterned-predicates + predicate->tag + caller) + caller))))) (define (predicate-template-parameter-names template) (template-pattern->names (predicate-template-pattern template))) -(define (predicate-template-accessor name template) +(define (predicate-template-accessor name template #!optional caller) (let ((elt (find (lambda (elt) - (eq? (template-pattern-element-name elt) name)) + (eq? name (template-pattern-element-name elt))) (predicate-template-pattern template)))) (if (not elt) - (error "Unknown parameter name:" name template)) + (error:bad-range-argument name 'predicate-template-accessor)) (let ((valid? (predicate-template-predicate template)) (convert (if (template-pattern-element-single-valued? elt) tag->predicate - tags->predicates))) + (lambda (tags) (map tag->predicate tags))))) (lambda (predicate) - (if (not (valid? predicate)) - (error "Not a valid predicate:" predicate)) + (guarantee valid? predicate caller) (convert (parameter-binding-value (find (lambda (binding) (eqv? name (parameter-binding-name binding))) - (parametric-tag-bindings - (predicate->tag predicate))))))))) - -(define (tags->predicates tags) - (map tag->predicate tags)) + (parametric-tag-bindings (predicate->tag predicate))))))))) ;;;; Template patterns @@ -188,11 +191,11 @@ USA. (define (template-pattern->names pattern) (map template-pattern-element-name pattern)) - -(define (match-template-pattern pattern values value-predicate) - (guarantee list? values 'match-template-pattern) + +(define (match-template-pattern pattern values value-predicate caller) + (guarantee list? values caller) (if (not (= (length values) (length pattern))) - (error "Wrong number of values:" values pattern)) + (error:bad-range-argument values caller)) (map (lambda (element value) (case (template-pattern-element-operator element) ((?) @@ -207,12 +210,20 @@ USA. (list? (cdr value)) (every value-predicate value))) (error "Mismatch:" element value))) - (else - (error:not-a template-pattern? pattern 'match-template-pattern))) + (else (error:not-a template-pattern? pattern caller))) (make-parameter-binding element value)) pattern values)) +(define (map-template-pattern pattern object value-procedure caller) + (map (lambda (element o) + (case (template-pattern-element-operator element) + ((?) (value-procedure o)) + ((?* ?+) (map value-procedure o)) + (else (error:not-a template-pattern? pattern caller)))) + pattern + object)) + (define-record-type (make-parameter-binding element value) parameter-binding? @@ -233,16 +244,6 @@ USA. (list (parameter-binding-value binding)) (parameter-binding-value binding))) -(define (map-template-pattern pattern object value-procedure) - (map (lambda (element o) - (case (template-pattern-element-operator element) - ((?) (value-procedure o)) - ((?* ?+) (map value-procedure o)) - (else - (error:not-a template-pattern? pattern 'map-template-pattern)))) - pattern - object)) - (add-boot-init! (lambda () (register-predicate! parametric-predicate? 'parametric-predicate diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index e338fc4a1..5ee5fad11 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -45,8 +45,9 @@ USA. (define (register-predicate! predicate name . keylist) (guarantee keyword-list? keylist 'register-predicate!) (let ((tag - (make-tag predicate - name + (make-tag name + predicate + predicate-tagging-strategy:never (get-keyword-value keylist 'extra) (get-keyword-value keylist 'description)))) (for-each (lambda (superset) @@ -100,22 +101,25 @@ USA. (and tag (not (tag-extra tag))))) -(define (make-tag predicate name #!optional extra description) - (guarantee unary-procedure? predicate 'make-tag) - (guarantee tag-name? name 'make-tag) - (if (predicate? predicate) - (error "Predicate is already registered:" predicate)) - (let ((tag - (%make-tag predicate - name - (if (default-object? description) - #f - (guarantee string? description 'make-tag)) - (if (default-object? extra) #f extra) - (make-strong-eq-hash-table) - (make-strong-eq-hash-table)))) - (set-predicate-tag! predicate tag) - tag)) +(define (make-tag name datum-test tagging-strategy caller + #!optional extra description) + (guarantee tag-name? name caller) + (guarantee unary-procedure? datum-test caller) + (if (not (default-object? description)) + (guarantee string? description caller)) + (tagging-strategy name datum-test + (lambda (predicate constructor accessor) + (let ((tag + (%make-tag name + predicate + constructor + accessor + (if (default-object? extra) #f extra) + (if (default-object? description) #f description) + (make-strong-eq-hash-table) + (make-strong-eq-hash-table)))) + (set-predicate-tag! predicate tag) + tag)))) (define (tag-name? object) (or (symbol? object) @@ -123,12 +127,15 @@ USA. (every tag-name? object)))) (define-record-type - (%make-tag predicate name description extra subsets supersets) + (%make-tag name predicate constructor accessor extra description + subsets supersets) tag? - (predicate tag->predicate) (name tag-name) - (description %tag-description) + (predicate tag->predicate) + (constructor tag-constructor) + (accessor tag-accessor) (extra tag-extra) + (description %tag-description) (subsets tag-subsets) (supersets tag-supersets)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9f5c1f712..8d12e9476 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1848,7 +1848,7 @@ USA. parametric-predicate-template parametric-predicate? predicate-template-accessor - predicate-template-instantiator + predicate-template-constructor predicate-template-name predicate-template-parameter-names predicate-template-pattern @@ -1859,12 +1859,12 @@ USA. (files "predicate-tagging") (parent (runtime)) (export () - object->datum - object->predicate - object-tagger predicate-tagging-strategy:always predicate-tagging-strategy:never predicate-tagging-strategy:optional + object->datum + object->predicate + object-tagger set-tagged-object-unparser-method! tag-object tagged-object-datum diff --git a/tests/check.scm b/tests/check.scm index 6bd1d5d4a..3b6d795c4 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -49,7 +49,7 @@ USA. "runtime/test-arith" "runtime/test-bytevector" ("runtime/test-char-set" (runtime character-set)) - ("runtime/test-compound-predicate" (runtime compound-predicate)) + ("runtime/test-compound-predicate" (runtime)) "runtime/test-dragon4" "runtime/test-dynamic-env" "runtime/test-division" @@ -61,8 +61,8 @@ USA. "runtime/test-integer-bits" "runtime/test-mime-codec" ("runtime/test-parametric-predicate" (runtime parametric-predicate)) - ("runtime/test-predicate-lattice" (runtime predicate-lattice)) - ("runtime/test-predicate-metadata" (runtime predicate-metadata)) + ("runtime/test-predicate-lattice" (runtime)) + ("runtime/test-predicate-metadata" (runtime)) "runtime/test-thread-queue" "runtime/test-process" "runtime/test-readwrite" diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm index 4357b3706..aa002bc9c 100644 --- a/tests/runtime/test-parametric-predicate.scm +++ b/tests/runtime/test-parametric-predicate.scm @@ -28,17 +28,22 @@ USA. (declare (usual-integrations)) +(define (make-template name pattern) + (make-predicate-template name pattern + predicate-tagging-strategy:always + (lambda (tag) tag any-object?))) + (define-test 'parametric-predicate-one-parameter (lambda () (let ((pattern '((? base)))) - (let* ((template (make-predicate-template 'template pattern)) - (instantiator (predicate-template-instantiator template))) + (let* ((template (make-template 'template pattern)) + (constructor (predicate-template-constructor template))) (test-template-operations template 'template pattern) (let ((params1 (list number?)) (params2 (list boolean?))) - (let ((tn (apply instantiator params1)) - (tb (apply instantiator params2))) + (let ((tn (apply constructor params1)) + (tb (apply constructor params2))) (test-predicate-operations tn '(template number)) (test-predicate-operations tb '(template boolean)) (test-parametric-predicate-operations tn template params1) @@ -47,14 +52,14 @@ USA. (define-test 'parametric-predicate-two-parameters (lambda () (let ((pattern '((?* domains -) (? base)))) - (let* ((template (make-predicate-template 'template pattern)) - (instantiator (predicate-template-instantiator template))) + (let* ((template (make-template 'template pattern)) + (constructor (predicate-template-constructor template))) (test-template-operations template 'template pattern) (let ((params1 (list (list number? number?) number?)) (params2 (list (list boolean? boolean?) boolean?))) - (let ((tn (apply instantiator params1)) - (tb (apply instantiator params2))) + (let ((tn (apply constructor params1)) + (tb (apply constructor params2))) (test-predicate-operations tn '(template (number number) number)) (test-predicate-operations tb '(template (boolean boolean) boolean)) (test-parametric-predicate-operations tn template params1) @@ -62,11 +67,11 @@ USA. (define-test 'covariant-ordering (lambda () - (let* ((template (make-predicate-template 'foo '((? a)))) - (instantiator (predicate-template-instantiator template))) - (let ((p1 (instantiator (disjoin string? symbol?))) - (p2 (instantiator string?)) - (p3 (instantiator symbol?))) + (let* ((template (make-template 'foo '((? a)))) + (constructor (predicate-template-constructor template))) + (let ((p1 (constructor (disjoin string? symbol?))) + (p2 (constructor string?)) + (p3 (constructor symbol?))) (assert-true (predicate<= p1 p1)) (assert-false (predicate<= p1 p2)) @@ -84,11 +89,11 @@ USA. (define-test 'contravariant-ordering (lambda () - (let* ((template (make-predicate-template 'foo '((? a -)))) - (instantiator (predicate-template-instantiator template))) - (let ((p1 (instantiator (disjoin string? symbol?))) - (p2 (instantiator string?)) - (p3 (instantiator symbol?))) + (let* ((template (make-template 'foo '((? a -)))) + (constructor (predicate-template-constructor template))) + (let ((p1 (constructor (disjoin string? symbol?))) + (p2 (constructor string?)) + (p3 (constructor symbol?))) (assert-true (predicate<= p1 p1)) (assert-true (predicate<= p1 p2)) @@ -106,13 +111,13 @@ USA. (define-test 'mixed-ordering (lambda () - (let* ((template (make-predicate-template 'foo '((? a -) (? b)))) - (instantiator (predicate-template-instantiator template))) - (let ((p1 (instantiator (disjoin string? symbol?) - (disjoin string? symbol?))) - (p2 (instantiator string? string?)) - (p3 (instantiator string? (disjoin string? symbol?))) - (p4 (instantiator (disjoin string? symbol?) string?))) + (let* ((template (make-template 'foo '((? a -) (? b)))) + (constructor (predicate-template-constructor template))) + (let ((p1 (constructor (disjoin string? symbol?) + (disjoin string? symbol?))) + (p2 (constructor string? string?)) + (p3 (constructor string? (disjoin string? symbol?))) + (p4 (constructor (disjoin string? symbol?) string?))) (for-each (lambda (predicate) (assert-true (predicate<= predicate predicate))) @@ -237,7 +242,8 @@ USA. (parametric-predicate-template predicate))) (define (match-numbers pattern values) - (parameter-bindings->alist (match-template-pattern pattern values number?))) + (parameter-bindings->alist + (match-template-pattern pattern values number? 'match-numbers))) (define (parameter-bindings->alist bindings) (map (lambda (binding)