Merge commit 'f78a1ccede'

configure.ac

@@ -655,7 +655,7 @@ AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64])
 #   langinfo.h, nl_types.h - SuS v2
 #   sched.h - missing on MinGW
 #
-AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h process.h string.h \
+AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h memory.h process.h string.h \
 regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
 sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
 sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
@@ -775,6 +775,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime
 #   sys/param.h - not in mingw
 #   pthread.h - only available with pthreads.  ACX_PTHREAD doesn't
 #       check this specifically, we need it for the timespec test below.
+#   pthread_np.h - available on FreeBSD
 #   sethostname - the function itself check because it's not in mingw,
 #       the DECL is checked because Solaris 10 doens't have in any header
 #   hstrerror - on Tru64 5.1b the symbol is available in libc but the
@@ -782,7 +783,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime
 #   cuserid - on Tru64 5.1b the declaration is documented to be available
 #       only with `_XOPEN_SOURCE' or some such.
 #
-AC_CHECK_HEADERS([crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h sys/mman.h])
+AC_CHECK_HEADERS([crypt.h netdb.h pthread.h pthread_np.h sys/param.h sys/resource.h sys/file.h sys/mman.h])
 AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
 AC_CHECK_DECLS([sethostname, hstrerror, cuserid])
 
@@ -1364,9 +1365,11 @@ case "$with_threads" in
     #         all; not present on MacOS X or Solaris 10
     #     pthread_get_stackaddr_np - "np" meaning "non portable" says it
     #         all; specific to MacOS X
+    #     pthread_attr_get_np - "np" meaning "non portable" says it
+    #         all; specific to FreeBSD
     #     pthread_sigmask - not available on mingw
     #
-    AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_sigmask)
+    AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask)
 
     # On past versions of Solaris, believe 8 through 10 at least, you
     # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };".

doc/ref/api-compound.texi

@@ -3293,10 +3293,13 @@ Again the choice of @var{hash-proc} must be consistent with previous calls to
 @code{vhash-cons}.
 @end deffn
 
-@deffn {Scheme Procedure} vhash-fold proc vhash
+@deffn {Scheme Procedure} vhash-fold proc init vhash
-@deffnx {Scheme Procedure} vhash-fold-right proc vhash
+@deffnx {Scheme Procedure} vhash-fold-right proc init vhash
-Fold over the key/value elements of @var{vhash} in the given direction.
+Fold over the key/value elements of @var{vhash} in the given direction,
-For each pair call @var{proc} as @code{(@var{proc} key value result)}.
+with each call to @var{proc} having the form @code{(@var{proc} key value
+result)}, where @var{result} is the result of the previous call to
+@var{proc} and @var{init} the value of @var{result} for the first call
+to @var{proc}.
 @end deffn
 
 @deffn {Scheme Procedure} vhash-fold* proc init key vhash [equal? [hash]]

doc/ref/api-data.texi

@@ -3366,7 +3366,7 @@ Change every character in @var{str} between @var{start} and
 @var{end} to @var{fill}.
 
 @lisp
