From: Chris Hanson Date: Sat, 28 Jan 2017 05:06:37 +0000 (-0800) Subject: Rename predicate constructor/accessor to tagger/untagger. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~44 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5a89e2b0f9c04b3045987e8d3a0afe9befc1cf67;p=mit-scheme.git Rename predicate constructor/accessor to tagger/untagger. --- diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 9f1a037db..defaa7763 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -58,11 +58,11 @@ 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-tagger predicate) + (tag-tagger (predicate->tag predicate 'predicate-tagger))) -(define (predicate-element-accessor predicate) - (tag-element-accessor (predicate->tag predicate 'predicate-accessor))) +(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))) @@ -112,12 +112,12 @@ USA. (if (not (default-object? description)) (guarantee string? description caller)) (tagging-strategy name datum-test - (lambda (predicate constructor accessor) + (lambda (predicate tagger untagger) (let ((tag (%make-tag name predicate - constructor - accessor + tagger + untagger (if (default-object? extra) #f extra) (if (default-object? description) #f description) tagging-strategy @@ -132,13 +132,13 @@ USA. (every tag-name? object)))) (define-record-type - (%make-tag name predicate constructor accessor extra description + (%make-tag name predicate tagger untagger extra description tagging-strategy subsets supersets) tag? (name tag-name) (predicate tag->predicate) - (constructor tag-element-constructor) - (accessor tag-element-accessor) + (tagger tag-tagger) + (untagger tag-untagger) (extra tag-extra) (description %tag-description) (tagging-strategy tag-tagging-strategy) diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index 8479f925c..a1d36527f 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -78,17 +78,18 @@ USA. ;;;; Tagging strategies (define (predicate-tagging-strategy:never name predicate make-tag) + (declare (ignore name)) - (define (constructor object #!optional constructor-name) - (guarantee predicate object constructor-name) + (define (tagger object #!optional tagger-name) + (guarantee predicate object tagger-name) object) - (define (accessor object #!optional accessor-name) - (guarantee predicate object accessor-name) + (define (untagger object #!optional untagger-name) + (guarantee predicate object untagger-name) object) (define tag - (make-tag predicate constructor accessor)) + (make-tag predicate tagger untagger)) tag) @@ -99,18 +100,18 @@ USA. (tag<= (tagged-object-tag object) tag) (datum-test (tagged-object-datum object)))) - (define (constructor datum #!optional constructor-name) + (define (tagger datum #!optional tagger-name) (if (not (datum-test datum)) (error:wrong-type-argument datum (string "datum for " name) - constructor-name)) + tagger-name)) (make-tagged-object tag datum)) - (define (accessor object #!optional accessor-name) - (guarantee predicate object accessor-name) - object) + (define (untagger object #!optional untagger-name) + (guarantee predicate object untagger-name) + (tagged-object-datum object)) (define tag - (make-tag predicate constructor tagged-object-datum)) + (make-tag predicate tagger untagger)) tag) @@ -125,21 +126,21 @@ USA. (tag<= (tagged-object-tag object) tag) (datum-test (tagged-object-datum object)))) - (define (constructor datum #!optional constructor-name) + (define (tagger datum #!optional tagger-name) (if (not (datum-test datum)) (error:wrong-type-argument datum (string "datum for " name) - constructor-name)) + tagger-name)) (if (tag<= (object->tag datum) tag) datum (make-tagged-object tag datum))) - (define (accessor object #!optional accessor-name) + (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 accessor-name)))) + (else (error:not-a predicate object untagger-name)))) (define tag - (make-tag predicate constructor accessor)) + (make-tag predicate tagger untagger)) tag) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 67c4e6d32..9c6caa3e6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1890,10 +1890,10 @@ USA. guarantee-list-of no-object? predicate-description - predicate-element-accessor - predicate-element-constructor predicate-name + predicate-tagger predicate-tagging-strategy + predicate-untagger predicate? register-predicate! set-predicate<=! @@ -1910,11 +1910,11 @@ USA. set-tag<=! tag->predicate tag-description - tag-element-accessor - tag-element-constructor tag-extra tag-name + tag-tagger tag-tagging-strategy + tag-untagger tag? top-tag top-tag?)) diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm index 06f04a035..26d714aaf 100644 --- a/tests/runtime/test-compound-predicate.scm +++ b/tests/runtime/test-compound-predicate.scm @@ -59,30 +59,24 @@ USA. (assert-eqv (compound-predicate-operator predicate) operator) (assert-lset= eqv? (compound-predicate-operands predicate) operands)) -(define-test 'construction +(define-test 'tagging (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)) + (test-tagging (disjoin) '() '(41 #t "41" 'foo)) + (test-tagging (disjoin number? boolean?) '(41 #t) '("41" 'foo)) + (test-tagging (disjoin number? string?) '(41 "41") '(#t 'foo)) + (test-tagging (conjoin) '(41 #t "41" 'foo) '()) + (test-tagging (conjoin number? boolean?) '() '(41 #t "41" 'foo)) + (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 (constructor datum))) + (let ((object (tagger datum))) (assert-true (predicate object)) - (assert-eq datum (accessor 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) @@ -93,5 +87,5 @@ USA. (assert-not-eq datum object)))))) data) (for-each (lambda (non-datum) - (assert-type-error (lambda () (constructor non-datum)))) + (assert-type-error (lambda () (tagger 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 e381e671f..2bb350085 100644 --- a/tests/runtime/test-predicate-metadata.scm +++ b/tests/runtime/test-predicate-metadata.scm @@ -51,21 +51,21 @@ USA. (assert-equal (tag-name tag) name) (assert-equal (predicate-description predicate) (tag-description tag)))) -(define-test 'simple-predicate-constructor +(define-test 'simple-predicate-tagging (lambda () - (test-element-construction number? '(41) '(foo)) - (test-element-construction boolean? '(#t) '(foo)) - (test-element-construction string? '("41") '(foo)))) + (test-tagging number? '(41) '(foo)) + (test-tagging boolean? '(#t) '(foo)) + (test-tagging string? '("41") '(foo)))) -(define (test-element-construction predicate data non-data) - (let ((constructor (predicate-element-constructor predicate)) - (accessor (predicate-element-accessor predicate)) +(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 (constructor datum))) + (let ((object (tagger datum))) (assert-true (predicate object)) - (assert-eq datum (accessor 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) @@ -76,5 +76,5 @@ USA. (assert-not-eq datum object)))))) data) (for-each (lambda (non-datum) - (assert-type-error (lambda () (constructor non-datum)))) + (assert-type-error (lambda () (tagger non-datum)))) non-data))) \ No newline at end of file