mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge remote-tracking branch 'local-2.0/stable-2.0'

Browse source 
Conflicts:
	module/language/tree-il/analyze.scm
This commit is contained in:
Andy Wingo 2012-02-23 14:10:22 +01:00
commit 9d15db65ff
10 changed files with 381 additions and 172 deletions
Download patch file Download diff file Expand all files Collapse all files

51
gnulib-local/lib/localcharset.c.diff
View file

@ -5,28 +5,10 @@ rationale.
--- a/lib/localcharset.c 2011-12-14 23:10:58.000000000 +0100
+++ b/lib/localcharset.c 2011-12-15 00:45:12.000000000 +0100
@@ -527,6 +527,76 @@ locale_charset (void)
codeset = "";
@@ -545,3 +545,74 @@ locale_charset (void)
/* Resolve alias. */
+ for (aliases = get_charset_aliases ();
+ *aliases != '\0';
+ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
+ if (strcmp (codeset, aliases) == 0
+ || (aliases[0] == '*' && aliases[1] == '\0'))
+ {
+ codeset = aliases + strlen (aliases) + 1;
+ break;
+ }
+
+ /* Don't return an empty string. GNU libc and GNU libiconv interpret
+ the empty string as denoting "the locale's character encoding",
+ thus GNU libiconv would call this function a second time. */
+ if (codeset[0] == '\0')
+ codeset = "ASCII";
+
+ return codeset;
+}
return codeset;
}
+
+/* A variant of the above, without calls to `setlocale', `nl_langinfo',
+ etc. */
@ -71,14 +53,29 @@ rationale.
+ strcpy (buf, "ASCII");
+ return buf;
+ }
+
+ /* Resolve through the charset.alias file. */
+ codeset = locale;
+ else
+ codeset = "";
+ }
+ else
+ codeset = "";
+
+ /* Resolve alias. */
for (aliases = get_charset_aliases ();
*aliases != '\0';
aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
+ for (aliases = get_charset_aliases ();
+ *aliases != '\0';
+ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
+ if (strcmp (codeset, aliases) == 0
+ || (aliases[0] == '*' && aliases[1] == '\0'))
+ {
+ codeset = aliases + strlen (aliases) + 1;
+ break;
+ }
+
+ /* Don't return an empty string. GNU libc and GNU libiconv interpret
+ the empty string as denoting "the locale's character encoding",
+ thus GNU libiconv would call this function a second time. */
+ if (codeset[0] == '\0')
+ /* Default to Latin-1, for backward compatibility with Guile 1.8. */
+ codeset = "ISO-8859-1";
+
+ return codeset;
+}

8
lib/localcharset.c
View file

@ -589,9 +589,8 @@ environ_locale_charset (void)
strcpy (buf, "ASCII");
return buf;
}
/* Resolve through the charset.alias file. */
codeset = locale;
else
codeset = "";
}
else
codeset = "";
@ -611,7 +610,8 @@ environ_locale_charset (void)
the empty string as denoting "the locale's character encoding",
thus GNU libiconv would call this function a second time. */
if (codeset[0] == '\0')
codeset = "ASCII";
/* Default to Latin-1, for backward compatibility with Guile 1.8. */
codeset = "ISO-8859-1";
return codeset;
}

208
libguile/posix.c
View file

