repair mz test suite
svn: r7760
This commit is contained in:
parent
416cffff77
commit
3abf3eb098
|
@ -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?))
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -3,8 +3,6 @@
|
|||
|
||||
(Section 'optimization)
|
||||
|
||||
(require scheme/namespace)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Check JIT inlining of primitives:
|
||||
|
|
|
@ -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"])
|
||||
|
|
|
@ -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])
|
||||
|
|
|
@ -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"))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -595,8 +595,6 @@
|
|||
#f y)
|
||||
x))
|
||||
|
||||
(require scheme/namespace)
|
||||
|
||||
(test 55 'namespace
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-variable-bind/invoke-unit
|
||||
|
|
|
@ -603,8 +603,6 @@
|
|||
(define foo 12)))
|
||||
foo))
|
||||
|
||||
(require scheme/namespace)
|
||||
|
||||
(test 120
|
||||
'namespace
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
|
|
|
@ -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. */
|
||||
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user