From 23f2b9a3de013f093c5913aa381219f09353c676 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 23:15:59 +0000 Subject: [PATCH] merge from 1.8 branch --- ChangeLog | 33 +++++++++ configure.in | 47 +++++------- doc/goops/ChangeLog | 6 ++ doc/goops/Makefile.am | 3 +- doc/goops/hierarchy.pdf | 74 ++++++++++++++++++ doc/ref/ChangeLog | 44 +++++++++++ doc/ref/api-compound.texi | 21 +++++- doc/ref/api-control.texi | 30 ++++++-- doc/ref/api-io.texi | 74 +++++++++++++----- doc/ref/api-scheduling.texi | 2 +- doc/ref/intro.texi | 6 +- doc/ref/misc-modules.texi | 2 +- doc/ref/posix.texi | 42 +++++++++-- doc/ref/srfi-modules.texi | 29 ++++++-- libguile/Makefile.am | 6 +- libguile/eval.c | 3 + libguile/filesys.c | 13 +++- libguile/fports.c | 12 +-- libguile/inline.h | 21 ++++++ libguile/numbers.c | 49 ++++++------ libguile/ports.c | 42 +++++------ libguile/ports.h | 20 ++--- libguile/posix.c | 24 ++++-- libguile/read.c | 2 + libguile/simpos.c | 25 ++++++- libguile/simpos.h | 1 + libguile/throw.c | 5 ++ test-suite/ChangeLog | 23 ++++++ test-suite/tests/numbers.test | 36 ++++++--- test-suite/tests/srfi-1.test | 110 ++++++++++++++++++++++++++- test-suite/tests/srfi-60.test | 1 + test-suite/tests/threads.test | 136 +++++++++++++++++++++++++++------- 32 files changed, 752 insertions(+), 190 deletions(-) create mode 100644 doc/goops/hierarchy.pdf diff --git a/ChangeLog b/ChangeLog index d8100a7af..0f32c104a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -8,6 +8,39 @@ autoconf macro archive, to fix pthread linking problem on Solaris 10, reported by Charles Gagnon. +2006-05-28 Kevin Ryde + + * configure.in (isnan): Remove "#ifdef __MINGW32__, #define isnan + _isnan". Mingw provides isnan as a macro (in math.h), the test + already detects it just fine with no special case. + +2006-05-26 Kevin Ryde + + * configure.in (AC_CHECK_FUNCS): Add ioctl. + (pthread_attr_getstack): Restrict test to pthreads case, to avoid + AC_TRY_RUN when cross-compiling --without-threads. + +2006-05-20 Kevin Ryde + + * configure.in (S_ISLNK): Remove test, leave it to #ifdef in the .c + files. + +2006-05-16 Kevin Ryde + + * configure.in (struct stat st_blocks): Change AC_STRUCT_ST_BLOCKS to + a plain AC_CHECK_MEMBERS, we don't want AC_LIBOBJ(fileblocks) which + the former gives. Remove the commented-out code that was to have + munged fileblocks out of LIBOBJS. This fixes mingw, where the lack of + st_blocks and absense of the fileblocks.c replacement caused build + failure. Reported by "The Senator". + (struct stat st_rdev, st_blksize): Combine into a single + AC_CHECK_MEMBERS. + +2006-04-18 Rob Browning + + * configure.in: Add AC_CONFIG_AUX_DIR([.]) as suggested in the + autotools documentation. + 2006-04-16 Kevin Ryde * configure.in (stat64, off_t): New tests. diff --git a/configure.in b/configure.in index 9146daa9a..1bb3ea7a4 100644 --- a/configure.in +++ b/configure.in @@ -29,6 +29,7 @@ AC_PREREQ(2.53) AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}), m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION})) +AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(GUILE-VERSION) AM_INIT_AUTOMAKE([no-define]) @@ -592,13 +593,14 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # DQNAN - OSF specific # (DINFINITY and DQNAN are actually global variables, not functions) # fesetround - available in C99, but not older systems +# ioctl - not in mingw. # gmtime_r - recent posix, not on old systems # readdir_r - recent posix, not on old systems # stat64 - SuS largefile stuff, not on old systems # sysconf - not on old systems # _NSGetEnviron - Darwin specific # -AC_CHECK_FUNCS([DINFINITY DQNAN ctermid fesetround ftime fchown getcwd geteuid gettimeofday gmtime_r lstat mkdir mknod nice readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex unsetenv _NSGetEnviron]) +AC_CHECK_FUNCS([DINFINITY DQNAN ctermid fesetround ftime fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex unsetenv _NSGetEnviron]) # Reasons for testing: # netdb.h - not in mingw @@ -900,9 +902,6 @@ int main () { return (isinf(0.0) != 0); }], AC_MSG_CHECKING([for isnan]) AC_LINK_IFELSE( [#include -#ifdef __MINGW32__ -#define isnan _isnan -#endif int main () { return (isnan(0.0) != 0); }], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_ISNAN, 1, @@ -919,22 +918,16 @@ then AC_ERROR([No native alloca found.]) fi -AC_CHECK_MEMBERS([struct stat.st_rdev]) -AC_CHECK_MEMBERS([struct stat.st_blksize]) - -AC_STRUCT_ST_BLOCKS - -AC_CACHE_CHECK([for S_ISLNK in sys/stat.h], ac_cv_macro_S_ISLNK, - [AC_TRY_CPP([#include - #ifndef S_ISLNK - #error no S_ISLNK - #endif], - ac_cv_macro_S_ISLNK=yes, - ac_cv_macro_S_ISLNK=no)]) -if test $ac_cv_macro_S_ISLNK = yes; then - AC_DEFINE(HAVE_S_ISLNK, 1, - [Define this if your system defines S_ISLNK in sys/stat.h.]) -fi +# Reasons for checking: +# +# st_rdev +# st_blksize +# st_blocks not in mingw +# +# Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the +# AC_LIBOBJ(fileblocks) replacement which that macro gives. +# +AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks]) AC_STRUCT_TIMEZONE GUILE_STRUCT_UTIMBUF @@ -1039,6 +1032,8 @@ AC_MSG_RESULT($with_threads) ## Check whether pthread_attr_getstack works for the main thread +if test "$with_threads" = pthreads; then + AC_MSG_CHECKING(whether pthread_attr_getstack works for the main thread) old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" @@ -1075,6 +1070,9 @@ AC_DEFINE(PTHREAD_ATTR_GETSTACK_WORKS, [1], [Define when pthread_att_get_stack w CFLAGS="$old_CFLAGS" AC_MSG_RESULT($works) +fi # with_threads=pthreads + + ## Cross building if test "$cross_compiling" = "yes"; then AC_MSG_CHECKING(cc for build) @@ -1137,15 +1135,6 @@ case "$GCC" in ;; esac -## NOTE the code below sets LIBOBJS directly and so is now forbidden -## -- I'm disabling it for now in the hopes that the newer autoconf -## will DTRT -- if not, we need to fix up the sed command to match the -## others... -## -## Remove fileblocks.o from the object list. This file gets added by -## the Autoconf macro AC_STRUCT_ST_BLOCKS. But there is no need. -#LIBOBJS="`echo ${LIBOBJS} | sed 's/fileblocks\.o//g'`" - ## If we're creating a shared library (using libtool!), then we'll ## need to generate a list of .lo files corresponding to the .o files ## given in LIBOBJS. We'll call it LIBLOBJS. diff --git a/doc/goops/ChangeLog b/doc/goops/ChangeLog index 11ff23e5e..f9c43e60b 100644 --- a/doc/goops/ChangeLog +++ b/doc/goops/ChangeLog @@ -1,3 +1,9 @@ +2006-04-21 Kevin Ryde + + * hierarchy.pdf: New file, converted from hierarchy.eps using + epstopdf, to let "make pdf" work. + * Makefile.am: (goops_TEXINFOS): Add it. + 2006-03-08 Ludovic Courts * goops.texi (Slot Options): Note init-value is shared. diff --git a/doc/goops/Makefile.am b/doc/goops/Makefile.am index 1506208c4..1f7d46998 100644 --- a/doc/goops/Makefile.am +++ b/doc/goops/Makefile.am @@ -23,6 +23,7 @@ AUTOMAKE_OPTIONS = gnu info_TEXINFOS = goops.texi -goops_TEXINFOS = goops-tutorial.texi hierarchy.eps hierarchy.png hierarchy.txt +goops_TEXINFOS = goops-tutorial.texi \ + hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf TEXINFO_TEX = ../ref/texinfo.tex diff --git a/doc/goops/hierarchy.pdf b/doc/goops/hierarchy.pdf new file mode 100644 index 000000000..3a19ba4eb --- /dev/null +++ b/doc/goops/hierarchy.pdf @@ -0,0 +1,74 @@ +%PDF-1.3 +%쏢 +5 0 obj +<> +stream +xmn1 E +-Ű(6-][. y)Ҽw(ug_o͇13l_Ml9bi}0(:U[|[-:s"V!zir E/N-#K5n[{ rE#]%w afJA<#"n J=uF$9"TZQAn*PmHXɎ+sd"st 1sU.a--b;{UijdS[gUfv^=(8|ٱGĄyTͦ PZA>cۨCx~2(8endstream +endobj +6 0 obj +660 +endobj +4 0 obj +<> +/Contents 5 0 R +>> +endobj +3 0 obj +<< /Type /Pages /Kids [ +4 0 R +] /Count 1 +>> +endobj +1 0 obj +<> +endobj +7 0 obj +<>endobj +9 0 obj +<> +endobj +10 0 obj +<> +endobj +8 0 obj +<> +endobj +2 0 obj +<>endobj +xref +0 11 +0000000000 65535 f +0000000973 00000 n +0000001186 00000 n +0000000914 00000 n +0000000764 00000 n +0000000015 00000 n +0000000745 00000 n +0000001021 00000 n +0000001121 00000 n +0000001062 00000 n +0000001091 00000 n +trailer +<< /Size 11 /Root 1 0 R /Info 2 0 R +/ID [(Cce3fq\\[)(Cce3fq\\[)] +>> +startxref +1379 +%%EOF diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index d80fba484..7ed1eb778 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -8,6 +8,50 @@ * api-compound.texi (Structure Concepts): Mentioned the behavior of `equal?' for structures. +2006-05-28 Kevin Ryde + + * srfi-modules.texi (SRFI-1 Length Append etc): Add an append-reverse + example. + +2006-05-20 Kevin Ryde + + * api-compound.texi (Pairs): Cross reference SRFI-1 second, third, + fourth. + (List Modification): Cross reference SRFI-1 delete and lset-difference. + (List Searching): Cross reference SRFI-1 member. + (List Mapping): Cross reference SRFI-1 map etc. + (Retrieving Alist Entries): Cross reference SRFI-1 assoc. + + * srfi-modules.texi (SRFI-1 Association Lists): Describe argument + order for "=" procedure. + +2006-05-15 Kevin Ryde + + * posix.texi (Processes): Add primitive-_exit. + +2006-05-10 Kevin Ryde + + * intro.texi (Linking Guile into Programs): Enhance example program, + change scm_str2string to scm_from_locale_string, since scm_str2string + is "discouraged". And check for NULL from getenv since neither + scm_str2string nor scm_from_locale_string can cope with that. + Reported by Frithjof. + +2006-05-09 Kevin Ryde + + * api-control.texi (Multiple Values): In `receive', add an example, + cross ref SRFI-8, tweak wording. + + * api-io.texi (Port Implementation): @defun style for + scm_make_port_type and the various set functions. + + * posix.texi (Ports and File Descriptors): Tweaks to fcntl. + +2006-04-29 Kevin Ryde + + * api-scheduling.texi (Threads): In call-with-new-thread, handler arg + is optional (as of 1.8.0). + 2006-04-15 Kevin Ryde * api-scheduling.texi (System asyncs): "{void *}" in @deffnx to keep diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index c00f3e9a8..3e1699aa0 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -189,6 +189,11 @@ for example @code{caddr} could be defined by @lisp (define caddr (lambda (x) (car (cdr (cdr x))))) @end lisp + +@code{cadr}, @code{caddr} and @code{cadddr} pick out the second, third +or fourth elements of a list, respectively. SRFI-1 provides the same +under the names @code{second}, @code{third} and @code{fourth} +(@pxref{SRFI-1 Selectors}). @end deffn @rnindex set-car! @@ -498,7 +503,7 @@ Return a newly-created copy of @var{lst} with elements @deffn {Scheme Procedure} delv item lst @deffnx {C Function} scm_delv (item, lst) Return a newly-created copy of @var{lst} with elements -@code{eqv?} to @var{item} removed. This procedure mirrors +@code{eqv?} to @var{item} removed. This procedure mirrors @code{memv}: @code{delv} compares elements of @var{lst} against @var{item} with @code{eqv?}. @end deffn @@ -506,9 +511,13 @@ Return a newly-created copy of @var{lst} with elements @deffn {Scheme Procedure} delete item lst @deffnx {C Function} scm_delete (item, lst) Return a newly-created copy of @var{lst} with elements -@code{equal?} to @var{item} removed. This procedure mirrors +@code{equal?} to @var{item} removed. This procedure mirrors @code{member}: @code{delete} compares elements of @var{lst} against @var{item} with @code{equal?}. + +See also SRFI-1 which has an extended @code{delete} (@ref{SRFI-1 +Deleting}), and also an @code{lset-difference} which can delete +multiple @var{item}s in one call (@ref{SRFI-1 Set Operations}). @end deffn @deffn {Scheme Procedure} delq! item lst @@ -598,6 +607,9 @@ the non-empty lists returned by @code{(list-tail @var{lst} @var{k})} for @var{k} less than the length of @var{lst}. If @var{x} does not occur in @var{lst}, then @code{#f} (not the empty list) is returned. + +See also SRFI-1 which has an extended @code{member} function +(@ref{SRFI-1 Searching}). @end deffn @@ -633,6 +645,8 @@ and the result(s) of the procedure applications are thrown away. The return value is not specified. @end deffn +See also SRFI-1 which extends these functions to take lists of unequal +lengths (@ref{SRFI-1 Fold and Map}). @node Vectors @subsection Vectors @@ -3262,7 +3276,8 @@ return is the pair @code{(KEY . VALUE)} from @var{alist}. If there's no matching entry the return is @code{#f}. @code{assq} compares keys with @code{eq?}, @code{assv} uses -@code{eqv?} and @code{assoc} uses @code{equal?}. +@code{eqv?} and @code{assoc} uses @code{equal?}. See also SRFI-1 +which has an extended @code{assoc} (@ref{SRFI-1 Association Lists}). @end deffn @deffn {Scheme Procedure} assq-ref alist key diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 424ce4507..3d1549ecf 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -544,20 +544,34 @@ of the call to @code{call-with-values}. @end deffn In addition to the fundamental procedures described above, Guile has a -module which exports a syntax called @code{receive}, which is much more -convenient. If you want to use it in your programs, you have to load -the module @code{(ice-9 receive)} with the statement +module which exports a syntax called @code{receive}, which is much +more convenient. This is in the @code{(ice-9 receive)} and is the +same as specified by SRFI-8 (@pxref{SRFI-8}). @lisp (use-modules (ice-9 receive)) @end lisp @deffn {library syntax} receive formals expr body @dots{} -Evaluate the expression @var{expr}, and bind the result values (zero or -more) to the formal arguments in the formal argument list @var{formals}. -@var{formals} must have the same syntax like the formal argument list -used in @code{lambda} (@pxref{Lambda}). After binding the variables, -the expressions in @var{body} @dots{} are evaluated in order. +Evaluate the expression @var{expr}, and bind the result values (zero +or more) to the formal arguments in @var{formals}. @var{formals} is a +list of symbols, like the argument list in a @code{lambda} +(@pxref{Lambda}). After binding the variables, the expressions in +@var{body} @dots{} are evaluated in order, the return value is the +result from the last expression. + +For example getting results from @code{partition} in SRFI-1 +(@pxref{SRFI-1}), + +@example +(receive (odds evens) + (partition odd? '(7 4 2 8 3)) + (display odds) + (display " and ") + (display evens)) +@print{} (7 3) and (4 2 8) +@end example + @end deffn diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index ab79e4fb0..6eb95db3d 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1118,15 +1118,17 @@ As described in the previous section, a port type object (ptob) is a structure of type @code{scm_ptob_descriptor}. A ptob is created by calling @code{scm_make_port_type}. +@deftypefun scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, size_t size)) +Return a new port type object. The @var{name}, @var{fill_input} and +@var{write} parameters are initial values for those port type fields, +as described below. The other fields are initialized with default +values and can be changed later. +@end deftypefun + All of the elements of the ptob, apart from @code{name}, are procedures which collectively implement the port behaviour. Creating a new port type mostly involves writing these procedures. -@code{scm_make_port_type} initializes three elements of the structure -(@code{name}, @code{fill_input} and @code{write}) from its arguments. -The remaining elements are initialized with default values and can be -set later if required. - @table @code @item name A pointer to a NUL terminated string: the name of the port type. This @@ -1136,25 +1138,42 @@ a procedure. Set via the first argument to @code{scm_make_port_type}. @item mark Called during garbage collection to mark any SCM objects that a port object may contain. It doesn't need to be set unless the port has -@code{SCM} components. Set using @code{scm_set_port_mark}. +@code{SCM} components. Set using + +@deftypefun void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM port)) +@end deftypefun @item free Called when the port is collected during gc. It should free any resources used by the port. -Set using @code{scm_set_port_free}. +Set using + +@deftypefun void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM port)) +@end deftypefun @item print Called when @code{write} is called on the port object, to print a -port description. e.g., for an fport it may produce something like: -@code{#}. Set using @code{scm_set_port_print}. +port description. E.g., for an fport it may produce something like: +@code{#}. Set using + +@deftypefun void scm_set_port_print (scm_t_bits tc, int (*print) (SCM port, SCM dest_port, scm_print_state *pstate)) +The first argument @var{port} is the object being printed, the second +argument @var{dest_port} is where its description should go. +@end deftypefun @item equalp -Not used at present. Set using @code{scm_set_port_equalp}. +Not used at present. Set using + +@deftypefun void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) +@end deftypefun @item close Called when the port is closed, unless it was collected during gc. It should free any resources used by the port. -Set using @code{scm_set_port_close}. +Set using + +@deftypefun void scm_set_port_close (scm_t_bits tc, int (*close) (SCM port)) +@end deftypefun @item write Accept data which is to be written using the port. The port implementation @@ -1164,12 +1183,18 @@ Set via the third argument to @code{scm_make_port_type}. @item flush Complete the processing of buffered output data. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_flush}. +Set using + +@deftypefun void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) +@end deftypefun @item end_input Perform any synchronization required when switching from input to output on the port. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_end_input}. +Set using + +@deftypefun void scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)) +@end deftypefun @item fill_input Read new data into the read buffer and return the first character. It @@ -1180,7 +1205,10 @@ Set via the second argument to @code{scm_make_port_type}. Return a lower bound on the number of bytes that could be read from the port without blocking. It can be assumed that the current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_input_waiting}. +Set using + +@deftypefun void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM port)) +@end deftypefun @item seek Set the current position of the port. The procedure can not make @@ -1189,10 +1217,10 @@ called. It can reset the buffers first if desired by using something like: @example - if (pt->rw_active == SCM_PORT_READ) - scm_end_input (object); - else if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (object); +if (pt->rw_active == SCM_PORT_READ) + scm_end_input (port); +else if (pt->rw_active == SCM_PORT_WRITE) + ptob->flush (port); @end example However note that this will have the side effect of discarding any data @@ -1202,12 +1230,18 @@ when seek is called to measure the current position of the port, i.e., @code{(seek p 0 SEEK_CUR)}. The libguile fport and string port implementations take care to avoid this problem. -The procedure is set using @code{scm_set_port_seek}. +The procedure is set using + +@deftypefun void scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, off_t offset, int whence)) +@end deftypefun @item truncate Truncate the port data to be specified length. It can be assumed that the current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using @code{scm_set_port_truncate}. +Set using + +@deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length)) +@end deftypefun @end table diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index e1f137175..1eaafc48d 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -240,7 +240,7 @@ Return the thread that called this function. @end deffn @c begin (texi-doc-string "guile" "call-with-new-thread") -@deffn {Scheme Procedure} call-with-new-thread thunk handler +@deffn {Scheme Procedure} call-with-new-thread thunk [handler] Call @code{thunk} in a new thread and with a new dynamic state, returning the new thread. The procedure @var{thunk} is called via @code{with-continuation-barrier}. diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index ce306d60a..a31fe30f8 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -193,7 +193,11 @@ functions provided by Guile, it will also offer the function static SCM my_hostname (void) @{ - return scm_str2string (getenv ("HOSTNAME")); + char *s = getenv ("HOSTNAME"); + if (s == NULL) + return SCM_BOOL_F; + else + return scm_from_locale_string (s); @} static void diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 598618a3e..f3a3c4093 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -1212,7 +1212,7 @@ This module implements queues holding arbitrary scheme objects and designed for efficient first-in / first-out operations. @code{make-q} creates a queue, and objects are entered and removed -with @code{enq!} and @code{deq!}. @code{q-push!} and @code{q-pop!} +with @code{enq!} and @code{deq!}. @code{q-push!} and @code{q-pop!} can be used too, treating the front of the queue like a stack. @sp 1 diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 31cb948ef..6a1d0f1b2 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -472,10 +472,11 @@ If @var{size} is omitted, a default size will be used. @end defvar @end deffn -@deffn {Scheme Procedure} fcntl object cmd [value] +@deffn {Scheme Procedure} fcntl port/fd cmd [value] @deffnx {C Function} scm_fcntl (object, cmd, value) -Apply @var{cmd} on @var{object}, either a port or file descriptor. -The @var{value} is an integer argument, for the @code{SET} commands. +Apply @var{cmd} on @var{port/fd}, either a port or file descriptor. +The @var{value} argument is used by the @code{SET} commands described +below, it's an integer value. Values for @var{cmd} are: @@ -497,6 +498,13 @@ flag, @example (fcntl port F_SETFD FD_CLOEXEC) @end example + +Or better, set it but leave any other possible future flags unchanged, + +@example +(fcntl port F_SETFD (logior FD_CLOEXEC + (fcntl port F_GETFD))) +@end example @end defvar @end defvar @@ -509,8 +517,8 @@ A common use is to set @code{O_NONBLOCK} on a network socket. The following sets that flag, and leaves other flags unchanged. @example -(fcntl sock F_SETFL - (logior (fcntl sock F_GETFL) O_NONBLOCK)) +(fcntl sock F_SETFL (logior O_NONBLOCK + (fcntl sock F_GETFL))) @end example @end defvar @@ -1644,10 +1652,28 @@ Example: (system* "echo" "foo" "bar") @end deffn @deffn {Scheme Procedure} primitive-exit [status] +@deffnx {Scheme Procedure} primitive-_exit [status] @deffnx {C Function} scm_primitive_exit (status) -Terminate the current process without unwinding the Scheme stack. -This is would typically be useful after a fork. The exit status -is @var{status} if supplied, otherwise zero. +@deffnx {C Function} scm_primitive__exit (status) +Terminate the current process without unwinding the Scheme stack. The +exit status is @var{status} if supplied, otherwise zero. + +@code{primitive-exit} uses the C @code{exit} function and hence runs +usual C level cleanups (flush output streams, call @code{atexit} +functions, etc, see @ref{Normal Termination,,, libc, The GNU C Library +Reference Manual})). + +@code{primitive-_exit} is the @code{_exit} system call +(@pxref{Termination Internals,,, libc, The GNU C Library Reference +Manual}). This terminates the program immediately, with neither +Scheme-level nor C-level cleanups. + +The typical use for @code{primitive-_exit} is from a child process +created with @code{primitive-fork}. For example in a Gdk program the +child process inherits the X server connection and a C-level +@code{atexit} cleanup which will close that connection. But closing +in the child would upset the protocol in the parent, so +@code{primitive-_exit} should be used to exit without that. @end deffn @deffn {Scheme Procedure} execl filename . args diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 3291320f3..8a027c00b 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -414,9 +414,13 @@ have a limit on the number of arguments a function takes, which the @deffn {Scheme Procedure} append-reverse rev-head tail @deffnx {Scheme Procedure} append-reverse! rev-head tail -Reverse @var{rev-head}, append @var{tail} and return the result. This -is equivalent to @code{(append (reverse @var{rev-head}) @var{tail})}, -but more efficient. +Reverse @var{rev-head}, append @var{tail} to it, and return the +result. This is equivalent to @code{(append (reverse @var{rev-head}) +@var{tail})}, but its implementation is more efficient. + +@example +(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6) +@end example @code{append-reverse!} may modify @var{rev-head} in order to produce the result. @@ -937,12 +941,21 @@ Lists}. The present section only documents the additional procedures for dealing with association lists defined by SRFI-1. @deffn {Scheme Procedure} assoc key alist [=] -Return the pair from @var{alist} which matches @var{key}. Equality is -determined by @var{=}, which defaults to @code{equal?} if not given. -@var{alist} must be an association lists---a list of pairs. +Return the pair from @var{alist} which matches @var{key}. This +extends the core @code{assoc} (@pxref{Retrieving Alist Entries}) by +taking an optional @var{=} comparison procedure. -This function extends the core @code{assoc} by accepting an equality -predicate. (@pxref{Association Lists}) +The default comparison is @code{equal?}. If an @var{=} parameter is +given it's called @code{(@var{=} @var{key} @var{alistcar})}, ie. the +given target @var{key} is the first argument, and a @code{car} from +@var{alist} is second. + +For example a case-insensitive string lookup, + +@example +(assoc "yy" '(("XX" . 1) ("YY" . 2)) string-ci=?) +@result{} ("YY" . 2) +@end example @end deffn @deffn {Scheme Procedure} alist-cons key datum alist diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6b6bb920d..68b5dfdc7 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -147,7 +147,7 @@ EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \ version.h scmconfig.h \ - $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) guile.texi + $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) EXTRA_libguile_la_SOURCES = _scm.h \ inet_aton.c memmove.c putenv.c strerror.c \ @@ -274,9 +274,9 @@ SUFFIXES = .x .doc (./guile-snarf-docs $(snarfcppopts) $< | \ ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } -$(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in +$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): scmconfig.h snarf.h guile-snarf.in -$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT) +$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): scmconfig.h snarf.h guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT) error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c diff --git a/libguile/eval.c b/libguile/eval.c index 5c9801c5b..9fe419137 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -53,6 +53,9 @@ char *alloca (); # endif # endif #endif +#if HAVE_MALLOC_H +#include /* alloca on mingw */ +#endif #include #include "libguile/_scm.h" diff --git a/libguile/filesys.c b/libguile/filesys.c index 14078ef45..8ac6bd246 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -45,6 +45,9 @@ char *alloca (); # endif # endif #endif +#if HAVE_MALLOC_H +#include /* alloca on mingw, though its not used on that system */ +#endif #include #include @@ -349,7 +352,7 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, iflags = SCM_NUM2INT (2, flags); imode = SCM_NUM2INT_DEF (3, mode, 0666); - STRING_SYSCALL (path, c_path, fd = open (c_path, iflags, imode)); + STRING_SYSCALL (path, c_path, fd = open_or_open64 (c_path, iflags, imode)); if (fd == -1) SCM_SYSERROR; return scm_from_int (fd); @@ -466,7 +469,7 @@ SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0, SCM_SYMBOL (scm_sym_regular, "regular"); SCM_SYMBOL (scm_sym_directory, "directory"); -#ifdef HAVE_S_ISLNK +#ifdef S_ISLNK SCM_SYMBOL (scm_sym_symlink, "symlink"); #endif SCM_SYMBOL (scm_sym_block_special, "block-special"); @@ -512,7 +515,8 @@ scm_stat2scm (struct stat_or_stat64 *stat_temp) SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_regular); else if (S_ISDIR (mode)) SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_directory); -#ifdef HAVE_S_ISLNK +#ifdef S_ISLNK + /* systems without symlinks probably don't have S_ISLNK */ else if (S_ISLNK (mode)) SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_symlink); #endif @@ -1707,6 +1711,9 @@ scm_init_filesys () #ifdef O_SYNC scm_c_define ("O_SYNC", scm_from_long (O_SYNC)); #endif +#ifdef O_LARGEFILE + scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE)); +#endif #ifdef F_DUPFD scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD)); diff --git a/libguile/fports.c b/libguile/fports.c index 7af5f6a27..563557e82 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -37,8 +37,6 @@ #endif #ifdef HAVE_UNISTD_H #include -#else -size_t fwrite (); #endif #ifdef HAVE_IO_H #include @@ -460,9 +458,8 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) static int fport_input_waiting (SCM port) { - int fdes = SCM_FSTREAM (port)->fdes; - #ifdef HAVE_SELECT + int fdes = SCM_FSTREAM (port)->fdes; struct timeval timeout; SELECT_TYPE read_set; SELECT_TYPE write_set; @@ -482,10 +479,15 @@ fport_input_waiting (SCM port) < 0) scm_syserror ("fport_input_waiting"); return FD_ISSET (fdes, &read_set) ? 1 : 0; -#elif defined (FIONREAD) + +#elif HAVE_IOCTL && defined (FIONREAD) + /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD + (for use with winsock ioctlsocket()) but not ioctl(). */ + int fdes = SCM_FSTREAM (port)->fdes; int remir; ioctl(fdes, FIONREAD, &remir); return remir; + #else scm_misc_error ("fport_input_waiting", "Not fully implemented on this platform", diff --git a/libguile/inline.h b/libguile/inline.h index 0f7f7aa01..621b4fb36 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -248,6 +248,27 @@ SCM_C_INLINE int scm_is_pair (SCM x) { + /* The following "workaround_for_gcc_295" avoids bad code generated by + i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least). + + Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so + the fetch of the tag word from x is done before confirming it's a + non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a + immediate. This was seen to afflict scm_srfi1_split_at and something + deep in the bowels of ceval(). In both cases segvs resulted from + deferencing a random immediate value. srfi-1.test exposes the problem + through a short list, the immediate being SCM_EOL in that case. + Something in syntax.test exposed the ceval() problem. + + Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the + problem, without even using that variable. The "w=w" is just to + prevent a warning about it being unused. + */ +#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95 + volatile SCM workaround_for_gcc_295 = x; + workaround_for_gcc_295 = workaround_for_gcc_295; +#endif + return SCM_I_CONSP (x); } diff --git a/libguile/numbers.c b/libguile/numbers.c index e07e5ce24..3b6d781af 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4779,28 +4779,33 @@ scm_i_divide (SCM x, SCM y, int inexact) else { /* big_x / big_y */ - int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - if (divisible_p) - { - SCM result = scm_i_mkbig (); - mpz_divexact (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_i_normbig (result); - } - else - { - if (inexact) - { - double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); - double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_from_double (dbx / dby); - } - else return scm_i_make_ratio (x, y); - } + if (inexact) + { + /* It's easily possible for the ratio x/y to fit a double + but one or both x and y be too big to fit a double, + hence the use of mpq_get_d rather than converting and + dividing. */ + mpq_t q; + *mpq_numref(q) = *SCM_I_BIG_MPZ (x); + *mpq_denref(q) = *SCM_I_BIG_MPZ (y); + return scm_from_double (mpq_get_d (q)); + } + else + { + int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + if (divisible_p) + { + SCM result = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (result); + } + else + return scm_i_make_ratio (x, y); + } } } else if (SCM_REALP (y)) diff --git a/libguile/ports.c b/libguile/ports.c index 77b59bedc..9ac0c1cbe 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -165,50 +165,50 @@ scm_make_port_type (char *name, } void -scm_set_port_mark (long tc, SCM (*mark) (SCM)) +scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark; } void -scm_set_port_free (long tc, size_t (*free) (SCM)) +scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free; } void -scm_set_port_print (long tc, int (*print) (SCM exp, SCM port, +scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print; } void -scm_set_port_equalp (long tc, SCM (*equalp) (SCM, SCM)) +scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp; } void -scm_set_port_flush (long tc, void (*flush) (SCM port)) +scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush; } void -scm_set_port_end_input (long tc, void (*end_input) (SCM port, int offset)) +scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input; } void -scm_set_port_close (long tc, int (*close) (SCM)) +scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close; } void -scm_set_port_seek (long tc, off_t (*seek) (SCM port, +scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, off_t OFFSET, int WHENCE)) { @@ -216,13 +216,13 @@ scm_set_port_seek (long tc, off_t (*seek) (SCM port, } void -scm_set_port_truncate (long tc, void (*truncate) (SCM port, off_t length)) +scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate; } void -scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)) +scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting; } @@ -1372,37 +1372,36 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_seek { - off_t off; - off_t rv; int how; fd_port = SCM_COERCE_OUTPORT (fd_port); - if (sizeof (off_t) == sizeof (scm_t_intmax)) - off = scm_to_intmax (offset); - else - off = scm_to_long (offset); how = scm_to_int (whence); - if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); + if (SCM_OPPORTP (fd_port)) { scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); + off_t off = scm_to_off_t (offset); + off_t rv; if (!ptob->seek) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); else rv = ptob->seek (fd_port, off, how); + return scm_from_off_t (rv); } else /* file descriptor?. */ { - rv = lseek (scm_to_int (fd_port), off, how); + off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); + off_t_or_off64_t rv; + rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how); if (rv == -1) SCM_SYSERROR; + return scm_from_off_t_or_off64_t (rv); } - return scm_from_intmax (rv); } #undef FUNC_NAME @@ -1450,8 +1449,9 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, object = SCM_COERCE_OUTPORT (object); if (scm_is_integer (object)) { - off_t c_length = scm_to_off_t (length); - SCM_SYSCALL (rv = ftruncate (scm_to_int (object), c_length)); + off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); + SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), + c_length)); } else if (SCM_OPOUTPORTP (object)) { diff --git a/libguile/ports.h b/libguile/ports.h index 8332107ca..ab0449063 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -205,28 +205,28 @@ SCM_API scm_t_bits scm_make_port_type (char *name, void (*write) (SCM port, const void *data, size_t size)); -SCM_API void scm_set_port_mark (long tc, SCM (*mark) (SCM)); -SCM_API void scm_set_port_free (long tc, size_t (*free) (SCM)); -SCM_API void scm_set_port_print (long tc, +SCM_API void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM)); +SCM_API void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)); +SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); -SCM_API void scm_set_port_equalp (long tc, SCM (*equalp) (SCM, SCM)); -SCM_API void scm_set_port_close (long tc, int (*close) (SCM)); +SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)); +SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM)); -SCM_API void scm_set_port_flush (long tc, +SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)); -SCM_API void scm_set_port_end_input (long tc, +SCM_API void scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)); -SCM_API void scm_set_port_seek (long tc, +SCM_API void scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, off_t OFFSET, int WHENCE)); -SCM_API void scm_set_port_truncate (long tc, +SCM_API void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length)); -SCM_API void scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)); +SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)); SCM_API SCM scm_char_ready_p (SCM port); size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); diff --git a/libguile/posix.c b/libguile/posix.c index 5715a327d..a96dabcfa 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1132,16 +1132,25 @@ extern int mkstemp (char *); SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, (SCM tmpl), - "Create a new unique file in the file system and returns a new\n" + "Create a new unique file in the file system and return a new\n" "buffered port open for reading and writing to the file.\n" "\n" "@var{tmpl} is a string specifying where the file should be\n" - "created: it must end with @samp{XXXXXX} and will be changed in\n" - "place to return the name of the temporary file.\n" + "created: it must end with @samp{XXXXXX} and those @samp{X}s\n" + "will be changed in the string to return the name of the file.\n" + "(@code{port-filename} on the port also gives the name.)\n" "\n" - "The file is created with mode @code{0600}, which means read and\n" - "write for the owner only. @code{chmod} can be used to change\n" - "this.") + "POSIX doesn't specify the permissions mode of the file, on GNU\n" + "and most systems it's @code{#o600}. An application can use\n" + "@code{chmod} to relax that if desired. For example\n" + "@code{#o666} less @code{umask}, which is usual for ordinary\n" + "file creation,\n" + "\n" + "@example\n" + "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n" + " (chmod port (logand #o666 (lognot (umask))))\n" + " ...)\n" + "@end example") #define FUNC_NAME s_scm_mkstemp { char *c_tmpl; @@ -1419,8 +1428,11 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, ctype = S_IFREG; else if (strcmp (p, "directory") == 0) ctype = S_IFDIR; +#ifdef S_IFLNK + /* systems without symlinks probably don't have S_IFLNK defined */ else if (strcmp (p, "symlink") == 0) ctype = S_IFLNK; +#endif else if (strcmp (p, "block-special") == 0) ctype = S_IFBLK; else if (strcmp (p, "char-special") == 0) diff --git a/libguile/read.c b/libguile/read.c index 0714e3f84..d75839589 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -329,7 +329,9 @@ static SCM scm_get_hash_procedure(int c); static SCM scm_i_lreadparen (SCM *, SCM, char *, SCM *, char); static char s_list[]="list"; +#if SCM_ENABLE_ELISP static char s_vector[]="vector"; +#endif SCM scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) diff --git a/libguile/simpos.c b/libguile/simpos.c index 3d5d0feb7..79b9f3e3a 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -195,9 +195,9 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, /* simple exit, without unwinding the scheme stack or flushing ports. */ SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0, (SCM status), - "Terminate the current process without unwinding the Scheme stack.\n" - "This is would typically be useful after a fork. The exit status\n" - "is @var{status} if supplied, otherwise zero.") + "Terminate the current process without unwinding the Scheme\n" + "stack. The exit status is @var{status} if supplied, otherwise\n" + "zero.") #define FUNC_NAME s_scm_primitive_exit { int cstatus = 0; @@ -207,6 +207,25 @@ SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0, + (SCM status), + "Terminate the current process using the _exit() system call and\n" + "without unwinding the Scheme stack. The exit status is\n" + "@var{status} if supplied, otherwise zero.\n" + "\n" + "This function is typically useful after a fork, to ensure no\n" + "Scheme cleanups or @code{atexit} handlers are run (those\n" + "usually belonging in the parent rather than the child).") +#define FUNC_NAME s_scm_primitive__exit +{ + int cstatus = 0; + if (!SCM_UNBNDP (status)) + cstatus = scm_to_int (status); + _exit (cstatus); +} +#undef FUNC_NAME + + void scm_init_simpos () diff --git a/libguile/simpos.h b/libguile/simpos.h index c7f40b62a..1ce207b1d 100644 --- a/libguile/simpos.h +++ b/libguile/simpos.h @@ -30,6 +30,7 @@ SCM_API SCM scm_system (SCM cmd); SCM_API SCM scm_system_star (SCM cmds); SCM_API SCM scm_getenv (SCM nam); SCM_API SCM scm_primitive_exit (SCM status); +SCM_API SCM scm_primitive__exit (SCM status); SCM_API void scm_init_simpos (void); #endif /* SCM_SIMPOS_H */ diff --git a/libguile/throw.c b/libguile/throw.c index 12c90b8d8..115bb0c03 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -499,6 +499,11 @@ scm_handle_by_message (void *handler_data, SCM tag, SCM args) handler_message (handler_data, tag, args); scm_i_pthread_exit (NULL); + + /* this point not reached, but suppress gcc warning about no return value + in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not + to be the case on cygwin for instance) */ + return SCM_BOOL_F; } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 16cf87876..ed36d30c7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -9,11 +9,34 @@ * tests/unif.test ("vector equal? one-dimensional array"): New. +2006-05-28 Kevin Ryde + + * tests/numbers.test (number->string): Disable 11.333 and 1.324e44 + tests, as these can't be expected to come out precisely in the current + implementation, and in fact don't under gcc 4. Reported by Hector + Herrera. + + * tests/srfi-1.test (append-reverse, append-reverse!): New tests. + 2006-05-28 Marius Vollmer * tests/ports.test, tests/filesys.test: Delete test file after all tests have run in order to make "make distcheck" work. +2006-05-20 Kevin Ryde + + * tests/srfi-1.test (assoc): A few tests, in particular "=" argument + order which had been wrong. + + * tests/srfi-60.test (test-srfi-60): Use #:duplicates (last) to + suppress warning about replacing bit-count. + +2006-05-09 Kevin Ryde + + * tests/numbers.test (exact->inexact): Test fractions big/big. + + * tests/threads.test (n-par-for-each, n-for-each-par-map): New tests. + 2006-04-17 Kevin Ryde * tests/filesys.test (lstat): Allow for test-symlink not existing yet. diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 54117b044..af67d6816 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1214,14 +1214,22 @@ (string=? (number->string 0.25 2) "0.010"))) (pass-if (string=? (number->string 255.0625 16) "FF.1")) (pass-if (string=? (number->string (/ 1 3) 3) "1/10")) - (pass-if (or (string=? (number->string 11.33333333333333333 12) - "B.4") - (string=? (number->string 11.33333333333333333 12) - "B.400000000000009"))) - (pass-if (or (string=? (number->string 1.324e44 16) - "5.EFE0A14FAFEe24") - (string=? (number->string 1.324e44 16) - "5.EFE0A14FAFDF8e24"))))) + + ;; Numeric conversion from decimal is not precise, in its current + ;; implementation, so 11.333... and 1.324... can't be expected to + ;; reliably come out to precise values. These tests did actually work + ;; for a while, but something in gcc changed, affecting the conversion + ;; code. + ;; + ;; (pass-if (or (string=? (number->string 11.33333333333333333 12) + ;; "B.4") + ;; (string=? (number->string 11.33333333333333333 12) + ;; "B.400000000000009"))) + ;; (pass-if (or (string=? (number->string 1.324e44 16) + ;; "5.EFE0A14FAFEe24") + ;; (string=? (number->string 1.324e44 16) + ;; "5.EFE0A14FAFDF8e24"))) + )) ;;; ;;; string->number @@ -2745,7 +2753,17 @@ (n (- (ash 1 (+ 2 dbl-mant-dig)) 1) (1- (* 2 n))) (want (+ (ash-flo 1.0 (+ 2 dbl-mant-dig)) 4.0) (* 2.0 want))) ((> i 100)) - (try-i i n want)))) + (try-i i n want))) + + (pass-if "frac big/big" + (let ((big (ash 1 256))) + (= 1.0 (exact->inexact (/ (1+ big) big))))) + + ;; In guile 1.8.0 this failed, giving back "nan" because it tried to + ;; convert the num and den to doubles, resulting in infs. + (pass-if "frac big/big, exceeding double" + (let ((big (ash 1 4096))) + (= 1.0 (exact->inexact (/ (1+ big) big)))))) ;;; ;;; floor diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 0f60a16be..dd55c1335 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -200,7 +200,115 @@ (pass-if "(1) (2) / 9 9" (equal? '(1 2) (append-map noop '((1) (2)) '(9 9)))))) - + +;; +;; append-reverse +;; + +(with-test-prefix "append-reverse" + + ;; return a list which is the cars and cdrs of LST + (define (list-contents lst) + (if (null? lst) + '() + (cons* (car lst) (cdr lst) (list-contents (cdr lst))))) + + (define (valid-append-reverse revhead tail want) + (let ((revhead-contents (list-contents revhead)) + (got (append-reverse revhead tail))) + (and (equal? got want) + ;; revhead unchanged + (equal? revhead-contents (list-contents revhead))))) + + (pass-if-exception "too few args (0)" exception:wrong-num-args + (append-reverse)) + + (pass-if-exception "too few args (1)" exception:wrong-num-args + (append-reverse '(x))) + + (pass-if-exception "too many args (3)" exception:wrong-num-args + (append-reverse '() '() #f)) + + (pass-if (valid-append-reverse '() '() '())) + (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3))) + + (pass-if (valid-append-reverse '(1) '() '(1))) + (pass-if (valid-append-reverse '(1) '(2) '(1 2))) + (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3))) + + (pass-if (valid-append-reverse '(1 2) '() '(2 1))) + (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3))) + (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4))) + + (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1))) + (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4))) + (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5)))) + +;; +;; append-reverse! +;; + +(with-test-prefix "append-reverse!" + + (pass-if-exception "too few args (0)" exception:wrong-num-args + (append-reverse!)) + + (pass-if-exception "too few args (1)" exception:wrong-num-args + (append-reverse! '(x))) + + (pass-if-exception "too many args (3)" exception:wrong-num-args + (append-reverse! '() '() #f)) + + (pass-if (equal? '() (append-reverse! '() '()))) + (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3)))) + + (pass-if (equal? '(1) (append-reverse! '(1) '()))) + (pass-if (equal? '(1 2) (append-reverse! '(1) '(2)))) + (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3)))) + + (pass-if (equal? '(2 1) (append-reverse! '(1 2) '()))) + (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3)))) + (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4)))) + + (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '()))) + (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4)))) + (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5))))) + +;; +;; assoc +;; + +(with-test-prefix "assoc" + + (pass-if "not found" + (let ((alist '((a . 1) + (b . 2) + (c . 3)))) + (eqv? #f (assoc 'z alist)))) + + (pass-if "found" + (let ((alist '((a . 1) + (b . 2) + (c . 3)))) + (eqv? (second alist) (assoc 'b alist)))) + + ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8 + ;; series, 1.6.x and earlier was ok) + (pass-if "= arg order" + (let ((alist '((b . 1))) + (good #f)) + (assoc 'a alist (lambda (x y) + (set! good (and (eq? x 'a) + (eq? y 'b))))) + good)) + + ;; likewise this one bad in guile 1.8.0 + (pass-if "srfi-1 example <" + (let ((alist '((1 . a) + (5 . b) + (6 . c)))) + (eq? (third alist) (assoc 5 alist <))))) + ;; ;; break ;; diff --git a/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index 5822cb1d0..fff89f1ca 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -18,6 +18,7 @@ ;;;; Boston, MA 02110-1301 USA (define-module (test-srfi-60) + #:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count' #:use-module (test-suite lib) #:use-module (srfi srfi-60)) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 511927719..014601611 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -21,34 +21,116 @@ (test-suite lib)) (if (provided? 'threads) - (with-test-prefix "parallel" - (pass-if "no forms" - (call-with-values - (lambda () - (parallel)) - (lambda () - #t))) + (begin - (pass-if "1" - (call-with-values + (with-test-prefix "parallel" + (pass-if "no forms" + (call-with-values + (lambda () + (parallel)) (lambda () - (parallel 1)) - (lambda (x) - (equal? x 1)))) + #t))) - (pass-if "1 2" - (call-with-values - (lambda () - (parallel 1 2)) - (lambda (x y) - (and (equal? x 1) - (equal? y 2))))) + (pass-if "1" + (call-with-values + (lambda () + (parallel 1)) + (lambda (x) + (equal? x 1)))) - (pass-if "1 2 3" - (call-with-values - (lambda () - (parallel 1 2 3)) - (lambda (x y z) - (and (equal? x 1) - (equal? y 2) - (equal? z 3))))))) + (pass-if "1 2" + (call-with-values + (lambda () + (parallel 1 2)) + (lambda (x y) + (and (equal? x 1) + (equal? y 2))))) + + (pass-if "1 2 3" + (call-with-values + (lambda () + (parallel 1 2 3)) + (lambda (x y z) + (and (equal? x 1) + (equal? y 2) + (equal? z 3)))))) + + ;; + ;; n-par-for-each + ;; + + (with-test-prefix "n-par-for-each" + + (pass-if "0 in limit 10" + (n-par-for-each 10 noop '()) + #t) + + (pass-if "6 in limit 10" + (let ((v (make-vector 6 #f))) + (n-par-for-each 10 (lambda (n) + (vector-set! v n #t)) + '(0 1 2 3 4 5)) + (equal? v '#(#t #t #t #t #t #t)))) + + (pass-if "6 in limit 1" + (let ((v (make-vector 6 #f))) + (n-par-for-each 1 (lambda (n) + (vector-set! v n #t)) + '(0 1 2 3 4 5)) + (equal? v '#(#t #t #t #t #t #t)))) + + (pass-if "6 in limit 2" + (let ((v (make-vector 6 #f))) + (n-par-for-each 2 (lambda (n) + (vector-set! v n #t)) + '(0 1 2 3 4 5)) + (equal? v '#(#t #t #t #t #t #t)))) + + (pass-if "6 in limit 3" + (let ((v (make-vector 6 #f))) + (n-par-for-each 3 (lambda (n) + (vector-set! v n #t)) + '(0 1 2 3 4 5)) + (equal? v '#(#t #t #t #t #t #t))))) + + ;; + ;; n-for-each-par-map + ;; + + (with-test-prefix "n-for-each-par-map" + + (pass-if "0 in limit 10" + (n-for-each-par-map 10 noop noop '()) + #t) + + (pass-if "6 in limit 10" + (let ((result '())) + (n-for-each-par-map 10 + (lambda (n) (set! result (cons n result))) + (lambda (n) (* 2 n)) + '(0 1 2 3 4 5)) + (equal? result '(10 8 6 4 2 0)))) + + (pass-if "6 in limit 1" + (let ((result '())) + (n-for-each-par-map 1 + (lambda (n) (set! result (cons n result))) + (lambda (n) (* 2 n)) + '(0 1 2 3 4 5)) + (equal? result '(10 8 6 4 2 0)))) + + (pass-if "6 in limit 2" + (let ((result '())) + (n-for-each-par-map 2 + (lambda (n) (set! result (cons n result))) + (lambda (n) (* 2 n)) + '(0 1 2 3 4 5)) + (equal? result '(10 8 6 4 2 0)))) + + (pass-if "6 in limit 3" + (let ((result '())) + (n-for-each-par-map 3 + (lambda (n) (set! result (cons n result))) + (lambda (n) (* 2 n)) + '(0 1 2 3 4 5)) + (equal? result '(10 8 6 4 2 0)))))))