mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Merge commit 'f78a1ccede'
This commit is contained in:
Andy Wingo
commit
0bdd43515e
21 changed files with 230 additions and 73 deletions
|
|
@ -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 };".
|
||||
|
|
|
|||
|
|
@ -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
|
||||
@deffnx {Scheme Procedure} vhash-fold-right proc vhash
|
||||
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)}.
|
||||
@deffn {Scheme Procedure} vhash-fold proc init vhash
|
||||
@deffnx {Scheme Procedure} vhash-fold-right proc init vhash
|
||||
Fold over the key/value elements of @var{vhash} in the given direction,
|
||||
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]]
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)'.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
the standard Guile API. @code{SCM_VALIDATE_SHAPE} is a macro that you
|
||||
should define as part of your SMOB definition: it checks that the
|
||||
passed parameter is of the expected type. This is needed to guard
|
||||
In this code, @code{scm_assert_smob_type}, @code{SCM_SMOB_DATA}, and
|
||||
@code{scm_from_bool} are from the standard Guile API. We assume that
|
||||
@code{shape_tag} was given to us when we made the shape SMOB type, using
|
||||
@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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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__ */
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(issue-deprecation-warning
|
||||
"Sequences of zero expressions are deprecated. Use *unspecified*.")
|
||||
(expand-void)))))
|
||||
(syntax-violation #f "sequence of zero expressions"
|
||||
(source-wrap e w s mod)))))
|
||||
((local-syntax-form)
|
||||
(expand-local-syntax value e r w s mod expand-sequence))
|
||||
((eval-when-form)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
"Fold over the key/pair elements of @var{vhash}. For each pair call
|
||||
@var{proc} as @code{(@var{proc} key value result)}."
|
||||
(define (vhash-fold proc init vhash)
|
||||
"Fold over the key/pair elements of @var{vhash} from left to right, 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}."
|
||||
(vlist-fold (lambda (key+value result)
|
||||
(proc (car key+value) (cdr key+value)
|
||||
result))
|
||||
seed
|
||||
init
|
||||
vhash))
|
||||
|
||||
(define (vhash-fold-right proc seed vhash)
|
||||
"Fold over the key/pair elements of @var{vhash}, starting from the 0th
|
||||
element. For each pair call @var{proc} as @code{(@var{proc} key value
|
||||
result)}."
|
||||
(define (vhash-fold-right proc init vhash)
|
||||
"Fold over the key/pair elements of @var{vhash} from right to left, 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}."
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(if (and
|
||||
(eqv? (string-ref filename (- (string-length filename) 1)) #\c)
|
||||
(eqv? (string-ref filename (- (string-length filename) 2)) #\.))
|
||||
(let ((file (string-append dirname "/" filename)))
|
||||
(if (and (file-exists? file)
|
||||
(egrep "SEEK_(SET|CUR|END)" file)
|
||||
(not (egrep "unistd.h" file)))
|
||||
(fail file)))))))
|
||||
((eof-object? filename))
|
||||
(if (and
|
||||
(eqv? (string-ref filename (- (string-length filename) 1)) #\c)
|
||||
(eqv? (string-ref filename (- (string-length filename) 2)) #\.))
|
||||
(let ((file (string-append dirname "/" filename)))
|
||||
(if (and (file-exists? file)
|
||||
(egrep "SEEK_(SET|CUR|END)" file))
|
||||
(pass-if file (egrep "unistd.h" file))))))))
|
||||
|
||||
;;; A rough conservative test to check that all source files
|
||||
;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue