From 68c46cca9a57835f38cb42e6eee45c86755f7cd8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 27 Feb 2010 19:21:42 +0000 Subject: [PATCH 1/3] fix with-types requires on windows svn: r18387 --- collects/typed-scheme/private/with-types.ss | 26 ++++++++++----------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/private/with-types.ss b/collects/typed-scheme/private/with-types.ss index dfaf470fc1..1cb4d12b1e 100644 --- a/collects/typed-scheme/private/with-types.ss +++ b/collects/typed-scheme/private/with-types.ss @@ -11,19 +11,19 @@ "base-types.ss" scheme/contract/regions scheme/contract/base (for-syntax "base-types-extra.ss") - (for-syntax (except-in (path-up "utils/utils.ss") infer) - (path-up "utils/tc-utils.ss") - (except-in (combine-in (path-up "types/convenience.ss") (path-up "types/abbrev.ss")) ->) - (path-up "types/utils.ss") - (path-up "infer/infer.ss") - (path-up "env/type-env.ss") - (path-up "env/type-environments.ss") - (path-up "env/type-name-env.ss") - (path-up "env/type-alias-env.ss") - (path-up "infer/infer-dummy.ss") - (path-up "private/parse-type.ss") - (path-up "private/type-contract.ss") - (path-up "typecheck/typechecker.ss"))) + (for-syntax (except-in "../utils/utils.ss" infer) + "../utils/tc-utils.ss" + (except-in (combine-in "../types/convenience.ss" "../types/abbrev.ss") ->) + "../types/utils.ss" + "../infer/infer.ss" + "../env/type-env.ss" + "../env/type-environments.ss" + "../env/type-name-env.ss" + "../env/type-alias-env.ss" + "../infer/infer-dummy.ss" + "../private/parse-type.ss" + "../private/type-contract.ss" + "../typecheck/typechecker.ss")) (provide with-type) (define-syntax (with-type stx) From cd076ae512cb68d407aa4652c5a525a24006e3c3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 27 Feb 2010 20:20:25 +0000 Subject: [PATCH 2/3] Fix bad assumption that paths can be turned to require specs (which breaks on Windows). svn: r18388 --- collects/scheme/require.ss | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/collects/scheme/require.ss b/collects/scheme/require.ss index b40197f910..90ccbf5b08 100644 --- a/collects/scheme/require.ss +++ b/collects/scheme/require.ss @@ -13,11 +13,12 @@ (regexp? (syntax-e #'rx)) (let ([rx (syntax-e #'rx)]) (define-values [imports sources] (expand-import #'spec)) - (values (filter (lambda (i) - (regexp-match? rx (symbol->string - (syntax-e (import-local-id i))))) - imports) - sources))])))) + (values + (filter (lambda (i) + (regexp-match? rx (symbol->string + (syntax-e (import-local-id i))))) + imports) + sources))])))) (provide subtract-in) (define-syntax subtract-in @@ -75,17 +76,18 @@ (let-values ([(dir name dir?) (split-path path)]) dir))] [srcdir (if (and (path-string? src) (complete-path? src)) (dirname src) - (or (current-load-relative-directory) + (or (current-load-relative-directory) (current-directory)))]) (define path (syntax-e #'path-stx)) (unless (complete-path? srcdir) (error 'path-up "internal error")) (parameterize ([current-directory srcdir]) - (let loop ([dir srcdir] [path (string->path path)]) + (let loop ([dir srcdir] [path (string->path path)] [pathstr path]) (if (file-exists? path) - (datum->syntax stx (path->string path) stx) + (datum->syntax stx pathstr stx) (let ([dir (dirname dir)]) (if dir - (loop dir (build-path 'up path)) + (loop dir (build-path 'up path) + (string-append "../" pathstr)) (raise-syntax-error 'path-up "file no found in any parent directory" stx #'path-stx)))))))])) From 16dbb0edc1e0853c571194adb757dc66fd4f1103 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 20:59:40 +0000 Subject: [PATCH 3/3] Fix bug in field mutation on contracted objects. svn: r18390 --- collects/scheme/private/class-internal.ss | 4 +- collects/tests/mzscheme/contract-test.ss | 81 ++++++++++++++++++++++- 2 files changed, 81 insertions(+), 4 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 0abfac5260..d64eebcdeb 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -4378,9 +4378,9 @@ [ext-field-ref (vector-ref old-ext-refs n)] [ext-field-set (vector-ref old-ext-sets n)]) (vector-set! int-field-refs n (λ (o) (int-field-ref obj))) - (vector-set! int-field-sets n (λ (o) (int-field-set obj))) + (vector-set! int-field-sets n (λ (o v) (int-field-set obj v))) (vector-set! ext-field-refs n (λ (o) (ext-field-ref obj))) - (vector-set! ext-field-sets n (λ (o) (ext-field-set obj)))))) + (vector-set! ext-field-sets n (λ (o v) (ext-field-set obj v)))))) ;; Handle external field contracts (unless (null? fields) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 2d35de9984..81e3558b10 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5142,7 +5142,6 @@ ; ;;;; ; ;;; -#| (test/pos-blame 'object/c-first-order-object-1 '(contract (object/c) @@ -5184,7 +5183,85 @@ (new (class object% (super-new) (field [n 3]))) 'pos 'neg)) -|# + + (test/spec-passed/result + 'object/c-higher-order-field-1 + '(get-field + n + (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)) + 3) + + (test/pos-blame + 'object/c-higher-order-field-2 + '(get-field + n + (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n #t]))) + 'pos + 'neg))) + + (test/spec-passed/result + 'object/c-higher-order-field-3 + '(let ([o (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)]) + (set-field! n o 5) + (get-field n o)) + 5) + + (test/neg-blame + 'object/c-higher-order-field-4 + '(let ([o (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)]) + (set-field! n o #t))) + + (test/spec-passed/result + 'object/c-higher-order-field-5 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n pre-o 5) + (get-field n o)) + 5) + + (test/spec-passed/result + 'object/c-higher-order-field-6 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n o 5) + (get-field n pre-o)) + 5) + + (test/neg-blame + 'object/c-higher-order-field-7 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n o #t) + (get-field n pre-o))) + + (test/pos-blame + 'object/c-higher-order-field-8 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n pre-o #t) + (get-field n o))) ; ;