From: Chris Hanson Date: Sat, 7 Jan 2017 03:46:07 +0000 (-0800) Subject: Add tests for predicates. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~193 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3fc3e6b924b350487c988c9edecc6fa850f771b8;p=mit-scheme.git Add tests for predicates. --- diff --git a/tests/check.scm b/tests/check.scm index 5a877565f..ace5029f5 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -43,6 +43,7 @@ USA. "microcode/test-lookup" "runtime/test-arith" ("runtime/test-char-set" (runtime character-set)) + ("runtime/test-compound-predicate" (runtime compound-predicate)) "runtime/test-dragon4" "runtime/test-dynamic-env" "runtime/test-division" @@ -53,6 +54,9 @@ USA. "runtime/test-hash-table" "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-thread-queue" "runtime/test-process" "runtime/test-readwrite" diff --git a/tests/runtime/test-compound-predicate.scm b/tests/runtime/test-compound-predicate.scm new file mode 100644 index 000000000..02d0dc585 --- /dev/null +++ b/tests/runtime/test-compound-predicate.scm @@ -0,0 +1,30 @@ +(define-test 'compound + (lambda () + (test-compound-predicate-operations (disjoin) 'disjoin '()) + (test-compound-predicate-operations (conjoin) 'conjoin '()) + + (assert-eqv string? (disjoin string?)) + (assert-eqv string? (disjoin string? string?)) + + (assert-eqv string? (conjoin string?)) + (assert-eqv string? (conjoin string? string?)) + + (test-compound-predicate-operations (disjoin string? symbol?) + 'disjoin + (list string? symbol?)) + (test-compound-predicate-operations (conjoin string? symbol?) + 'conjoin + (list string? symbol?)))) + +(define-test 'ordering + (lambda () + (assert-true (predicate<= string? (disjoin string? symbol?))) + (assert-false (predicate<= (disjoin string? symbol?) string?)) + + (assert-false (predicate<= string? (conjoin string? symbol?))) + (assert-true (predicate<= (conjoin string? symbol?) string?)))) + +(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 diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm new file mode 100644 index 000000000..6045c6a64 --- /dev/null +++ b/tests/runtime/test-parametric-predicate.scm @@ -0,0 +1,243 @@ +(define-test 'parametric-predicate-one-parameter + (lambda () + (let ((pattern '((? base)))) + (let* ((template (make-predicate-template 'template pattern)) + (instantiator (predicate-template-instantiator template))) + (test-template-operations template 'template pattern) + + (let ((params1 (list number?)) + (params2 (list boolean?))) + (let ((tn (apply instantiator params1)) + (tb (apply instantiator params2))) + (test-predicate-operations tn '(template number)) + (test-predicate-operations tb '(template boolean)) + (test-parametric-predicate-operations tn template params1) + (test-parametric-predicate-operations tb template params2))))))) + +(define-test 'parametric-predicate-two-parameters + (lambda () + (let ((pattern '((?* domains -) (? base)))) + (let* ((template (make-predicate-template 'template pattern)) + (instantiator (predicate-template-instantiator 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))) + (test-predicate-operations tn '(template (number number) number)) + (test-predicate-operations tb '(template (boolean boolean) boolean)) + (test-parametric-predicate-operations tn template params1) + (test-parametric-predicate-operations tb template params2))))))) + +(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?))) + + (assert-true (predicate<= p1 p1)) + (assert-false (predicate<= p1 p2)) + (assert-false (predicate<= p1 p3)) + + (assert-true (predicate<= p2 p1)) + (assert-true (predicate<= p2 p2)) + (assert-false (predicate<= p2 p3)) + + (assert-true (predicate<= p3 p1)) + (assert-false (predicate<= p3 p2)) + (assert-true (predicate<= p3 p3)) + + )))) + +(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?))) + + (assert-true (predicate<= p1 p1)) + (assert-true (predicate<= p1 p2)) + (assert-true (predicate<= p1 p3)) + + (assert-false (predicate<= p2 p1)) + (assert-true (predicate<= p2 p2)) + (assert-false (predicate<= p2 p3)) + + (assert-false (predicate<= p3 p1)) + (assert-false (predicate<= p3 p2)) + (assert-true (predicate<= p3 p3)) + + )))) + +(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?))) + + (for-each (lambda (predicate) + (assert-true (predicate<= predicate predicate))) + (list p1 p2 p3 p4)) + + (assert-false (predicate<= p2 p1)) + (assert-false (predicate<= p3 p1)) + (assert-true (predicate<= p4 p1)) + + (assert-false (predicate<= p3 p2)) + (assert-true (predicate<= p4 p2)) + + (assert-true (predicate<= p2 p3)) + (assert-false (predicate<= p2 p4)) + + )))) + +(define-test 'template-patterns + (lambda () + (let ((operators '(? ?* ?+)) + (names '(a b c)) + (polarities '(+ = -))) + + (assert-false (template-pattern? '())) + (assert-false (template-pattern-element? '())) + (assert-false (template-pattern? '(()))) + (for-each (lambda (symbol) + (assert-false (template-pattern? symbol)) + (assert-false (template-pattern-element? symbol)) + (assert-false (template-pattern? (list symbol))) + (assert-false (template-pattern-element? (list symbol))) + (assert-false (template-pattern? (list (list symbol))))) + (append operators names polarities)) + + (let ((elements (elementwise-lists-of (list operators names polarities)))) + (for-each + (lambda (element) + (assert-true (template-pattern? (list element))) + (assert-false (template-pattern? element)) + (for-each + (lambda (permutation) + (let ((assertion + (if (equal? permutation element) + assert-true + assert-false))) + (assertion (template-pattern-element? permutation)) + (assertion (template-pattern? (list permutation))) + (assertion (template-pattern-element? (take permutation 2))) + (assertion (template-pattern? (list (take permutation 2)))))) + (all-permutations-of element))) + elements) + + (for-each + (lambda (elements) + ((if (= (length elements) + (length (delete-duplicates (map cadr elements) eqv?))) + assert-true + assert-false) + (template-pattern? elements))) + (append + (elementwise-lists-of (list elements elements)) + (elementwise-lists-of (list elements elements elements)))))))) + +(define-test 'match-template-pattern + (lambda () + (assert-wta-error (lambda () (match-numbers '((? a)) 1))) + (assert-equal (match-numbers '((? a)) '(1)) + '((a + 1))) + (assert-equal (match-numbers '((? a -) (? b)) '(1 2)) + '((a - 1) + (b + 2))) + (assert-equal (match-numbers '((?* a) (? b -)) '((1 2 3) 2)) + '((a + (1 2 3)) + (b - 2))) + (assert-equal (match-numbers '((?+ a -) (? b)) '((1 2 3) 2)) + '((a - (1 2 3)) + (b + 2))) + (assert-equal (match-numbers '((?* a) (? b -)) '(() 2)) + '((a + ()) + (b - 2))) + (assert-simple-error (lambda () (match-numbers '((?+ a -) (? b)) '(() 2)))) + (assert-simple-error (lambda () (match-numbers '((?* a) (? b -)) '(1 2)))) + (assert-simple-error (lambda () (match-numbers '((?+ a -) (? b)) '(1 2)))))) + +(define (test-template-operations template name pattern) + (assert-true (predicate-template? template)) + (assert-false (predicate? template)) + (assert-eqv (predicate-template-name template) name) + (assert-equal pattern (predicate-template-pattern template)) + (assert-lset= eq? + (predicate-template-parameter-names template) + (map template-pattern-element-name pattern)) + (let ((predicate (predicate-template-predicate template))) + (assert-true (predicate? predicate)) + (assert-true (predicate<= predicate parametric-predicate?)) + (assert-false (predicate<= parametric-predicate? predicate)))) + +(define (test-predicate-operations predicate name) + (assert-true (predicate? predicate)) + (let ((tag (predicate->tag predicate))) + (assert-true (tag? tag)) + (assert-eqv (tag->predicate tag) predicate) + (assert-equal (predicate-name predicate) name) + (assert-equal (tag-name tag) name))) + +(define (test-parametric-predicate-operations predicate template parameters) + (assert-false (simple-predicate? predicate)) + (assert-false (compound-predicate? predicate)) + (assert-true (parametric-predicate? predicate)) + (assert-eqv (parametric-predicate-template predicate) template) + (assert-lset= eq? + (parametric-predicate-names predicate) + (predicate-template-parameter-names template)) + (assert-lset= equal? + (map (lambda (name) + ((predicate-template-accessor name template) predicate)) + (predicate-template-parameter-names template)) + parameters)) + +(define (parametric-predicate-names predicate) + (predicate-template-parameter-names + (parametric-predicate-template predicate))) + +(define (match-numbers pattern values) + (parameter-bindings->alist (match-template-pattern pattern values number?))) + +(define (parameter-bindings->alist bindings) + (map (lambda (binding) + (list (parameter-binding-name binding) + (parameter-binding-polarity binding) + (parameter-binding-value binding))) + bindings)) + +(define (all-permutations-of items) + (let loop ((items items)) + (if (pair? items) + (append-map (lambda (index) + (map (let ((head (list-ref items index))) + (lambda (tail) + (cons head tail))) + (loop (delete-item items index)))) + (iota (length items))) + '(())))) + +(define (delete-item items index) + (append (take items index) + (cdr (drop items index)))) + +(define (elementwise-lists-of lists) + (let loop ((lists lists)) + (if (pair? lists) + (append-map (let ((tails (loop (cdr lists)))) + (lambda (head) + (map (lambda (tail) + (cons head tail)) + tails))) + (car lists)) + '(())))) \ No newline at end of file diff --git a/tests/runtime/test-predicate-lattice.scm b/tests/runtime/test-predicate-lattice.scm new file mode 100644 index 000000000..0056e783d --- /dev/null +++ b/tests/runtime/test-predicate-lattice.scm @@ -0,0 +1,18 @@ +(define-test 'ordering + (lambda () + (assert-true (predicate<= no-object? string?)) + (assert-true (predicate<= no-object? no-object?)) + (assert-false (predicate<= string? no-object?)) + + (assert-false (predicate<= any-object? string?)) + (assert-true (predicate<= any-object? any-object?)) + (assert-true (predicate<= string? any-object?)) + + (assert-eqv (disjoin string?) string?) + (assert-eqv (conjoin string?) string?) + + (assert-true (predicate<= string? (disjoin string? symbol?))) + (assert-false (predicate<= (disjoin string? symbol?) string?)) + + (assert-false (predicate<= string? (conjoin string? symbol?))) + (assert-true (predicate<= (conjoin string? symbol?) string?)))) \ No newline at end of file diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm new file mode 100644 index 000000000..6bed5bd53 --- /dev/null +++ b/tests/runtime/test-predicate-metadata.scm @@ -0,0 +1,22 @@ +(define-test 'non-predicate + (lambda () + (let ((np (lambda (object) #f))) + (assert-false (predicate? np)) + (assert-wta-error (lambda () (predicate->tag np))) + (assert-wta-error (lambda () (predicate-name np))) + (assert-true (string? (predicate-description np)))))) + +(define-test 'simple-predicate + (lambda () + (test-predicate-operations number? 'number) + (test-predicate-operations boolean? 'boolean) + (test-predicate-operations string? 'string))) + +(define (test-predicate-operations predicate name) + (assert-true (predicate? predicate)) + (let ((tag (predicate->tag predicate))) + (assert-true (tag? tag)) + (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