suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Syncing up to get that bugfix on trunk.

Browse Source 
svn: r18391
This commit is contained in:
Stevie Strickland 2010-02-27 21:02:36 +00:00
commit 75dd3eeb2b
4 changed files with 105 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/scheme/private/class-internal.ss
View File

@ -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)

20
collects/scheme/require.ss
View File

@ -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)))))))]))

81
collects/tests/mzscheme/contract-test.ss
View File

@ -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)))
;
;

26
collects/typed-scheme/private/with-types.ss
View File

@ -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)