-(define y "abcdefg")
+(define y (string-copy "abcdefg"))
 (substring-fill! y 1 3 #\r)
 y
 @result{} "arrdefg"

doc/ref/api-foreign.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008,
-@c   2009, 2010, 2011 Free Software Foundation, Inc.
+@c   2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Foreign Function Interface
@@ -680,7 +680,7 @@ pointers to manipulate them.  We could write:
   (lambda (b p)
     (format p "#<bottle of ~a ~x>"
             (bottle-contents b)
-            (pointer-address (unwrap-foo b)))))
+            (pointer-address (unwrap-bottle b)))))
 
 (define grab-bottle
   ;; Wrapper for `bottle_t *grab (void)'.

doc/ref/libguile-program.texi

@@ -279,13 +279,12 @@ As an example, here is a possible implementation of the @code{square?}
 primitive:
 
 @lisp
-#define FUNC_NAME "square?"
 static SCM square_p (SCM shape)
 @{
   struct dia_guile_shape * guile_shape;
 
   /* Check that arg is really a shape SMOB. */
-  SCM_VALIDATE_SHAPE (SCM_ARG1, shape);
+  scm_assert_smob_type (shape_tag, shape);
 
   /* Access Scheme-specific shape structure. */
   guile_shape = SCM_SMOB_DATA (shape);
@@ -295,7 +294,6 @@ static SCM square_p (SCM shape)
   return scm_from_bool (guile_shape->c_shape &&
                         (guile_shape->c_shape->type == DIA_SQUARE));
 @}
-#undef FUNC_NAME
 @end lisp
 
 Notice how easy it is to chain through from the @code{SCM shape}
@@ -303,10 +301,11 @@ parameter that @code{square_p} receives --- which is a SMOB --- to the
 Scheme-specific structure inside the SMOB, and thence to the underlying
 C structure for the shape.
 
-In this code, @code{SCM_SMOB_DATA} and @code{scm_from_bool} are from
+In this code, @code{scm_assert_smob_type}, @code{SCM_SMOB_DATA}, and
-the standard Guile API.  @code{SCM_VALIDATE_SHAPE} is a macro that you
+@code{scm_from_bool} are from the standard Guile API.  We assume that
-should define as part of your SMOB definition: it checks that the
+@code{shape_tag} was given to us when we made the shape SMOB type, using
-passed parameter is of the expected type.  This is needed to guard
+@code{scm_make_smob_type}.  The call to @code{scm_assert_smob_type}
+ensures that @var{shape} is indeed a shape.  This is needed to guard
 against Scheme code using the @code{square?} procedure incorrectly, as
 in @code{(square? "hello")}; Scheme's latent typing means that usage
 errors like this must be caught at run time.

libguile/gc-malloc.c

@@ -26,6 +26,7 @@
 #include <stdio.h>
 #include <errno.h>
 #include <string.h>
+#include <stdlib.h>
 
 #ifdef __ia64__
 #include <ucontext.h>
@@ -57,10 +58,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 #include "libguile/debug-malloc.h"
 #endif
 
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
 #endif

libguile/gc.c

@@ -27,6 +27,7 @@
 #include <stdio.h>
 #include <errno.h>
 #include <string.h>
+#include <stdlib.h>
 #include <math.h>
 
 #ifdef __ia64__
@@ -64,10 +65,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 #include "libguile/debug-malloc.h"
 #endif
 
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
 #endif

libguile/generalized-vectors.c

@@ -131,9 +131,11 @@ SCM
 scm_c_generalized_vector_ref (SCM v, size_t idx)
 {
   scm_t_array_handle h;
+  size_t pos;
   SCM ret;
   scm_generalized_vector_get_handle (v, &h);
-  ret = h.impl->vref (&h, idx);
+  pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
+  ret = h.impl->vref (&h, pos);
   scm_array_handle_release (&h);
   return ret;
 }
@@ -152,8 +154,10 @@ void
 scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
 {
   scm_t_array_handle h;
+  size_t pos;
   scm_generalized_vector_get_handle (v, &h);
-  h.impl->vset (&h, idx, val);
+  pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
+  h.impl->vset (&h, pos, val);
   scm_array_handle_release (&h);
 }
 

libguile/mallocs.c

@@ -24,15 +24,14 @@
 #  include <config.h>
 #endif
 
+#include <stdlib.h>
+
 #include "libguile/_scm.h"
 #include "libguile/ports.h"
 #include "libguile/smob.h"
 
 #include "libguile/mallocs.h"
 
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
 #endif

libguile/smob.c

@@ -23,6 +23,7 @@
 #endif
 
 #include <stdio.h>
+#include <stdlib.h>
 #include <errno.h>
 
 #include "libguile/_scm.h"
@@ -33,10 +34,6 @@
 #include "libguile/objcodes.h"
 #include "libguile/programs.h"
 
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
 #include "libguile/smob.h"
 
 #include "libguile/bdw-gc.h"

libguile/threads.c

@@ -38,6 +38,10 @@
 #include <sys/time.h>
 #endif
 
+#if HAVE_PTHREAD_NP_H
+# include <pthread_np.h>
+#endif
+
 #include <assert.h>
 #include <fcntl.h>
 #include <nproc.h>
@@ -140,6 +144,29 @@ get_thread_stack_base ()
   return pthread_get_stackaddr_np (pthread_self ());
 }
 
+#elif HAVE_PTHREAD_ATTR_GET_NP
+/* This one is for FreeBSD 9.  */
+static void *
+get_thread_stack_base ()
+{
+  pthread_attr_t attr;
+  void *start, *end;
+  size_t size;
+
+  pthread_attr_init (&attr);
+  pthread_attr_get_np (pthread_self (), &attr);
+  pthread_attr_getstack (&attr, &start, &size);
+  pthread_attr_destroy (&attr);
+
+  end = (char *)start + size;
+
+#if SCM_STACK_GROWS_UP
+  return start;
+#else
+  return end;
+#endif
+}
+
 #else 
 #error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl.  Please upgrade to libgc >= 7.1.
 #endif
@@ -2216,6 +2243,21 @@ scm_ia64_ar_bsp (const void *opaque)
   return (void *) ctx->uc_mcontext.sc_ar_bsp;
 }
 # endif /* linux */
+# ifdef __FreeBSD__
+#  include <ucontext.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+  return (void *)0x8000000000000000;
+}
+void *
+scm_ia64_ar_bsp (const void *opaque)
+{
+  const ucontext_t *ctx = opaque;
+  return (void *)(ctx->uc_mcontext.mc_special.bspstore
+                  + ctx->uc_mcontext.mc_special.ndirty);
+}
+# endif /* __FreeBSD__ */
 #endif /* __ia64__ */
 
 

module/ice-9/psyntax.scm

@@ -1,7 +1,8 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;; 	Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 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
 ;;;; License as published by the Free Software Foundation; either
@@ -1321,10 +1322,8 @@
            (syntax-case e ()
              ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
              ((_)
-              (begin
+              (syntax-violation #f "sequence of zero expressions"
-                (issue-deprecation-warning
+                                (source-wrap e w s mod)))))
-                 "Sequences of zero expressions are deprecated.  Use *unspecified*.")
-                (expand-void)))))
           ((local-syntax-form)
            (expand-local-syntax value e r w s mod expand-sequence))
           ((eval-when-form)

module/ice-9/vlist.scm

@@ -545,23 +545,26 @@ with @var{equal?}."
 (define vhash-delq (cut vhash-delete <> <> eq? hashq))
 (define vhash-delv (cut vhash-delete <> <> eqv? hashv))
 
-(define (vhash-fold proc seed vhash)
+(define (vhash-fold proc init vhash)
-  "Fold over the key/pair elements of @var{vhash}.  For each pair call
+  "Fold over the key/pair elements of @var{vhash} from left to right, with
-@var{proc} as @code{(@var{proc} key value result)}."
+each call to @var{proc} having the form @code{(@var{proc} key value result)},
+where @var{result} is the result of the previous call to @var{proc} and
+@var{init} the value of @var{result} for the first call to @var{proc}."
   (vlist-fold (lambda (key+value result)
                 (proc (car key+value) (cdr key+value)
                       result))
-              seed
+              init
               vhash))
 
-(define (vhash-fold-right proc seed vhash)
+(define (vhash-fold-right proc init vhash)
-  "Fold over the key/pair elements of @var{vhash}, starting from the 0th
+  "Fold over the key/pair elements of @var{vhash} from right to left, with
-element.  For each pair call @var{proc} as @code{(@var{proc} key value
+each call to @var{proc} having the form @code{(@var{proc} key value result)},
-result)}."
+where @var{result} is the result of the previous call to @var{proc} and
+@var{init} the value of @var{result} for the first call to @var{proc}."
   (vlist-fold-right (lambda (key+value result)
                       (proc (car key+value) (cdr key+value)
                             result))
-                    seed
+                    init
                     vhash))
 
 (define* (alist->vhash alist #:optional (hash hash))

module/language/tree-il/analyze.scm

@@ -359,7 +359,8 @@
       (else '())))
   
   ;; allocation: sym -> {lambda -> address}
-  ;;             lambda -> (nlocs labels . free-locs)
+  ;;             lambda -> (labels . free-locs)
+  ;;             lambda-case -> (gensym . nlocs)
   (define allocation (make-hash-table))
   
   (define (allocate! x proc n)

module/system/base/compile.scm

@@ -99,7 +99,7 @@
 ;;; files, either you know where they should go, in which case you tell
 ;;; compile-file explicitly, as in the srcdir != builddir case; or you
 ;;; don't know, in which case this function is called, and we just put
-;;; them in your own ccache dir in ~/.guile-ccache.
+;;; them in your own ccache dir in ~/.cache/guile/ccache.
 ;;;
 ;;; See also boot-9.scm:load.
 (define (compiled-file-name file)

module/web/http.scm

@@ -1240,22 +1240,28 @@ phrase\"."
 (declare-key-value-list-header! "Cache-Control"
   (lambda (k v-str)
     (case k
-      ((max-age max-stale min-fresh s-maxage)
+      ((max-age min-fresh s-maxage)
        (parse-non-negative-integer v-str))
+      ((max-stale)
+       (and v-str (parse-non-negative-integer v-str)))
       ((private no-cache)
        (and v-str (split-header-names v-str)))
       (else v-str)))
   (lambda (k v)
     (case k
-      ((max-age max-stale min-fresh s-maxage)
+      ((max-age min-fresh s-maxage)
        (non-negative-integer? v))
+      ((max-stale)
+       (or (not v) (non-negative-integer? v)))
       ((private no-cache)
        (or (not v) (list-of-header-names? v)))
+      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+       (not v))
       (else
-       (not v))))
+       (or (not v) (string? v)))))
   (lambda (k v port)
     (cond
-     ((string? v) (display v port))
+     ((string? v) (default-val-writer k v port))
      ((pair? v)
       (display #\" port)
       (write-header-list v port)

test-suite/tests/arrays.test

@@ -1,6 +1,6 @@
 ;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
 ;;;;
-;;;; Copyright 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright 2004, 2006, 2009, 2010, 2011 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
@@ -606,3 +606,19 @@
                                (lambda (i) (list i i))
                                '(0 2))
             #(a e i))))
+
+;;;
+;;; slices as generalized vectors
+;;;
+
+(let ((array #2u32((0 1) (2 3))))
+  (define (array-row a i)
+    (make-shared-array a (lambda (j) (list i j))
+                       (cadr (array-dimensions a))))
+  (with-test-prefix "generalized vector slices"
+    (pass-if (equal? (array-row array 1)
+                     #u32(2 3)))
+    (pass-if (equal? (array-ref (array-row array 1) 0)
+                     2))
+    (pass-if (equal? (generalized-vector-ref (array-row array 1) 0)
+                     2))))

test-suite/tests/c-api.test

@@ -1,22 +1,24 @@
 ;;;; c-api.test --- complementary test suite for the c-api     -*- scheme -*-
 ;;;; MDJ 990915 <djurfeldt@nada.kth.se>
 ;;;;
-;;;; 	Copyright (C) 1999, 2006 Free Software Foundation, Inc.
+;;;;   Copyright (C) 1999, 2006, 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
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
+(use-modules (test-suite lib))
+
 (define srcdir (cdr (assq 'srcdir %guile-build-info)))
 
 (define (egrep string filename)
@@ -25,15 +27,14 @@
 (define (seek-offset-test dirname)
   (let ((dir (opendir dirname)))
     (do ((filename (readdir dir) (readdir dir)))
-	((eof-object? filename))
+        ((eof-object? filename))
-      (if (and 
+      (if (and
-	   (eqv? (string-ref filename (- (string-length filename) 1)) #\c)
+           (eqv? (string-ref filename (- (string-length filename) 1)) #\c)
-	   (eqv? (string-ref filename (- (string-length filename) 2)) #\.))
+           (eqv? (string-ref filename (- (string-length filename) 2)) #\.))
-	  (let ((file (string-append dirname "/" filename)))
+          (let ((file (string-append dirname "/" filename)))
-	    (if (and (file-exists? file)
+            (if (and (file-exists? file)
-		     (egrep "SEEK_(SET|CUR|END)" file)
+                     (egrep "SEEK_(SET|CUR|END)" file))
-		     (not (egrep "unistd.h" file)))
+                (pass-if file (egrep "unistd.h" file))))))))
-		(fail file)))))))
 
 ;;; A rough conservative test to check that all source files
 ;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.

test-suite/tests/ramap.test

@@ -19,6 +19,14 @@
 (define-module (test-suite test-ramap)
   #:use-module (test-suite lib))
 
+(define (array-row a i)
+  (make-shared-array a (lambda (j) (list i j))
+                       (cadr (array-dimensions a))))
+
+(define (array-col a j)
+  (make-shared-array a (lambda (i) (list i j))
+                       (car (array-dimensions a))))
+
 ;;;
 ;;; array-index-map!
 ;;;
@@ -183,4 +191,67 @@
     (pass-if "+"
       (let ((a (make-array #f 4)))
 	(array-map! a + #(1 2 3 4) #(5 6 7 8))
-	(equal? a #(6 8 10 12))))))
+	(equal? a #(6 8 10 12))))
+        
+    (pass-if "noncompact arrays 1"
+      (let ((a #2((0 1) (2 3)))
+            (c #(0 0)))
+        (begin
+          (array-map! c + (array-row a 1) (array-row a 1))
+          (array-equal? c #(4 6)))))
+          
+    (pass-if "noncompact arrays 2"
+      (let ((a #2((0 1) (2 3)))
+            (c #(0 0)))
+        (begin
+          (array-map! c + (array-col a 1) (array-col a 1))
+          (array-equal? c #(2 6)))))
+          
+    (pass-if "noncompact arrays 3"
+      (let ((a #2((0 1) (2 3)))
+            (c #(0 0)))
+        (begin
+          (array-map! c + (array-col a 1) (array-row a 1))
+          (array-equal? c #(3 6)))))
+          
+    (pass-if "noncompact arrays 4"
+      (let ((a #2((0 1) (2 3)))
+            (c #(0 0)))
+        (begin
+          (array-map! c + (array-col a 1) (array-row a 1))
+          (array-equal? c #(3 6)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+  (with-test-prefix "3 sources"
+    (pass-if "noncompact arrays 1"
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+        (equal? l '((3 3 3) (2 2 2)))))
+          
+    (pass-if "noncompact arrays 2"
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+        (equal? l '((3 3 3) (2 2 1)))))
+          
+    (pass-if "noncompact arrays 3"
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+        (equal? l '((3 3 3) (2 1 1)))))
+          
+    (pass-if "noncompact arrays 4"
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (rec (lambda args (set! l (cons args l)))))
+        (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+        (equal? l '((3 2 3) (1 0 2)))))))

test-suite/tests/syntax.test

@@ -1,7 +1,8 @@
 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 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
 ;;;; License as published by the Free Software Foundation; either
@@ -88,7 +89,7 @@
     ((_ name pat exp)
      (pass-if name
        (catch 'syntax-error
-         (lambda () exp (error "expected uri-error exception"))
+         (lambda () exp (error "expected syntax-error exception"))
          (lambda (k who what where form . maybe-subform)
            (if (if (pair? pat)
                    (and (eq? who (car pat))

test-suite/tests/web-http.test

@@ -45,6 +45,18 @@
                     val)
             (valid-header? 'sym val))))))
 
+(define-syntax pass-if-round-trip
+  (syntax-rules ()
+    ((_ str)
+     (pass-if (format #f "~s round trip" str)
+       (equal? (call-with-output-string
+                (lambda (port)
+                  (call-with-values
+                      (lambda () (read-header (open-input-string str)))
+                    (lambda (sym val)
+                      (write-header sym val port)))))
+               str)))))
+
 (define-syntax pass-if-any-error
   (syntax-rules ()
     ((_ sym str)
@@ -83,6 +95,12 @@
                  '((private . (foo))))
   (pass-if-parse cache-control "no-cache,max-age=10"
                  '(no-cache (max-age . 10)))
+  (pass-if-parse cache-control "max-stale" '(max-stale))
+  (pass-if-parse cache-control "max-stale=10" '((max-stale . 10)))
+  (pass-if-round-trip "Cache-Control: acme-cache-extension\r\n")
+  (pass-if-round-trip "Cache-Control: acme-cache-extension=20\r\n")
+  (pass-if-round-trip "Cache-Control: acme-cache-extension=100 quux\r\n")
+  (pass-if-round-trip "Cache-Control: acme-cache-extension=\"100, quux\"\r\n")
 
   (pass-if-parse connection "close" '(close))
   (pass-if-parse connection "Content-Encoding" '(content-encoding))