repair mz test suite

svn: r7760

collects/tests/mzscheme/file.ss

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

collects/tests/mzscheme/htdp-image.ss

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

collects/tests/mzscheme/macro.ss

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

collects/tests/mzscheme/makeflats.ss

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

collects/tests/mzscheme/module.ss

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

collects/tests/mzscheme/namespac.ss

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

collects/tests/mzscheme/optimize.ss

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

collects/tests/mzscheme/package-gen.ss

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

collects/tests/mzscheme/parallel.ss

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

collects/tests/mzscheme/param.ss

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

collects/tests/mzscheme/path.ss

@@ -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 "\\\\?\\\\UNC\\x\\y") cleanse-path (coerce "\\\\?\\\\UNC\\x\\y"))
-    (test (string->path "\\\\?\\c:\\") expand-path (coerce "\\\\?\\c:\\\\")))
+    (test (string->path "\\\\?\\c:\\") cleanse-path (coerce "\\\\?\\c:\\\\")))
 
-  ;; expand-path removes redundant backslashes, and
+  ;; cleanse-path removes redundant backslashes, and
-  ;; simplify-path uses expand-path under Windows:
+  ;; simplify-path uses cleanse-path under Windows:
   (let ([go
-         (lambda (expand-path)
+         (lambda (cleanse-path)
-           (test (string->path "c:\\") expand-path (coerce "c:"))
+           (test (string->path "c:\\") cleanse-path (coerce "c:"))
-           (test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\\\a\\\\."))
+           (test (string->path "\\\\?\\c:\\a\\.") cleanse-path (coerce "\\\\?\\c:\\\\a\\\\."))
-           (test (string->path "\\\\?\\c:\\a\\\\") expand-path (coerce "\\\\?\\c:\\a\\\\"))
+           (test (string->path "\\\\?\\c:\\a\\\\") cleanse-path (coerce "\\\\?\\c:\\a\\\\"))
-           (test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\a\\\\."))
+           (test (string->path "\\\\?\\c:\\a\\.") cleanse-path (coerce "\\\\?\\c:\\a\\\\."))
-           (test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\."))
+           (test (string->path "\\\\?\\UNC\\a\\b\\.") cleanse-path (coerce "\\\\?\\UNC\\\\a\\b\\."))
-           (test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\\\."))
+           (test (string->path "\\\\?\\UNC\\a\\b\\.") cleanse-path (coerce "\\\\?\\UNC\\\\a\\b\\\\."))
-           (test (string->path "\\\\?\\RED\\\\..") expand-path (coerce "\\\\?\\RED\\.."))
+           (test (string->path "\\\\?\\RED\\\\..") cleanse-path (coerce "\\\\?\\RED\\.."))
-           (test (string->path "\\\\?\\") expand-path (coerce "\\\\?\\\\")))])
+           (test (string->path "\\\\?\\") cleanse-path (coerce "\\\\?\\\\")))])
     (when (eq? 'windows (system-type))
-      (go expand-path)
+      (go cleanse-path)
-      (test (string->path "\\\\?\\c:") expand-path (coerce "\\\\?\\c:"))
+      (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)

collects/tests/mzscheme/runflats.ss

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

collects/tests/mzscheme/stx.ss

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

collects/tests/mzscheme/syntax.ss

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

collects/tests/mzscheme/unit.ss

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

collects/tests/mzscheme/unitsig.ss

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

src/mzscheme/sconfig.h

@@ -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. */
 

src/mzscheme/src/network.c

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

src/mzscheme/src/string.c

@@ -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 /* empty */
-# define ICONV_ARG_CAST (const char **)
-#else
-# define ICONV_ARG_CAST /* empty */
-#endif
 
 static char *do_convert(iconv_t cd,
 			/* if cd == -1 and either from_e or to_e can be NULL, then