From 448ada8c620b9069b61b0884593d7c06d65728b3 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 29 May 2014 23:16:03 -0700 Subject: [PATCH] Correctly add scopes to incoming objects in replace-names. original commit: 1ec00bb6029a251ae0415620a5d38e43289da162 --- .../typed-racket/typecheck/tc-subst.rkt | 19 ++++++++++++------- .../unit-tests/metafunction-tests.rkt | 10 ++++++++++ 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt index 4fab5b35..69736752 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt @@ -83,11 +83,7 @@ #:Object (lambda (f) (subst-object f k o polarity))) t [#:arr dom rng rest drest kws - (let* ([st* (if (pair? k) - ;; Add a scope if we are substituting an index and - ;; not a free variable by name - (λ (t) (subst-type t (add-scope k) o polarity)) - st)]) + (let* ([st* (λ (t) (subst-type t (add-scope k) (add-scope/object o) polarity))]) (make-arr (map st dom) (st* rng) (and rest (st rest)) @@ -95,9 +91,18 @@ (map st kws)))])) ;; add-scope : name-ref/c -> name-ref/c -;; Add a scope from an index object +;; Add a scope to an index name-ref (define (add-scope key) - (list (+ (car key) 1) (cadr key))) + (match key + [(list fun arg) (list (add1 fun) arg)] + [(? identifier?) key])) + +;; add-scope/object : Object? -> Object? +;; Add a scope to an index object +(define (add-scope/object obj) + (match obj + [(Empty:) -empty-obj] + [(Path: p nm) (make-Path p (add-scope nm))])) ;; Substitution of objects into objects ;; This is o [o'/x] from the paper diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt index 2bd9b58b..ea575860 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt @@ -144,6 +144,16 @@ (list (make-Path null #'x)) (list Univ)) (ret null null null (-> Univ -Boolean : (-FS (-filter -String #'x) -top)) 'b)) + ) + (test-suite "replace-names" + (check-equal? + (replace-names (list (list #'x (make-Path null (list 0 0)))) + (ret Univ -top-filter (make-Path null #'x))) + (ret Univ -top-filter (make-Path null (list 0 0)))) + (check-equal? + (replace-names (list (list #'x (make-Path null (list 0 0)))) + (ret (-> Univ Univ : -top-filter : (make-Path null #'x)))) + (ret (-> Univ Univ : -top-filter : (make-Path null (list 1 0))))) ) ))