Identify, expose, and repair bug (using the new `opaque-placeholder`)

This commit is contained in:
Tony Garnock-Jones 2018-11-20 13:20:31 +00:00
parent 6c1e3b033d
commit 937bb7a7c4
2 changed files with 85 additions and 1 deletions

View File

@ -74,6 +74,11 @@
(apply (struct-type-make-constructor (struct->struct-type t))
(map f (struct-fields t))))
(struct opaque-placeholder ())
;; ^ not transparent or prefab -- used to frustrate
;; otherwise-potentially-matching constant positions in instantiated
;; terms
(define (instantiate-term->value t actuals)
(define (pop-actual!)
(define v (car actuals))
@ -101,7 +106,7 @@
(begin0 (pop-actual!)
(pop-captures! detail))] ;; to consume nested bindings
[(discard)
(discard)]
(opaque-placeholder)]
[(? non-object-struct?)
(struct-map walk t)]
[(? list?)

View File

@ -0,0 +1,79 @@
#lang imperative-syndicate/test-implementation
;; 2018-11-20 Prior to the commit that introduced this test case (and
;; fixed the bug it exposed), matching a constant/literal `(discard)`
;; in an `inbound` pattern would match a visibility-restricted term,
;; so long as the captures were in the right places. After the fix,
;; `instantiate-term->value` replaces `(discard)` in the term with an
;; opaque value that cannot match any other value, meaning that only
;; patterns which completely ignore `discard`ed positions will match.
;;
;; Previously, the test-case marked (B) below yielded the correct
;; output, but (A) yielded the following incorrect output:
;;
;; Added discarded topic: Computering
;; Added discarded topic: Bicycling
;; Added discarded topic: Evil
;; Added discarded topic: Cryptography
;; Added topic: Computering
;; Added topic: Bicycling
;; Added topic: Evil
;; Added topic: Cryptography
;;
;; Now both yield the same output.
(require (only-in imperative-syndicate/pattern discard capture))
(assertion-struct researcher (name topic))
(define-syntax-rule (correct-topics)
(expected-output (set "Added topic: Bicycling"
"Added topic: Computering"
"Added topic: Cryptography"
"Added topic: Evil")))
(test-case ;; (A)
[(spawn #:name 'tony
(assert (researcher "Tony" "Computering"))
(assert (researcher "Tony" "Bicycling")))
(spawn #:name 'alice
(assert (researcher "Alice" "Cryptography"))
(assert (researcher "Alice" "Bicycling")))
(spawn #:name 'eve
(assert (researcher "Eve" "Cryptography"))
(assert (researcher "Eve" "Computering"))
(assert (researcher "Eve" "Evil")))
(dataspace #:name 'inner-dataspace
(spawn #:name 'all-topics
(during (inbound (researcher _ $topic))
(on-start (printf "Added topic: ~a\n" topic))
(on-stop (printf "Removed topic: ~a\n" topic))))
(spawn #:name 'all-researchers
(during (inbound (researcher (discard) $topic))
(on-start (printf "Added discarded topic: ~a\n" topic))
(on-stop (printf "Removed discarded topic: ~a\n" topic)))))]
no-crashes
(correct-topics))
(test-case ;; (B)
[(spawn #:name 'tony
(assert (researcher "Tony" "Computering"))
(assert (researcher "Tony" "Bicycling")))
(spawn #:name 'alice
(assert (researcher "Alice" "Cryptography"))
(assert (researcher "Alice" "Bicycling")))
(spawn #:name 'eve
(assert (researcher "Eve" "Cryptography"))
(assert (researcher "Eve" "Computering"))
(assert (researcher "Eve" "Evil")))
(spawn #:name 'all-topics
(during (researcher _ $topic)
(on-start (printf "Added topic: ~a\n" topic))
(on-stop (printf "Removed topic: ~a\n" topic))))
(spawn #:name 'all-researchers
(during (researcher (discard) $topic)
(on-start (printf "Added discarded topic: ~a\n" topic))
(on-stop (printf "Removed discarded topic: ~a\n" topic))))]
no-crashes
(correct-topics))