From: Chris Hanson Date: Wed, 18 Jan 2017 00:03:58 +0000 (-0800) Subject: Implement predicate-{element-{constructor,accessor},testing-strategy}. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~115 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a98e9d22b87a1ba66d46d7fc001884f490af6ae;p=mit-scheme.git Implement predicate-{element-{constructor,accessor},testing-strategy}. --- diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 5ee5fad11..71e00cc90 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -64,6 +64,15 @@ USA. (define (predicate-name predicate) (tag-name (predicate->tag predicate 'predicate-name))) +(define (predicate-element-constructor predicate) + (tag-element-constructor (predicate->tag predicate 'predicate-constructor))) + +(define (predicate-element-accessor predicate) + (tag-element-accessor (predicate->tag predicate 'predicate-accessor))) + +(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 @@ -116,6 +125,7 @@ USA. accessor (if (default-object? extra) #f extra) (if (default-object? description) #f description) + tagging-strategy (make-strong-eq-hash-table) (make-strong-eq-hash-table)))) (set-predicate-tag! predicate tag) @@ -128,14 +138,15 @@ USA. (define-record-type (%make-tag name predicate constructor accessor extra description - subsets supersets) + tagging-strategy subsets supersets) tag? (name tag-name) (predicate tag->predicate) - (constructor tag-constructor) - (accessor tag-accessor) + (constructor tag-element-constructor) + (accessor tag-element-accessor) (extra tag-extra) (description %tag-description) + (tagging-strategy tag-tagging-strategy) (subsets tag-subsets) (supersets tag-supersets)) diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index 9d17c1bab..8479f925c 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -79,12 +79,12 @@ USA. (define (predicate-tagging-strategy:never name predicate make-tag) - (define (constructor object #!optional caller) - (guarantee predicate object caller) + (define (constructor object #!optional constructor-name) + (guarantee predicate object constructor-name) object) - (define (accessor object #!optional caller) - (guarantee predicate object caller) + (define (accessor object #!optional accessor-name) + (guarantee predicate object accessor-name) object) (define tag @@ -99,13 +99,14 @@ USA. (tag<= (tagged-object-tag object) tag) (datum-test (tagged-object-datum object)))) - (define (constructor datum #!optional caller) + (define (constructor datum #!optional constructor-name) (if (not (datum-test datum)) - (error:wrong-type-argument datum (string "datum for " name) caller)) + (error:wrong-type-argument datum (string "datum for " name) + constructor-name)) (make-tagged-object tag datum)) - (define (accessor object #!optional caller) - (guarantee predicate object caller) + (define (accessor object #!optional accessor-name) + (guarantee predicate object accessor-name) object) (define tag @@ -124,17 +125,18 @@ USA. (tag<= (tagged-object-tag object) tag) (datum-test (tagged-object-datum object)))) - (define (constructor datum #!optional caller) + (define (constructor datum #!optional constructor-name) (if (not (datum-test datum)) - (error:wrong-type-argument datum (string "datum for " name) caller)) - (if (eq? tag (object->tag datum)) + (error:wrong-type-argument datum (string "datum for " name) + constructor-name)) + (if (tag<= (object->tag datum) tag) datum (make-tagged-object tag datum))) - (define (accessor object #!optional caller) + (define (accessor object #!optional accessor-name) (cond ((tagged-object-test object) (tagged-object-datum object)) ((datum-test object) object) - (else (error:not-a predicate object caller)))) + (else (error:not-a predicate object accessor-name)))) (define tag (make-tag predicate constructor accessor)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 8d12e9476..b57672cda 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1782,7 +1782,10 @@ USA. guarantee-list-of no-object? predicate-description + predicate-element-accessor + predicate-element-constructor predicate-name + predicate-tagging-strategy predicate? register-predicate! set-predicate<=! @@ -1800,8 +1803,11 @@ USA. set-tag<=! tag->predicate tag-description + tag-element-accessor + tag-element-constructor tag-extra tag-name + tag-tagging-strategy tag? top-tag top-tag?)) diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm index 67cec84ea..06f04a035 100644 --- a/tests/runtime/test-compound-predicate.scm +++ b/tests/runtime/test-compound-predicate.scm @@ -57,4 +57,41 @@ USA. (define (test-compound-predicate-operations predicate operator operands) (assert-true (compound-predicate? predicate)) (assert-eqv (compound-predicate-operator predicate) operator) - (assert-lset= eqv? (compound-predicate-operands predicate) operands)) \ No newline at end of file + (assert-lset= eqv? (compound-predicate-operands predicate) operands)) + +(define-test 'construction + (lambda () + (test-element-construction (disjoin) + '() '(41 #t "41" 'foo)) + (test-element-construction (disjoin number? boolean?) + '(41 #t) '("41" 'foo)) + (test-element-construction (disjoin number? string?) + '(41 "41") '(#t 'foo)) + (test-element-construction (conjoin) + '(41 #t "41" 'foo) '()) + (test-element-construction (conjoin number? boolean?) + '() '(41 #t "41" 'foo)) + (test-element-construction (conjoin number? string?) + '() '(41 #t "41" 'foo)))) + +(define (test-element-construction predicate data non-data) + (let ((constructor (predicate-element-constructor predicate)) + (accessor (predicate-element-accessor predicate)) + (tagging-strategy (predicate-tagging-strategy predicate))) + (for-each + (lambda (datum) + (let ((object (constructor datum))) + (assert-true (predicate object)) + (assert-eq datum (accessor object)) + (cond ((eqv? tagging-strategy predicate-tagging-strategy:never) + (assert-eq datum object)) + ((eqv? tagging-strategy predicate-tagging-strategy:always) + (assert-not-eq datum object)) + (else + (if (predicate<= (object->predicate datum) predicate) + (assert-eq datum object) + (assert-not-eq datum object)))))) + data) + (for-each (lambda (non-datum) + (assert-type-error (lambda () (constructor non-datum)))) + non-data))) \ No newline at end of file diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm index 7d9e7a2a4..e381e671f 100644 --- a/tests/runtime/test-predicate-metadata.scm +++ b/tests/runtime/test-predicate-metadata.scm @@ -49,4 +49,32 @@ USA. (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)))) \ No newline at end of file + (assert-equal (predicate-description predicate) (tag-description tag)))) + +(define-test 'simple-predicate-constructor + (lambda () + (test-element-construction number? '(41) '(foo)) + (test-element-construction boolean? '(#t) '(foo)) + (test-element-construction string? '("41") '(foo)))) + +(define (test-element-construction predicate data non-data) + (let ((constructor (predicate-element-constructor predicate)) + (accessor (predicate-element-accessor predicate)) + (tagging-strategy (predicate-tagging-strategy predicate))) + (for-each + (lambda (datum) + (let ((object (constructor datum))) + (assert-true (predicate object)) + (assert-eq datum (accessor object)) + (cond ((eqv? tagging-strategy predicate-tagging-strategy:never) + (assert-eq datum object)) + ((eqv? tagging-strategy predicate-tagging-strategy:always) + (assert-not-eq datum object)) + (else + (if (predicate<= (object->predicate datum) predicate) + (assert-eq datum object) + (assert-not-eq datum object)))))) + data) + (for-each (lambda (non-datum) + (assert-type-error (lambda () (constructor non-datum)))) + non-data))) \ No newline at end of file