Identify, expose, and repair bug (using the new `opaque-placeholder`)
This commit is contained in:
parent
0021f7f1a9
commit
b4f1d36329
|
@ -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?)
|
||||
|
|
|
@ -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))
|
Loading…
Reference in New Issue