@ -1254,6 +1254,201 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
return scm_from_int (pid);
}
#undef FUNC_NAME
/* Since Guile uses threads, we have to be very careful to avoid calling
functions that are not async-signal-safe in the child. That's why
this function is implemented in C. */
static SCM
scm_open_process (SCM mode, SCM prog, SCM args)
#define FUNC_NAME "open-process"
{
long mode_bits;
int reading, writing;
int c2p[2]; /* Child to parent. */
int p2c[2]; /* Parent to child. */
int in = -1, out = -1, err = -1;
int pid;
char *exec_file;
char **exec_argv;
int max_fd = 1024;
exec_file = scm_to_locale_string (prog);
exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
mode_bits = scm_i_mode_bits (mode);
reading = mode_bits & SCM_RDNG;
writing = mode_bits & SCM_WRTNG;
if (reading)
{
if (pipe (c2p))
{
int errno_save = errno;
free (exec_file);
errno = errno_save;
SCM_SYSERROR;
}
out = c2p[1];
}
if (writing)
{
if (pipe (p2c))
{
int errno_save = errno;
free (exec_file);
if (reading)
{
close (c2p[0]);
close (c2p[1]);
}
errno = errno_save;
SCM_SYSERROR;
}
in = p2c[0];
}
{
SCM port;
if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
err = SCM_FPORT_FDES (port);
if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
out = SCM_FPORT_FDES (port);
if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
in = SCM_FPORT_FDES (port);
}
#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE)
{
struct rlimit lim = { 0, 0 };
if (getrlimit (RLIMIT_NOFILE, &lim) == 0)
max_fd = lim.rlim_cur;
}
#endif
pid = fork ();
if (pid == -1)
{
int errno_save = errno;
free (exec_file);
if (reading)
{
close (c2p[0]);
close (c2p[1]);
}
if (writing)
{
close (p2c[0]);
close (p2c[1]);
}
errno = errno_save;
SCM_SYSERROR;
}
if (pid)
/* Parent. */
{
SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port;
/* There is no sense in catching errors on close(). */
if (reading)
{
close (c2p[1]);
read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe);
scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
}
if (writing)
{
close (p2c[0]);
write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
}
if (reading && writing)
{
static SCM make_rw_port = SCM_BOOL_F;
if (scm_is_false (make_rw_port))
make_rw_port = scm_c_private_variable ("ice-9 popen",
"make-rw-port");
port = scm_call_2 (scm_variable_ref (make_rw_port),
read_port, write_port);
}
else if (reading)
port = read_port;
else if (writing)
port = write_port;
else
port = scm_sys_make_void_port (mode);
return scm_cons (port, scm_from_int (pid));
}
/* The child. */
if (reading)
close (c2p[0]);
if (writing)
close (p2c[1]);
/* Close all file descriptors in ports inherited from the parent
except for in, out, and err. Heavy-handed, but robust. */
while (max_fd--)
if (max_fd != in && max_fd != out && max_fd != err)
close (max_fd);
/* Ignore errors on these open() calls. */
if (in == -1)
in = open ("/dev/null", O_RDONLY);
if (out == -1)
out = open ("/dev/null", O_WRONLY);
if (err == -1)
err = open ("/dev/null", O_WRONLY);
if (in > 0)
{
if (out == 0)
do out = dup (out); while (errno == EINTR);
if (err == 0)
do err = dup (err); while (errno == EINTR);
do dup2 (in, 0); while (errno == EINTR);
close (in);
}
if (out > 1)
{
if (err == 1)
do err = dup (err); while (errno == EINTR);
do dup2 (out, 1); while (errno == EINTR);
close (out);
}
if (err > 2)
{
do dup2 (err, 2); while (errno == EINTR);
close (err);
}
execvp (exec_file,
#ifdef __MINGW32__
/* extra "const" in mingw formals, provokes warning from gcc */
(const char * const *)
#endif
exec_argv);
/* The exec failed! There is nothing sensible to do. */
if (err > 0)
{
char *msg = strerror (errno);
fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
exec_file, msg);
}
_exit (EXIT_FAILURE);
/* Not reached. */
return SCM_BOOL_F;
}
#undef FUNC_NAME
#endif /* HAVE_FORK */
#ifdef __MINGW32__
@ -2084,6 +2279,14 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
#endif /* HAVE_GETHOSTNAME */
#ifdef HAVE_FORK
static void
scm_init_popen (void)
{
scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
}
#endif
void
scm_init_posix ()
{
@ -2172,6 +2375,11 @@ scm_init_posix ()
#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_popen",
(scm_t_extension_init_func) scm_init_popen,
NULL);
}
/*

101
module/ice-9/popen.scm
View file

@ -1,6 +1,6 @@
;; popen emulation, for non-stdio based ports.
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -21,6 +21,10 @@
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
(eval-when (load eval compile)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_popen"))
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
@ -38,100 +42,6 @@
;; a weak hash-table to store the process ids.
(define port/pid-table (make-weak-key-hash-table 31))
(define (ensure-fdes port mode)
(or (false-if-exception (fileno port))
(open-fdes *null-device* mode)))
;; run a process connected to an input, an output or an
;; input/output port
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
;; returns port/pid pair.
(define (open-process mode prog . args)
(let* ((reading (or (equal? mode OPEN_READ)
(equal? mode OPEN_BOTH)))
(writing (or (equal? mode OPEN_WRITE)
(equal? mode OPEN_BOTH)))
(c2p (if reading (pipe) #f)) ; child to parent
(p2c (if writing (pipe) #f))) ; parent to child
(if c2p (setvbuf (cdr c2p) _IONBF))
(if p2c (setvbuf (cdr p2c) _IONBF))
(let ((pid (primitive-fork)))
(cond ((= pid 0)
;; child
(ensure-batch-mode!)
;; select the three file descriptors to be used as
;; standard descriptors 0, 1, 2 for the new
;; process. They are pipes to/from the parent or taken
;; from the current Scheme input/output/error ports if
;; possible.
(let ((input-fdes (if writing
(fileno (car p2c))
(ensure-fdes (current-input-port)
O_RDONLY)))
(output-fdes (if reading
(fileno (cdr c2p))
(ensure-fdes (current-output-port)
O_WRONLY)))
(error-fdes (ensure-fdes (current-error-port)
O_WRONLY)))
;; close all file descriptors in ports inherited from
;; the parent except for the three selected above.
;; this is to avoid causing problems for other pipes in
;; the parent.
;; use low-level system calls, not close-port or the
;; scsh routines, to avoid side-effects such as
;; flushing port buffers or evicting ports.
(port-for-each (lambda (pt-entry)
(false-if-exception
(let ((pt-fileno (fileno pt-entry)))
(if (not (or (= pt-fileno input-fdes)
(= pt-fileno output-fdes)
(= pt-fileno error-fdes)))
(close-fdes pt-fileno))))))
;; Copy the three selected descriptors to the standard
;; descriptors 0, 1, 2, if not already there
(cond ((not (= input-fdes 0))
(if (= output-fdes 0)
(set! output-fdes (dup->fdes 0)))
(if (= error-fdes 0)
(set! error-fdes (dup->fdes 0)))
(dup2 input-fdes 0)
;; it's possible input-fdes is error-fdes
(if (not (= input-fdes error-fdes))
(close-fdes input-fdes))))
(cond ((not (= output-fdes 1))
(if (= error-fdes 1)
(set! error-fdes (dup->fdes 1)))
(dup2 output-fdes 1)
;; it's possible output-fdes is error-fdes
(if (not (= output-fdes error-fdes))
(close-fdes output-fdes))))
(cond ((not (= error-fdes 2))
(dup2 error-fdes 2)
(close-fdes error-fdes)))
(apply execlp prog prog args)))
(else
;; parent
(if c2p (close-port (cdr c2p)))
(if p2c (close-port (car p2c)))
(cons (cond ((not writing) (car c2p))
((not reading) (cdr p2c))
(else (make-rw-port (car c2p)
(cdr p2c))))
pid))))))
(define (open-pipe* mode command . args)
"Executes the program @var{command} with optional arguments
@var{args} (all strings) in a subprocess.
@ -213,3 +123,4 @@ information on how to interpret this value."
(define (open-input-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
(open-pipe command OPEN_BOTH))

87
module/language/tree-il/analyze.scm
View file

@ -1353,16 +1353,41 @@ accurate information is missing from a given `tree-il' element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
(define (const-fmt x)
;; Return the literal format pattern for X, or #f.
(define (proc-ref? exp proc special-name env)
"Return #t when EXP designates procedure PROC in ENV. As a last
resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(match exp
(($ <toplevel-ref> _ name)
(let ((var (false-if-exception (module-variable env name))))
(if var
(eq? (variable-ref var) proc)
(eq? name special-name)))) ; special hack to support local aliases
(($ <module-ref> _ module name public?)
(let ((m (false-if-exception (if public?
(resolve-interface module)
(resolve-module module)))))
(and m (eq? (false-if-exception (module-ref module name)) proc))))
(_ #f)))
(define gettext? (cut proc-ref? <> gettext '_ <>))
(define ngettext? (cut proc-ref? <> ngettext 'N_ <>))
(define (const-fmt x env)
;; Return the literal format string for X, or #f.
(match x
(($ <const> _ exp)
(($ <const> _ (? string? exp))
exp)
(($ <call> _
(or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
(($ <const> _ (and (? string?) fmt))))
(($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
(($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
;; TODO: Check whether the singular and plural strings have the
;; same format escapes.
fmt)
(_ #f)))
(define format-analysis
@ -1377,36 +1402,38 @@ accurate information is missing from a given `tree-il' element."
(define (check-format-args args loc)
(pmatch args
((,port ,fmt . ,rest)
(guard (const-fmt fmt))
(guard (const-fmt fmt env))
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
(let ((fmt (const-fmt fmt))
(let ((fmt (const-fmt fmt env))
(count (length rest)))
(if (string? fmt)
(catch &syntax-error
(lambda ()
(let-values (((min max)
(format-string-argument-count fmt)))
(and min max
(or (and (or (eq? min 'any) (>= count min))
(or (eq? max 'any) (<= count max)))
(warning 'format loc 'wrong-format-arg-count
fmt min max count)))))
(lambda (_ key)
(warning 'format loc 'syntax-error key fmt)))
(warning 'format loc 'wrong-format-string fmt))))
(catch &syntax-error
(lambda ()
(let-values (((min max)
(format-string-argument-count fmt)))
(and min max
(or (and (or (eq? min 'any) (>= count min))
(or (eq? max 'any) (<= count max)))
(warning 'format loc 'wrong-format-arg-count
fmt min max count)))))
(lambda (_ key)
(warning 'format loc 'syntax-error key fmt)))))
((,port ,fmt . ,rest)
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
;; Warn on non-literal format strings, unless they refer to a
;; lexical variable named "fmt".
(if (record-case fmt
((<lexical-ref> name)
(not (eq? name 'fmt)))
(else #t))
(warning 'format loc 'non-literal-format-string)))
(match fmt
(($ <const> loc* (? (negate string?) fmt))
(warning 'format (or loc* loc) 'wrong-format-string fmt))
;; Warn on non-literal format strings, unless they refer to
;; a lexical variable named "fmt".
(($ <lexical-ref> _ fmt)
#t)
((? (negate const?))
(warning 'format loc 'non-literal-format-string))))
(else
(warning 'format loc 'wrong-num-args (length args)))))
@ -1436,8 +1463,8 @@ accurate information is missing from a given `tree-il' element."
(warning 'format loc 'simple-format fmt
(find (negate (cut memq <> allowed-chars)) opts))
#f))))
((port (($ <const> _ '_) fmt) args ...)
(check-simple-format-args `(,port ,fmt ,args) loc))
((port (= (cut const-fmt <> env) (? string? fmt)) args ...)
(check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc))
(_ #t)))
(define (resolve-toplevel name)

25
module/web/uri.scm
View file

@ -1,6 +1,6 @@
;;;; (web uri) --- URI manipulation tools
;;;;
;;;; Copyright (C) 1997,2001,2002,2010,2011 Free Software Foundation, Inc.
;;;; Copyright (C) 1997,2001,2002,2010,2011,2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -89,9 +89,9 @@ consistency checks to make sure that the constructed URI is valid."
;; 3490), and non-ASCII host names.
;;
(define ipv4-regexp
(make-regexp "^([0-9.]+)"))
(make-regexp "^([0-9.]+)$"))
(define ipv6-regexp
(make-regexp "^\\[([0-9a-fA-F:]+)\\]+"))
(make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
(define domain-label-regexp
(make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
(define top-label-regexp
@ -100,18 +100,17 @@ consistency checks to make sure that the constructed URI is valid."
(define (valid-host? host)
(cond
((regexp-exec ipv4-regexp host)
=> (lambda (m)
(false-if-exception (inet-pton AF_INET (match:substring m 1)))))
(false-if-exception (inet-pton AF_INET host)))
((regexp-exec ipv6-regexp host)
=> (lambda (m)
(false-if-exception (inet-pton AF_INET6 (match:substring m 1)))))
(false-if-exception (inet-pton AF_INET6 host)))
(else
(let ((labels (reverse (string-split host #\.))))
(and (pair? labels)
(regexp-exec top-label-regexp (car labels))
(and-map (lambda (label)
(regexp-exec domain-label-regexp label))
(cdr labels)))))))
(let lp ((start 0))
(let ((end (string-index host #\. start)))
(if end
(and (regexp-exec domain-label-regexp
(substring host start end))
(lp (1+ end)))
(regexp-exec top-label-regexp host start)))))))
(define userinfo-pat
"[a-zA-Z0-9_.!~*'();:&=+$,-]+")

5
test-suite/standalone/Makefile.am
View file

@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
## 2011 Free Software Foundation, Inc.
## 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -85,6 +85,9 @@ EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
check_SCRIPTS += test-command-line-encoding
TESTS += test-command-line-encoding
check_SCRIPTS += test-command-line-encoding2
TESTS += test-command-line-encoding2
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}

20
test-suite/standalone/test-command-line-encoding2 Executable file
View file

@ -0,0 +1,20 @@
#!/bin/sh
# Choose a locale name that lacks a dot followed by the encoding name.
# This should not confuse `environ_locale_charset'.
# See <http://bugs.gnu.org/10742> for the original bug report.
LC_ALL="en_US"
export LC_ALL
unset LANG
unset LC_CTYPE
exec guile -q -s "$0" "hello"
!#
;; Make sure our argument was suitable decoded.
(exit (string=? (cadr (program-arguments)) "hello"))
;; Local Variables:
;; mode: scheme
;; coding: iso-8859-1
;; End:

42
test-suite/tests/tree-il.test
View file

@ -2172,12 +2172,34 @@
"non-literal format string")))))
(pass-if "non-literal format string using gettext"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (gettext "~A ~A!") "hello" "world")
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "non-literal format string using gettext as _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
(lambda ()
(compile '(format #t
(ngettext "~a thing" "~a things" n "dom") n)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "non-literal format string using ngettext as N_"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (N_ "~a thing" "~a things" n) n)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
@ -2219,7 +2241,7 @@
(pass-if "one missing argument, gettext"
(let ((w (call-with-warnings
(lambda ()
(compile '(format some-port (_ "foo ~A~%"))
(compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2550,5 +2572,23 @@
(compile '(simple-format #t "foo ~x~%" 16)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
(pass-if "unsupported, gettext"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
(pass-if "unsupported, ngettext"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option"))))))))

6
test-suite/tests/web-uri.test
View file

@ -1,6 +1,6 @@
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -143,6 +143,10 @@
(uri=? (string->uri "http://foo:/")
#:scheme 'http #:host "foo" #:path "/"))
(pass-if "http://2012.jsconf.us/"
(uri=? (string->uri "http://2012.jsconf.us/")
#:scheme 'http #:host "2012.jsconf.us" #:path "/"))
(pass-if "http://foo:not-a-port"
(not (string->uri "http://foo:not-a-port")))