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

repair mz test suite

Browse Source 
svn: r7760
This commit is contained in:
Matthew Flatt 2007-11-18 04:34:49 +00:00
parent 416cffff77
commit 3abf3eb098
19 changed files with 56 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/tests/mzscheme/file.ss
View File

@ -1367,7 +1367,7 @@
(equal? (cdr x) who))))
(parameterize ([current-security-guard (make-file-sg '(exists read))])
(test #t path? (expand-path "tmp1"))
(test #t path? (cleanse-path "tmp1"))
(test #t file-exists? "tmp1")
(test #f directory-exists? "tmp1")
(test #f link-exists? "tmp1")
@ -1383,7 +1383,7 @@
(test #t list? (directory-list)))
(parameterize ([current-security-guard (make-file-sg '(exists write))])
(test #t path? (expand-path "tmp1"))
(test #t path? (cleanse-path "tmp1"))
(err/rt-test (open-input-file "tmp1") (fs-reject? 'open-input-file))
(err/rt-test (open-output-file "tmp1" #:exists 'append) (fs-reject? 'open-output-file))
(err/rt-test (open-output-file "tmp1" #:exists 'update) (fs-reject? 'open-output-file))
@ -1404,7 +1404,7 @@
(err/rt-test (current-directory "tmp1") (fs-reject? 'current-directory))
(err/rt-test (current-drive) (lambda (x)
(or (exn:unsupported? x) ((fs-reject? 'current-drive) x))))
(err/rt-test (expand-path "tmp1") (fs-reject? 'expand-path))
(err/rt-test (cleanse-path "tmp1") (fs-reject? 'cleanse-path))
(err/rt-test (resolve-path "tmp1") (fs-reject? 'resolve-path))
(err/rt-test (simplify-path "../tmp1") (fs-reject? 'simplify-path))
(err/rt-test (file-exists? "tmp1") (fs-reject? 'file-exists?))

2
collects/tests/mzscheme/htdp-image.ss
View File

@ -1182,7 +1182,7 @@
(err/rt-name-test (overlay/xy (rectangle 100 200 'outline 'red) 10 +inf.0 #f) "third")
(err/rt-name-test (overlay/xy (rectangle 100 200 'outline 'red) -inf.0 +inf.0 #f) "second")
(parameterize ((current-namespace (make-namespace)))
(parameterize ((current-namespace (make-base-namespace)))
(err/rt-test (eval '(module m (lib "htdp-beginner.ss" "lang") (require (lib "image.ss" "teachpack" "htdp")) overlay))
(lambda (exn)
(regexp-match #rx"must be applied to arguments"

2
collects/tests/mzscheme/macro.ss
View File

@ -252,7 +252,7 @@
(let ([v (et-struct-info arity-at-least)])
(test '(struct:arity-at-least make-arity-at-least arity-at-least?
(arity-at-least-value) (set-arity-at-least-value!) #t)
(arity-at-least-value) (#f) #t)
values v))
(let ()

2
collects/tests/mzscheme/makeflats.ss
View File

@ -1,7 +1,7 @@
(define flat-number 0)
(for-each (lambda (f)
(parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-base-namespace)])
(set! flat-number (add1 flat-number))
(eval
`(begin

4
collects/tests/mzscheme/module.ss
View File

@ -133,7 +133,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check namespace-attach-module:
(let* ([n (make-namespace)]
(let* ([n (make-empty-namespace)]
[l null]
[here (lambda (v)
(set! l (cons v l)))])
@ -177,7 +177,7 @@
(eval `(require 'f))
(let ([finished '(f b e a d c b d c b d c b c)])
(test finished values l)
(let ([n2 (make-namespace)])
(let ([n2 (make-empty-namespace)])
(namespace-attach-module n ''f)
(test finished values l)
(eval `(require 'a))

4
collects/tests/mzscheme/namespac.ss
View File

@ -1,8 +1,6 @@
(load-relative "loadtest.ss")
(require scheme/namespace)
(Section 'namespaces)
(arity-test eval 1 2)
@ -58,7 +56,7 @@
gvl)))
;; Test empty namespace:
(let ([e (make-namespace)]
(let ([e (make-empty-namespace)]
[orig (current-namespace)])
(parameterize ([current-namespace e])
(test null namespace-mapped-symbols)

2
collects/tests/mzscheme/optimize.ss
View File

@ -3,8 +3,6 @@
(Section 'optimization)
(require scheme/namespace)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check JIT inlining of primitives:

2
collects/tests/mzscheme/package-gen.ss
View File

@ -98,7 +98,7 @@
(printf "~a/~a~n" cnt total))
(when ((add1 (random 10)) . >= . do-threshold)
; (pretty-print form)
(parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module ns m)
(let ([done? #f]
[mode "top-level"])

2
collects/tests/mzscheme/parallel.ss
View File

@ -31,7 +31,7 @@
(if (zero? n)
null
(cons
(let ([ns (make-namespace)]
(let ([ns (make-base-namespace)]
[eh (exit-handler)]
[cust (list-ref custodians (sub1 n))])
(parameterize ([current-custodian cust])

4
collects/tests/mzscheme/param.ss
View File

@ -1,8 +1,6 @@
(load-relative "loadtest.ss")
(require scheme/namespace)
(Section 'parameters)
(let ([p (open-output-file "tmp5" #:exists 'replace)])
@ -296,7 +294,7 @@
(list current-namespace
(list (make-base-namespace)
(make-namespace))
(make-empty-namespace))
'(begin 0)
exn:fail:syntax?
'("bad setting"))

47
collects/tests/mzscheme/path.ss
View File

@ -284,9 +284,9 @@
rels)
(define (test-path expect f . args)
(test (normal-case-path (expand-path expect))
(test (normal-case-path (cleanse-path expect))
(or (object-name f) 'unknown)
(normal-case-path (expand-path (apply f args)))))
(normal-case-path (cleanse-path (apply f args)))))
(for-each
(lambda (absol)
@ -387,7 +387,8 @@
(test (path->directory-path (build-path 'same)) simplify-path (build-path 'same "a" 'same 'up 'same) #f)
(arity-test simplify-path 1 2)
(arity-test expand-path 1 2)
(arity-test cleanse-path 1 1)
(arity-test expand-user-path 1 1)
(arity-test resolve-path 1 1)
(map
@ -396,7 +397,7 @@
(list build-path split-path file-exists? directory-exists?
delete-file directory-list make-directory delete-directory
file-or-directory-modify-seconds file-or-directory-permissions
expand-path resolve-path simplify-path path->complete-path
cleanse-path resolve-path simplify-path path->complete-path
open-input-file open-output-file))
(map
(lambda (f)
@ -416,7 +417,7 @@
(string-append
"\\\\?\\"
(path->string
(normal-case-path (simplify-path (expand-path (current-directory))))))
(normal-case-path (simplify-path (cleanse-path (current-directory))))))
"")]
[drive (path->string (current-drive))])
@ -672,26 +673,26 @@
(test (string->path "\\\\?\\UNC\\foo\\A") normal-case-path (coerce "\\\\?\\UNC\\foo\\A"))
(test (string->path "\\\\?\\RED\\..\\..") normal-case-path (coerce "\\\\?\\RED\\..\\.."))
;; expand-path removes redundant backslashes
;; cleanse-path removes redundant backslashes
(when (eq? 'windows (system-type))
(test (string->path "\\\\?\\\\UNC\\x\\y") expand-path (coerce "\\\\?\\\\UNC\\x\\y"))
(test (string->path "\\\\?\\c:\\") expand-path (coerce "\\\\?\\c:\\\\")))
(test (string->path "\\\\?\\\\UNC\\x\\y") cleanse-path (coerce "\\\\?\\\\UNC\\x\\y"))
(test (string->path "\\\\?\\c:\\") cleanse-path (coerce "\\\\?\\c:\\\\")))
;; expand-path removes redundant backslashes, and
;; simplify-path uses expand-path under Windows:
;; cleanse-path removes redundant backslashes, and
;; simplify-path uses cleanse-path under Windows:
(let ([go
(lambda (expand-path)
(test (string->path "c:\\") expand-path (coerce "c:"))
(test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\\\a\\\\."))
(test (string->path "\\\\?\\c:\\a\\\\") expand-path (coerce "\\\\?\\c:\\a\\\\"))
(test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\a\\\\."))
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\."))
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\\\."))
(test (string->path "\\\\?\\RED\\\\..") expand-path (coerce "\\\\?\\RED\\.."))
(test (string->path "\\\\?\\") expand-path (coerce "\\\\?\\\\")))])
(lambda (cleanse-path)
(test (string->path "c:\\") cleanse-path (coerce "c:"))
(test (string->path "\\\\?\\c:\\a\\.") cleanse-path (coerce "\\\\?\\c:\\\\a\\\\."))
(test (string->path "\\\\?\\c:\\a\\\\") cleanse-path (coerce "\\\\?\\c:\\a\\\\"))
(test (string->path "\\\\?\\c:\\a\\.") cleanse-path (coerce "\\\\?\\c:\\a\\\\."))
(test (string->path "\\\\?\\UNC\\a\\b\\.") cleanse-path (coerce "\\\\?\\UNC\\\\a\\b\\."))
(test (string->path "\\\\?\\UNC\\a\\b\\.") cleanse-path (coerce "\\\\?\\UNC\\\\a\\b\\\\."))
(test (string->path "\\\\?\\RED\\\\..") cleanse-path (coerce "\\\\?\\RED\\.."))
(test (string->path "\\\\?\\") cleanse-path (coerce "\\\\?\\\\")))])
(when (eq? 'windows (system-type))
(go expand-path)
(test (string->path "\\\\?\\c:") expand-path (coerce "\\\\?\\c:"))
(go cleanse-path)
(test (string->path "\\\\?\\c:") cleanse-path (coerce "\\\\?\\c:"))
(go simplify-path))
(go (lambda (p) (simplify-path p #f)))
(test (string->path "a\\b") simplify-path (coerce "a/b") #f)
@ -709,7 +710,7 @@
(test (bytes->path #"\\\\?\\\\\\c:") simplify-path (coerce "\\\\?\\\\\\c:") #f)
(when (eq? 'windows (system-type))
(test (bytes->path #"\\\\?\\c:\\a\\b//c\\d") expand-path (coerce "\\\\?\\c:\\a\\b//c\\d")))
(test (bytes->path #"\\\\?\\c:\\a\\b//c\\d") cleanse-path (coerce "\\\\?\\c:\\a\\b//c\\d")))
(test (bytes->path #"\\\\?\\UNC\\a\\b/c\\") simplify-path (coerce "\\\\?\\\\UNC\\a\\b/c") #f)
(test (bytes->path #"\\\\a\\b\\") simplify-path (coerce "\\\\?\\\\UNC\\a\\b") #f)
@ -720,7 +721,7 @@
(test (bytes->path #"..\\") simplify-path (coerce "\\\\?\\REL\\..") #f)
(test (bytes->path #"..\\") simplify-path (coerce "\\\\?\\REL\\..\\") #f)
(when (eq? 'windows (system-type))
(test (bytes->path #"\\\\foo\\bar\\") expand-path (coerce "\\\\foo\\bar\\")))
(test (bytes->path #"\\\\foo\\bar\\") cleanse-path (coerce "\\\\foo\\bar\\")))
(test (bytes->path #"\\\\foo\\bar\\") simplify-path (coerce "\\\\foo\\bar\\") #f)
(test (bytes->path #"\\\\foo\\bar\\") simplify-path (coerce "\\\\?\\UNC\\foo\\bar") #f)
(test (bytes->path #"\\\\foo\\bar\\") simplify-path (coerce "\\\\?\\UNC\\foo\\bar\\") #f)

2
collects/tests/mzscheme/runflats.ss
View File

@ -1,7 +1,7 @@
(for-each (lambda (f)
(when (regexp-match "^flat-[0-9]+[.]ss$" (path->string f))
(parameterize ([current-namespace (make-namespace)]
(parameterize ([current-namespace (make-base-namespace)]
[exit-handler void])
(eval
`(begin

6
collects/tests/mzscheme/stx.ss
View File

@ -452,7 +452,7 @@
(let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base
(require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons]))
bcons)) ()
[(mod m mz (#%mod-beg req (app print cons) void))
[(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print) void))
(let ([s (syntax cons)])
(test 'bcons syntax-e s)
s)]))])
@ -842,11 +842,9 @@
(test 100 values ++xm)
(test 10 values ++y-macro2)
(require scheme/namespace)
(let ()
(define n (current-namespace))
(define n2 (make-empty-base-namespace))
(define n2 (make-base-empty-namespace))
(define i (make-inspector))

2
collects/tests/mzscheme/syntax.ss
View File

@ -1091,7 +1091,7 @@
[(_ . e) (quote e)])))
(dynamic-require ''quoting-top-interaction #f)
(let ([ns (make-namespace)])
(let ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace) ''quoting-top-interaction ns)
(parameterize ([current-namespace ns])
(namespace-require ''quoting-top-interaction))

2
collects/tests/mzscheme/unit.ss
View File

@ -595,8 +595,6 @@
#f y)
x))
(require scheme/namespace)
(test 55 'namespace
(parameterize ([current-namespace (make-base-namespace)])
(namespace-variable-bind/invoke-unit

2
collects/tests/mzscheme/unitsig.ss
View File

@ -603,8 +603,6 @@
(define foo 12)))
foo))
(require scheme/namespace)
(test 120
'namespace
(parameterize ([current-namespace (make-base-namespace)])

8
src/mzscheme/sconfig.h
View File

@ -673,6 +673,8 @@
# define USE_UNDERSCORE_SETJMP
# define UDP_DISCONNECT_EADRNOTAVAIL_OK
#ifndef XONX
# define MACOS_UNICODE_SUPPORT
#endif
@ -709,6 +711,8 @@
# define USE_UNDERSCORE_SETJMP
# define UDP_DISCONNECT_EADRNOTAVAIL_OK
# define MZ_USE_JIT_I386
# define FLAGS_ALREADY_SET
@ -1042,6 +1046,10 @@
/* USE_NULL_TO_DISCONNECT_UDP calls connect() with NULL instead of
an AF_UNSPEC address to disconnect a UDP socket. */
/* UDP_DISCONNECT_EADRNOTAVAIL_OK means that a disconnecting call
to connect() might return EADDRNOTAVAIL instead of
EAFNOSUPPORT. */
/* MZ_BINARY is combinaed with other flags in all calls to open();
it can be defined to O_BINARY in Cygwin, for example. */

8
src/mzscheme/src/network.c
View File

@ -2705,6 +2705,12 @@ udp_connected_p(int argc, Scheme_Object *argv[])
#endif
}
#ifdef UDP_DISCONNECT_EADRNOTAVAIL_OK
# define OK_DISCONNECT_ERROR(e) (((e) == mz_AFNOSUPPORT) || ((e) == EADDRNOTAVAIL))
#else
# define OK_DISCONNECT_ERROR(e) ((e) == mz_AFNOSUPPORT)
#endif
static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Object *argv[], int do_bind)
{
#ifdef UDP_IS_SUPPORTED
@ -2806,7 +2812,7 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj
else
errid = 0;
if (!ok && (errid == mz_AFNOSUPPORT) && !origid) {
if (!ok && OK_DISCONNECT_ERROR(errid) && !origid) {
/* It's ok. We were trying to disconnect */
ok = 1;
}

6
src/mzscheme/src/string.c
View File

@ -2395,11 +2395,7 @@ static Scheme_Object *system_language_country(int argc, Scheme_Object *argv[])
#ifndef DONT_USE_LOCALE
#ifdef OS_X
# define ICONV_ARG_CAST (const char **)
#else
# define ICONV_ARG_CAST /* empty */
#endif
#define ICONV_ARG_CAST /* empty */
static char *do_convert(iconv_t cd,
/* if cd == -1 and either from_e or to_e can be NULL, then