From ad97642e70962bb9ce5a21311f86a1db772189e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 13 Jun 2006 08:14:01 +0000 Subject: [PATCH 001/116] Changes from arch/CVS synchronization --- ChangeLog | 4 ++++ NEWS | 1 + doc/ref/ChangeLog | 5 +++++ doc/ref/api-compound.texi | 4 ++++ 4 files changed, 14 insertions(+) diff --git a/ChangeLog b/ChangeLog index d9cac4803..d8100a7af 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2006-06-13 Ludovic Courts + + * NEWS: Mentioned the new behavior of `equal?' for structures. + 2006-06-06 Neil Jerram * acinclude.m4 (ACX_PTHREAD): Update to latest definition from diff --git a/NEWS b/NEWS index 6b7ad7c52..3ff9f42af 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,7 @@ Changes in 1.8.1: * Changes to Scheme functions and syntax ** A one-dimenisonal array can now be 'equal?' to a vector. +** Structures, records, and SRFI-9 records can now be compared with `equal?'. * Bug fixes. ** array-set! with bit vector. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index ba5968a02..3122bc3d3 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-06-13 Ludovic Courts + + * api-compound.texi (Structure Concepts): Mentioned the behavior + of `equal?' for structures. + 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 dda2518de..c00f3e9a8 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2705,6 +2705,10 @@ memory, private to the structure, divided up into typed fields. A vtable is another structure used to hold type-specific data. Multiple structures can share a common vtable. +When applied to structures, the @code{equal?} predicate +(@pxref{Equality}) returns @code{#t} if the two structures share a +common vtable @emph{and} all their fields satisfy @code{equal?}. + Three concepts are key to understanding structures. @itemize @bullet{} From 42be21d82afbede08c86bcde8203d1c94fdbd56e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Jun 2006 07:39:59 +0000 Subject: [PATCH 002/116] Changes from arch/CVS synchronization --- doc/ref/ChangeLog | 5 +++++ doc/ref/api-utility.texi | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 3122bc3d3..d80fba484 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-06-16 Ludovic Courts + + * api-utility.texi (Equality): Mentioned the behavior of `equal?' + for structures (as suggested by Kevin Ryde). + 2006-06-13 Ludovic Courts * api-compound.texi (Structure Concepts): Mentioned the behavior diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index 9f6766c71..4a902123e 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -137,7 +137,7 @@ inexact number (even if their value is the same). Return @code{#t} if @var{x} and @var{y} are the same type, and their contents or value are equal. -For a pair, string, vector or array, @code{equal?} compares the +For a pair, string, vector, array or structure, @code{equal?} compares the contents, and does so using using the same @code{equal?} recursively, so a deep structure can be traversed. From 9a9931719ddc6d1a7ed2e6597257e336114a69a9 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 22:47:50 +0000 Subject: [PATCH 003/116] merge 1.8 branch --- srfi/ChangeLog | 10 ++++++++ srfi/srfi-1.c | 61 ++++++++++++++++++++++++++++++++++++++++++++++++- srfi/srfi-1.h | 2 ++ srfi/srfi-1.scm | 9 -------- 4 files changed, 72 insertions(+), 10 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index f089bed5b..1d77d7747 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,13 @@ +2006-05-28 Kevin Ryde + + * srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!): + Rewrite in C. + +2006-05-20 Kevin Ryde + + * srfi-1.c (scm_srfi1_assoc): Correction to comparison procedure + argument order, SRFI-1 specifies given key is first. + 2006-02-06 Marius Vollmer * srfi-1.scm, srfi-60.scm: Updated versions in library name to diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index a300abfda..8e27ab4e6 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -124,6 +124,65 @@ SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0, #undef FUNC_NAME + +SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0, + (SCM revhead, SCM tail), + "Reverse @var{rev-head}, append @var{tail} to it, and return the\n" + "result. This is equivalent to @code{(append (reverse\n" + "@var{rev-head}) @var{tail})}, but its implementation is more\n" + "efficient.\n" + "\n" + "@example\n" + "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n" + "@end example") +#define FUNC_NAME s_scm_srfi1_append_reverse +{ + while (scm_is_pair (revhead)) + { + /* copy first element of revhead onto front of tail */ + tail = scm_cons (SCM_CAR (revhead), tail); + revhead = SCM_CDR (revhead); + } + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME, + "list"); + return tail; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0, + (SCM revhead, SCM tail), + "Reverse @var{rev-head}, append @var{tail} to it, and return the\n" + "result. This is equivalent to @code{(append! (reverse!\n" + "@var{rev-head}) @var{tail})}, but its implementation is more\n" + "efficient.\n" + "\n" + "@example\n" + "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n" + "@end example\n" + "\n" + "@var{rev-head} may be modified in order to produce the result.") +#define FUNC_NAME s_scm_srfi1_append_reverse_x +{ + SCM newtail; + + while (scm_is_pair (revhead)) + { + /* take the first cons cell from revhead */ + newtail = revhead; + revhead = SCM_CDR (revhead); + + /* make it the new start of tail, appending the previous */ + SCM_SETCDR (newtail, tail); + tail = newtail; + } + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME, + "list"); + return tail; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0, (SCM pred, SCM lst), "Return two values, the longest initial prefix of @var{lst}\n" @@ -1557,7 +1616,7 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, SCM tmp = SCM_CAR (ls); SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME, "association list"); - if (scm_is_true (equal_p (pred, SCM_CAR (tmp), key))) + if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp)))) return tmp; } SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 810f1046d..936586697 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -33,6 +33,8 @@ #endif SCM_SRFI1_API SCM scm_srfi1_alist_copy (SCM alist); +SCM_SRFI1_API SCM scm_srfi1_append_reverse (SCM revhead, SCM tail); +SCM_SRFI1_API SCM scm_srfi1_append_reverse_x (SCM revhead, SCM tail); SCM_SRFI1_API SCM scm_srfi1_break (SCM pred, SCM lst); SCM_SRFI1_API SCM scm_srfi1_break_x (SCM pred, SCM lst); SCM_SRFI1_API SCM scm_srfi1_car_plus_cdr (SCM pair); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 252e9b312..7c55d9923 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -324,15 +324,6 @@ ;;; Miscelleneous: length, append, concatenate, reverse, zip & count -(define (append-reverse rev-head tail) - (let lp ((l rev-head) (acc tail)) - (if (null? l) - acc - (lp (cdr l) (cons (car l) acc))))) - -(define (append-reverse! rev-head tail) - (append-reverse rev-head tail)) ; XXX:optimize - (define (zip clist1 . rest) (let lp ((l (cons clist1 rest)) (acc '())) (if (any null? l) From 5be9f7290b0ac38335e66a9e68e01ac254b9912c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 22:53:04 +0000 Subject: [PATCH 004/116] merge from 1.8 branch --- guile-readline/.cvsignore | 3 +++ guile-readline/Makefile.am | 2 +- guile-readline/configure.in | 8 ++++++-- guile-readline/readline.c | 6 ++---- ice-9/ChangeLog | 12 ++++++++++++ ice-9/documentation.scm | 19 +++++++++++++------ ice-9/threads.scm | 4 ++-- libguile-ltdl/.cvsignore | 0 libguile-ltdl/COPYING.LIB | 0 libguile-ltdl/ChangeLog | 0 libguile-ltdl/Makefile.am | 0 libguile-ltdl/README | 0 libguile-ltdl/guile-ltdl.c | 0 libguile-ltdl/guile-ltdl.h | 0 libguile-ltdl/raw-ltdl.c | 0 libguile-ltdl/raw-ltdl.h | 0 libguile-ltdl/upstream/.cvsignore | 0 libguile-ltdl/upstream/Makefile.am | 0 libguile-ltdl/upstream/ltdl.c | 0 libguile-ltdl/upstream/ltdl.h | 0 20 files changed, 39 insertions(+), 15 deletions(-) delete mode 100644 libguile-ltdl/.cvsignore delete mode 100644 libguile-ltdl/COPYING.LIB delete mode 100644 libguile-ltdl/ChangeLog delete mode 100644 libguile-ltdl/Makefile.am delete mode 100644 libguile-ltdl/README delete mode 100644 libguile-ltdl/guile-ltdl.c delete mode 100644 libguile-ltdl/guile-ltdl.h delete mode 100644 libguile-ltdl/raw-ltdl.c delete mode 100644 libguile-ltdl/raw-ltdl.h delete mode 100644 libguile-ltdl/upstream/.cvsignore delete mode 100644 libguile-ltdl/upstream/Makefile.am delete mode 100644 libguile-ltdl/upstream/ltdl.c delete mode 100644 libguile-ltdl/upstream/ltdl.h diff --git a/guile-readline/.cvsignore b/guile-readline/.cvsignore index 0d3a474f6..22b5d0d48 100644 --- a/guile-readline/.cvsignore +++ b/guile-readline/.cvsignore @@ -14,8 +14,11 @@ config.status config.sub configure depcomp +guile-readline-config.h +guile-readline-config.h.in install-sh libtool ltmain.sh missing mkinstalldirs +stamp-h1 diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 6d6e16882..f1f038755 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -26,7 +26,7 @@ DEFS = @DEFS@ @EXTRA_DEFS@ ## Check for headers in $(srcdir)/.., so that #include ## will find MUMBLE.h in this dir when we're ## building. -INCLUDES = -I.. -I$(srcdir)/.. +INCLUDES = -I. -I.. -I$(srcdir)/.. GUILE_SNARF = ../libguile/guile-snarf diff --git a/guile-readline/configure.in b/guile-readline/configure.in index 1f0a08cd4..b58b46b87 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -2,7 +2,9 @@ AC_PREREQ(2.50) AC_INIT(guile-readline, m4_esyscmd(. ../GUILE-VERSION && echo -n ${GUILE_VERSION})) +AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(readline.c) +AM_CONFIG_HEADER([guile-readline-config.h]) AM_INIT_AUTOMAKE([foreign no-define]) . $srcdir/../GUILE-VERSION @@ -58,7 +60,8 @@ ac_cv_var_rl_pre_input_hook=yes, ac_cv_var_rl_pre_input_hook=no)]) AC_MSG_RESULT($ac_cv_var_rl_pre_input_hook) if test $ac_cv_var_rl_pre_input_hook = yes; then - AC_DEFINE(HAVE_RL_PRE_INPUT_HOOK) + AC_DEFINE(HAVE_RL_PRE_INPUT_HOOK,1, + [Define if rl_pre_input_hook is available.]) fi @@ -107,7 +110,8 @@ guile_cv_sigwinch_sa_restart_cleared=no, guile_cv_sigwinch_sa_restart_cleared=yes)) AC_MSG_RESULT($guile_cv_sigwinch_sa_restart_cleared) if test $guile_cv_sigwinch_sa_restart_cleared = yes; then - AC_DEFINE(GUILE_SIGWINCH_SA_RESTART_CLEARED) + AC_DEFINE(GUILE_SIGWINCH_SA_RESTART_CLEARED, 1, + [Define if readline disables SA_RESTART.]) fi AC_CACHE_CHECK([for rl_getc_function pointer in readline], diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 37eab2433..4eab67582 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -22,11 +22,9 @@ -#if HAVE_CONFIG_H -# include -#endif +/* Include private, configure generated header (i.e. config.h). */ +#include "guile-readline-config.h" -#include "libguile/_scm.h" #ifdef HAVE_RL_GETC_FUNCTION #include "libguile.h" #include "libguile/gh.h" diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f0e8294b2..690a76780 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,15 @@ +2006-05-28 Kevin Ryde + + * documentation.scm (file-commentary): Move make-regexp into + file-commentary so that it's possible to get to the repl prompt when + regexps are not available. + +2006-05-09 Kevin Ryde + + * threads.scm (n-par-for-each, n-for-each-par-map): Two more spots + where `futures' should become `threads' from Marius' change of + 2006-01-29. + 2006-03-04 Ludovic Courts * ice-9/boot-9.scm (make-autoload-interface): Don't call `set-car!' if diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 4cf3263b0..6e74799e6 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -90,14 +90,21 @@ ;; ;; commentary extraction ;; -(define default-in-line-re (make-regexp "^;;; Commentary:")) -(define default-after-line-re (make-regexp "^;;; Code:")) -(define default-scrub (let ((dirt (make-regexp "^;+"))) - (lambda (line) - (let ((m (regexp-exec dirt line))) - (if m (match:suffix m) line))))) (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB) + + ;; These are constants but are not at the top level because the repl in + ;; boot-9.scm loads session.scm which in turn loads this file, and we want + ;; that to work even even when regexps are not available (ie. make-regexp + ;; doesn't exist), as for instance is the case on mingw. + ;; + (define default-in-line-re (make-regexp "^;;; Commentary:")) + (define default-after-line-re (make-regexp "^;;; Code:")) + (define default-scrub (let ((dirt (make-regexp "^;+"))) + (lambda (line) + (let ((m (regexp-exec dirt line))) + (if m (match:suffix m) line))))) + ;; fixme: might be cleaner to use optargs here... (let ((in-line-re (if (> 1 (length cust)) default-in-line-re diff --git a/ice-9/threads.scm b/ice-9/threads.scm index 74021dc3d..cdabb2417 100644 --- a/ice-9/threads.scm +++ b/ice-9/threads.scm @@ -86,7 +86,7 @@ (threads '())) (do ((i 0 (+ 1 i))) ((= i n) - (for-each join-thread futures)) + (for-each join-thread threads)) (set! threads (cons (begin-thread (let loop () @@ -115,7 +115,7 @@ of applying P-PROC on ARGLISTS." (result results)) (do ((i 0 (+ 1 i))) ((= i n) - (for-each join-thread futures)) + (for-each join-thread threads)) (set! threads (cons (begin-thread (let loop () diff --git a/libguile-ltdl/.cvsignore b/libguile-ltdl/.cvsignore deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/COPYING.LIB b/libguile-ltdl/COPYING.LIB deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/ChangeLog b/libguile-ltdl/ChangeLog deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/Makefile.am b/libguile-ltdl/Makefile.am deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/README b/libguile-ltdl/README deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/guile-ltdl.c b/libguile-ltdl/guile-ltdl.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/guile-ltdl.h b/libguile-ltdl/guile-ltdl.h deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/raw-ltdl.c b/libguile-ltdl/raw-ltdl.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/raw-ltdl.h b/libguile-ltdl/raw-ltdl.h deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/upstream/.cvsignore b/libguile-ltdl/upstream/.cvsignore deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/upstream/Makefile.am b/libguile-ltdl/upstream/Makefile.am deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/upstream/ltdl.c b/libguile-ltdl/upstream/ltdl.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile-ltdl/upstream/ltdl.h b/libguile-ltdl/upstream/ltdl.h deleted file mode 100644 index e69de29bb..000000000 From a4f1c77ddb2057ca630b8bed9be437bdbc5dc552 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 22:57:28 +0000 Subject: [PATCH 005/116] merge from 1.8 branch And: show "1.8" not "1.10" in effective version, that being what it was at the time of that news entry --- NEWS | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 3ff9f42af..95a9b1603 100644 --- a/NEWS +++ b/NEWS @@ -12,16 +12,40 @@ Each release reports the NEWS in the following sections: * Changes to the C interface -Changes in 1.8.1: +Changes in 1.9.XXXXXXXX: + +* Changes to the distribution +* Changes to the stand-alone interpreter +* Changes to Scheme functions and syntax +* Changes to the C interface + + +Changes in 1.8.1 (since 1.8.0): + +* Changes to the distribution + +** New primitive-_exit giving the _exit() system call. * Changes to Scheme functions and syntax ** A one-dimenisonal array can now be 'equal?' to a vector. ** Structures, records, and SRFI-9 records can now be compared with `equal?'. +* Changes to the C interface + +** New function scm_c_locale_stringn_to_number. + * Bug fixes. + ** array-set! with bit vector. +** make-shared-array fixes, including examples in the manual which failed. ** stringinexact overflows on fractions with big num/den but small result. +** srfi-1 assoc "=" procedure argument order. +** Build problems on MacOS, SunOS, QNX. Changes since the 1.6.x series: @@ -46,10 +70,10 @@ headers. Guile now provides scm_effective_version and effective-version functions which return the "effective" version number. This is just the normal full version string without the final micro-version number, -so the current effective-version is "1.10". The effective version +so the current effective-version is "1.8". The effective version should remain unchanged during a stable series, and should be used for items like the versioned share directory name -i.e. /usr/share/guile/1.10. +i.e. /usr/share/guile/1.8. Providing an unchanging version number during a stable release for things like the versioned share directory can be particularly From 23f2b9a3de013f093c5913aa381219f09353c676 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 23:15:59 +0000 Subject: [PATCH 006/116] 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))))))) From c862d0e0c125808a85c5290045a4e1f87c5ac962 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 23:29:46 +0000 Subject: [PATCH 007/116] merge from 1.8 branch --- libguile/ChangeLog | 89 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 88 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 536e3cf92..cb34d8d05 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -9,6 +9,35 @@ (scm_i_struct_equalp): New. * struct.h (scm_i_struct_equalp): New declaration. +2006-06-06 Kevin Ryde + + * Makefile.am (BUILT_SOURCES): Remove guile.texi, only used by + maintainers (with doc/maint/docstring.el). Fixes parallel "make -j2" + reported by Mattias Holm. + +2006-06-03 Kevin Ryde + + * read.c (s_vector): Conditionalize on SCM_ENABLE_ELISP, to avoid + unused variable warning when elisp disabled. Reported by Ryan + VanderBijl. + + * throw.c (scm_handle_by_message): Add dummy return value to avoid + compiler warning on cygwin. Reported by Ryan VanderBijl. + + * Makefile.am (EXTRA_DOT_X_FILES): Typo in dependency rule, was a + duplicate of EXTRA_DOT_DOC_FILES. + (DOT_X_FILES, EXTRA_DOT_X_FILES, DOT_DOC_FILES, EXTRA_DOT_DOC_FILES): + Add scmconfig.h to dependencies, since these all run cpp. Helps a + parallel "make -j2". Reported by Mattias Holm. + +2006-05-30 Kevin Ryde + + * ports.c, ports.h (scm_set_port_mark, scm_set_port_free, + scm_set_port_print, scm_set_port_equalp, scm_set_port_flush, + scm_set_port_end_input, scm_set_port_close, scm_set_port_seek, + scm_set_port_truncate, scm_set_port_input_waiting): Use scm_t_bits for + port type descriptor, same as scm_make_port_type return value. + 2006-05-30 Marius Vollmer * eq.c (scm_equal_p): Use scm_array_equal_p explicitely when one @@ -21,16 +50,74 @@ that we have a pair before accessing its cdr. Thanks to Bill Schottstaedt! -2006-05-28 Marius Vollmer +2006-05-28 Kevin Ryde + + * eval.c, filesys.c: Add malloc.h to get alloca() on mingw. Reported + by "The Senator". + +2006-05-27 Marius Vollmer * srfi-4.c, strings.c: Replace SCM_C_INLINE with SCM_C_INLINE_KEYWORD. Thanks to Mark Gran! +2006-05-26 Kevin Ryde + + * fports.c (fport_input_waiting): For ioctl, check HAVE_IOCTL as well + as defined(FIONREAD), since mingw has FIONREAD but not ioctl(). + Reported by "The Senator". + For select and ioctl, move fdes into those conditionals, to avoid + unused variable warning when neither of those used. + +2006-05-23 Kevin Ryde + + * fports.c: Remove "fwrite" declaration under "! HAVE_UNISTD_H". + It's unused and will be in stdio.h anyway (if it's anywhere). + +2006-05-20 Kevin Ryde + + * filesys.c (scm_stat2scm): Test #ifdef S_ISLNK directly, rather than + HAVE_S_ISLNK from configure (it was only a #ifdef test anyway). + + * posix.c (scm_mknod): Test #ifdef S_IFLNK before using that (for + symlink). Probably can't create symlinks with mknod anyway though. + + * inline.h (scm_is_pair): Add a workaround for i386 gcc 2.95 bad code + generation. + +2006-05-15 Kevin Ryde + + * simpos.c, simpos.h (scm_primitive__exit): New function. + (scm_primitive_exit): Update docstring, no longer the best exit after + a fork. + +2006-05-09 Kevin Ryde + + * numbers.c (scm_i_divide): For big/big wanting inexact, use mpq_get_d + rather than converting to doubles, to avoid inf or nan when the inputs + are too big for a double but the quotient does fit. This affects + conversions exact->inexact of big fractions. + + * filesys.c (scm_open_fdes): Use open64. + (scm_init_filesys): Add O_LARGEFILE. + + * ports.c (scm_seek): Use lseek64. + (scm_truncate_file): Use ftruncate64. + 2006-05-08 Marius Vollmer * private-gc.h (CELL_P): Also check that the potential pointer is correctly aligned for a cell. Thanks to Miroslav Lichvar! +2006-04-18 Rob Browning + + * _scm.h: Add back error if the size of off_t is unknown. The bug + was actually in guile-readline's configuration. + +2006-04-18 Kevin Ryde + + * posix.c (scm_mkstemp): Update docstring from the manual, in + particular file mode 0600 is not guaranteed. + 2006-04-17 Kevin Ryde * _scm.h (scm_to_off_t, scm_from_off_t): No error if unknown off_t From 22acb29853fb9d427fe44f5318a083e67a04bc62 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 17 Jun 2006 23:41:24 +0000 Subject: [PATCH 008/116] merge from 1.8 branch --- guile-readline/ChangeLog | 20 ++++++++++++++++++++ libguile/_scm.h | 14 ++++++++------ 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e658108ae..383541575 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -3,6 +3,26 @@ * ice-9/readline.scm: Bump lib file version to libguilereadline-v-18, matching LIBGUILEREADLINE-VERSION. +2006-05-15 Kevin Ryde + + * Makefile.am (INCLUDES): Add "-I." to pick up guile-readline-config.h + in snarfer. + +2006-04-18 Rob Browning + + * .cvsignore: Add guile-readline-config.h and + guile-readline-config.h.in. + + * readline.c: Don't include Guile private header _scm.h. + Include new guile-readline-config.h private header. + + * configure.in: Add AC_CONFIG_AUX_DIR([.]) as suggested in the + autotools documentation. Add + AM_CONFIG_HEADER([guile-readline-config.h]) so that guile-readline + will have its own configure-based config.h equivalent. + (HAVE_RL_PRE_INPUT_HOOK): Add documentation template. + (GUILE_SIGWINCH_SA_RESTART_CLEARED): Add documentation template. + 2006-03-12 Neil Jerram * ice-9/readline.scm (make-completion-function): New. diff --git a/libguile/_scm.h b/libguile/_scm.h index 0b97c432e..ea654ad39 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -145,6 +145,7 @@ #define dirent_or_dirent64 CHOOSE_LARGEFILE(dirent,dirent64) #define fstat_or_fstat64 CHOOSE_LARGEFILE(fstat,fstat64) #define ftruncate_or_ftruncate64 CHOOSE_LARGEFILE(ftruncate,ftruncate64) +#define lseek_or_lseek64 CHOOSE_LARGEFILE(lseek,lseek64) #define lstat_or_lstat64 CHOOSE_LARGEFILE(lstat,lstat64) #define off_t_or_off64_t CHOOSE_LARGEFILE(off_t,off64_t) #define open_or_open64 CHOOSE_LARGEFILE(open,open64) @@ -158,12 +159,13 @@ #define scm_to_off_t_or_off64_t CHOOSE_LARGEFILE(scm_to_off_t,scm_to_int64) #if SIZEOF_OFF_T == 4 -#define scm_to_off_t scm_to_int32 -#define scm_from_off_t scm_from_int32 -#endif -#if SIZEOF_OFF_T == 8 -#define scm_to_off_t scm_to_int64 -#define scm_from_off_t scm_from_int64 +# define scm_to_off_t scm_to_int32 +# define scm_from_off_t scm_from_int32 +#elif SIZEOF_OFF_T == 8 +# define scm_to_off_t scm_to_int64 +# define scm_from_off_t scm_from_int64 +#else +# error sizeof(off_t) is not 4 or 8. #endif From 731bcf738eb2746cef3bcbdca8353f1c9c862bd2 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 19 Jun 2006 22:01:23 +0000 Subject: [PATCH 009/116] * Makefile.am: New file. * gds.el, gds-scheme.el, gds-server.el: New files. --- emacs/ChangeLog | 6 + emacs/Makefile.am | 27 ++ emacs/gds-scheme.el | 1038 +++++++++++++++++++++++++++++++++++++++++++ emacs/gds-server.el | 110 +++++ emacs/gds.el | 628 ++++++++++++++++++++++++++ 5 files changed, 1809 insertions(+) create mode 100644 emacs/Makefile.am create mode 100755 emacs/gds-scheme.el create mode 100644 emacs/gds-server.el create mode 100644 emacs/gds.el diff --git a/emacs/ChangeLog b/emacs/ChangeLog index ab4969cab..2396af25c 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,9 @@ +2006-06-19 Neil Jerram + + * Makefile.am: New file. + + * gds.el, gds-scheme.el, gds-server.el: New files. + 2005-07-09 Neil Jerram * Makefile.am, REAME.GDS, gds-client.scm, gds-problems.txt, diff --git a/emacs/Makefile.am b/emacs/Makefile.am new file mode 100644 index 000000000..e10043c2b --- /dev/null +++ b/emacs/Makefile.am @@ -0,0 +1,27 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2006 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE 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 General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth +## Floor, Boston, MA 02110-1301 USA + +AUTOMAKE_OPTIONS = gnu + +dist_lisp_LISP = gds.el gds-server.el gds-scheme.el +ELCFILES = + +ETAGS_ARGS = $(dist_lisp_LISP) diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el new file mode 100755 index 000000000..f5d235edf --- /dev/null +++ b/emacs/gds-scheme.el @@ -0,0 +1,1038 @@ +;;; gds-scheme.el -- GDS function for Scheme mode buffers + +;;;; Copyright (C) 2005 Neil Jerram +;;;; +;;;; 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA + +(require 'comint) +(require 'scheme) +(require 'derived) +(require 'pp) + +;;;; Maintaining an association between a Guile client process and a +;;;; set of Scheme mode buffers. + +(defcustom gds-auto-create-utility-client t + "Whether to automatically create a utility Guile client, and +associate the current buffer with it, if there are no existing Guile +clients available to GDS when the user does something that requires a +running Guile client." + :type 'boolean + :group 'gds) + +(defcustom gds-auto-associate-single-client t + "Whether to automatically associate the current buffer with an +existing Guile client, if there is only only client known to GDS when +the user does something that requires a running Guile client, and the +current buffer is not already associated with a Guile client." + :type 'boolean + :group 'gds) + +(defcustom gds-auto-associate-last-client t + "Whether to automatically associate the current buffer with the +Guile client that most recently caused that buffer to be displayed, +when the user does something that requires a running Guile client and +the current buffer is not already associated with a Guile client." + :type 'boolean + :group 'gds) + +(defvar gds-last-touched-by nil + "For each Scheme mode buffer, this records the GDS client that most +recently `touched' that buffer in the sense of using it to display +source code, for example for the source code relevant to a debugger +stack frame.") +(make-variable-buffer-local 'gds-last-touched-by) + +(defun gds-auto-associate-buffer () + "Automatically associate the current buffer with a Guile client, if +possible." + (let* ((num-clients (length gds-client-info)) + (client + (or + ;; If there are no clients yet, and + ;; `gds-auto-create-utility-client' allows us to create one + ;; automatically, do that. + (and (= num-clients 0) + gds-auto-create-utility-client + (gds-start-utility-guile)) + ;; Otherwise, if there is a single existing client, and + ;; `gds-auto-associate-single-client' allows us to use it + ;; for automatic association, do that. + (and (= num-clients 1) + gds-auto-associate-single-client + (caar gds-client-info)) + ;; Otherwise, if the current buffer was displayed because + ;; of a Guile client trapping somewhere in its code, and + ;; `gds-auto-associate-last-client' allows us to associate + ;; with that client, do so. + (and gds-auto-associate-last-client + gds-last-touched-by)))) + (if client + (gds-associate-buffer client)))) + +(defun gds-associate-buffer (client) + "Associate the current buffer with the Guile process CLIENT. +This means that operations in this buffer that require a running Guile +process - such as evaluation, help, completion and setting traps - +will be sent to the Guile process whose name or connection number is +CLIENT." + (interactive (list (gds-choose-client))) + ;; If this buffer is already associated, dissociate from its + ;; existing client first. + (if gds-client (gds-dissociate-buffer)) + ;; Store the client number in the buffer-local variable gds-client. + (setq gds-client client) + ;; Add this buffer to the list of buffers associated with the + ;; client. + (gds-client-put client 'associated-buffers + (cons (current-buffer) + (gds-client-get client 'associated-buffers)))) + +(defun gds-dissociate-buffer () + "Dissociate the current buffer from any specific Guile process." + (interactive) + (if gds-client + (progn + ;; Remove this buffer from the list of buffers associated with + ;; the current client. + (gds-client-put gds-client 'associated-buffers + (delq (current-buffer) + (gds-client-get gds-client 'associated-buffers))) + ;; Reset the buffer-local variable gds-client. + (setq gds-client nil) + ;; Clear any process status indication from the modeline. + (setq mode-line-process nil) + (force-mode-line-update)))) + +(defun gds-show-client-status (client status-string) + "Show a client's status in the modeline of all its associated +buffers." + (let ((buffers (gds-client-get client 'associated-buffers))) + (while buffers + (if (buffer-live-p (car buffers)) + (with-current-buffer (car buffers) + (setq mode-line-process status-string) + (force-mode-line-update))) + (setq buffers (cdr buffers))))) + +(defcustom gds-running-text ":running" + "*Mode line text used to show that a Guile process is \"running\". +\"Running\" means that the process cannot currently accept any input +from the GDS frontend in Emacs, because all of its threads are busy +running code that GDS cannot easily interrupt." + :type 'string + :group 'gds) + +(defcustom gds-ready-text ":ready" + "*Mode line text used to show that a Guile process is \"ready\". +\"Ready\" means that the process is ready to interact with the GDS +frontend in Emacs, because at least one of its threads is waiting for +GDS input." + :type 'string + :group 'gds) + +(defcustom gds-debug-text ":debug" + "*Mode line text used to show that a Guile process is \"debugging\". +\"Debugging\" means that the process is using the GDS frontend in +Emacs to display an error or trap so that the user can debug it." + :type 'string + :group 'gds) + +(defun gds-choose-client () + "Ask the user to choose a GDS client process from a list." + (let ((table '()) + (default nil)) + ;; Prepare a table containing all current clients. + (mapcar (lambda (client-info) + (setq table (cons (cons (cadr (assq 'name client-info)) + (car client-info)) + table))) + gds-client-info) + ;; Add an entry to allow the user to ask for a new process. + (setq table (cons (cons "Start a new Guile process" nil) table)) + ;; Work out a good default. If the buffer has a good value in + ;; gds-last-touched-by, we use that; otherwise default to starting + ;; a new process. + (setq default (or (and gds-last-touched-by + (gds-client-get gds-last-touched-by 'name)) + (caar table))) + ;; Read using this table. + (let* ((name (completing-read "Choose a Guile process: " + table + nil + t ; REQUIRE-MATCH + nil ; INITIAL-INPUT + nil ; HIST + default)) + ;; Convert name to a client number. + (client (cdr (assoc name table)))) + ;; If the user asked to start a new Guile process, do that now. + (or client (setq client (gds-start-utility-guile))) + ;; Return the chosen client ID. + client))) + +(defvar gds-last-utility-number 0 + "Number of the last started Guile utility process.") + +(defun gds-start-utility-guile () + "Start a new utility Guile process." + (setq gds-last-utility-number (+ gds-last-utility-number 1)) + (let* ((procname (format "gds-util[%d]" gds-last-utility-number)) + (code (format "(begin + %s + (use-modules (ossau gds-client)) + (run-utility))" + (if gds-scheme-directory + (concat "(set! %load-path (cons " + (format "%S" gds-scheme-directory) + " %load-path))") + ""))) + (proc (start-process procname + (get-buffer-create procname) + gds-guile-program + "-q" + "--debug" + "-c" + code)) + (client nil)) + ;; Note that this process can be killed automatically on Emacs + ;; exit. + (process-kill-without-query proc) + ;; Set up a process filter to catch the new client's number. + (set-process-filter proc + (lambda (proc string) + (setq client (string-to-number string)) + (if (process-buffer proc) + (with-current-buffer (process-buffer proc) + (insert string))))) + ;; Accept output from the new process until we have its number. + (while (not client) + (accept-process-output proc)) + ;; Return the new process's client number. + client)) + +;;;; Evaluating code. + +;; The following commands send code for evaluation through the GDS TCP +;; connection, receive the result and any output generated through the +;; same connection, and display the result and output to the user. +;; +;; For each buffer where evaluations can be requested, GDS uses the +;; buffer-local variable `gds-client' to track which GDS client +;; program should receive and handle that buffer's evaluations. + +(defun gds-module-name (start end) + "Determine and return the name of the module that governs the +specified region. The module name is returned as a list of symbols." + (interactive "r") ; why not? + (save-excursion + (goto-char start) + (let (module-name) + (while (and (not module-name) + (beginning-of-defun-raw 1)) + (if (looking-at "(define-module ") + (setq module-name + (progn + (goto-char (match-end 0)) + (read (current-buffer)))))) + module-name))) + +(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: " + "Prefix used when telling Guile the name of the port from which a +chunk of Scheme code (to be evaluated) comes. GDS uses this prefix, +followed by the buffer name, in two cases: when the buffer concerned +is not associated with a file, or if the buffer has been modified +since last saving to its file. In the case where the buffer is +identical to a saved file, GDS uses the file name as the port name." + :type '(string) + :group 'gds) + +(defun gds-port-name (start end) + "Return port name for the specified region of the current buffer. +The name will be used by Guile as the port name when evaluating that +region's code." + (or (and (not (buffer-modified-p)) + buffer-file-name) + (concat gds-emacs-buffer-port-name-prefix (buffer-name)))) + +(defun gds-line-and-column (pos) + "Return 0-based line and column number at POS." + (let (line column) + (save-excursion + (goto-char pos) + (setq column (current-column)) + (beginning-of-line) + (setq line (count-lines (point-min) (point)))) + (cons line column))) + +(defun gds-eval-region (start end) + "Evaluate the current region." + (interactive "r") + (or gds-client + (gds-auto-associate-buffer) + (call-interactively 'gds-associate-buffer)) + (let ((module (gds-module-name start end)) + (port-name (gds-port-name start end)) + (lc (gds-line-and-column start))) + (let ((code (buffer-substring-no-properties start end))) + (gds-send (format "eval (region . %S) %s %S %d %d %S" + (gds-abbreviated code) + (if module (prin1-to-string module) "#f") + port-name (car lc) (cdr lc) + code) + gds-client)))) + +(defun gds-eval-expression (expr &optional correlator) + "Evaluate the supplied EXPR (a string)." + (interactive "sEvaluate expression: \nP") + (or gds-client + (gds-auto-associate-buffer) + (call-interactively 'gds-associate-buffer)) + (set-text-properties 0 (length expr) nil expr) + (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S" + (or correlator 'expression) + (gds-abbreviated expr) + expr) + gds-client)) + +(defconst gds-abbreviated-length 35) + +(defun gds-abbreviated (code) + (let ((nlpos (string-match (regexp-quote "\n") code))) + (while nlpos + (setq code + (if (= nlpos (- (length code) 1)) + (substring code 0 nlpos) + (concat (substring code 0 nlpos) + "\\n" + (substring code (+ nlpos 1))))) + (setq nlpos (string-match (regexp-quote "\n") code)))) + (if (> (length code) gds-abbreviated-length) + (concat (substring code 0 (- gds-abbreviated-length 3)) "...") + code)) + +(defun gds-eval-defun () + "Evaluate the defun (top-level form) at point." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (gds-eval-region (point) end)))) + +(defun gds-eval-last-sexp () + "Evaluate the sexp before point." + (interactive) + (gds-eval-region (save-excursion (backward-sexp) (point)) (point))) + +;;;; Help. + +;; Help is implemented as a special case of evaluation, identified by +;; the evaluation correlator 'help. + +(defun gds-help-symbol (sym) + "Get help for SYM (a Scheme symbol)." + (interactive + (let ((sym (thing-at-point 'symbol)) + (enable-recursive-minibuffers t) + val) + (setq val (read-from-minibuffer + (if sym + (format "Describe Guile symbol (default %s): " sym) + "Describe Guile symbol: "))) + (list (if (zerop (length val)) sym val)))) + (gds-eval-expression (format "(help %s)" sym) 'help)) + +(defun gds-apropos (regex) + "List Guile symbols matching REGEX." + (interactive + (let ((sym (thing-at-point 'symbol)) + (enable-recursive-minibuffers t) + val) + (setq val (read-from-minibuffer + (if sym + (format "Guile apropos (regexp, default \"%s\"): " sym) + "Guile apropos (regexp): "))) + (list (if (zerop (length val)) sym val)))) + (set-text-properties 0 (length regex) nil regex) + (gds-eval-expression (format "(apropos %S)" regex) 'apropos)) + +;;;; Displaying results of help and eval. + +(defun gds-display-results (client correlator stack-available results) + (let* ((helpp+bufname (cond ((eq (car correlator) 'help) + '(t . "*Guile Help*")) + ((eq (car correlator) 'apropos) + '(t . "*Guile Apropos*")) + (t + '(nil . "*Guile Evaluation*")))) + (helpp (car helpp+bufname))) + (let ((buf (get-buffer-create (cdr helpp+bufname)))) + (save-excursion + (set-buffer buf) + (gds-dissociate-buffer) + (erase-buffer) + (scheme-mode) + (insert (cdr correlator) "\n\n") + (while results + (insert (car results)) + (or (bolp) (insert "\\\n")) + (if helpp + nil + (if (cadr results) + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert " => no (or unspecified) value\n")) + (insert "\n")) + (setq results (cddr results))) + (if stack-available + (let ((beg (point)) + (map (make-sparse-keymap))) + (define-key map [mouse-1] 'gds-show-last-stack) + (insert "[click here to show error stack]") + (add-text-properties beg (point) + (list 'keymap map + 'mouse-face 'highlight)) + (insert "\n"))) + (goto-char (point-min)) + (gds-associate-buffer client)) + (pop-to-buffer buf) + (run-hooks 'temp-buffer-show-hook) + (other-window 1)))) + +(defun gds-show-last-stack () + "Show stack of the most recent error." + (interactive) + (or gds-client + (gds-auto-associate-buffer) + (call-interactively 'gds-associate-buffer)) + (gds-send "debug-lazy-trap-context" gds-client)) + +;;;; Completion. + +(defvar gds-completion-results nil) + +(defun gds-complete-symbol () + "Complete the Guile symbol before point. Returns `t' if anything +interesting happened, `nil' if not." + (interactive) + (or gds-client + (gds-auto-associate-buffer) + (call-interactively 'gds-associate-buffer)) + (let* ((chars (- (point) (save-excursion + (while (let ((syntax (char-syntax (char-before (point))))) + (or (eq syntax ?w) (eq syntax ?_))) + (forward-char -1)) + (point))))) + (if (zerop chars) + nil + (setq gds-completion-results nil) + (gds-send (format "complete %s" + (prin1-to-string + (buffer-substring-no-properties (- (point) chars) + (point)))) + gds-client) + (while (null gds-completion-results) + (accept-process-output gds-debug-server 0 200)) + (cond ((eq gds-completion-results 'error) + (error "Internal error - please report the contents of the *Guile Evaluation* window")) + ((eq gds-completion-results t) + nil) + ((stringp gds-completion-results) + (if (<= (length gds-completion-results) chars) + nil + (insert (substring gds-completion-results chars)) + (message "Sole completion") + t)) + ((= (length gds-completion-results) 1) + (if (<= (length (car gds-completion-results)) chars) + nil + (insert (substring (car gds-completion-results) chars)) + t)) + (t + (with-output-to-temp-buffer "*Completions*" + (display-completion-list gds-completion-results)) + t))))) + +;;;; Breakpoints. + +(defvar gds-bufferless-breakpoints nil + "The list of breakpoints that are not yet associated with a +particular buffer. Each element looks like (BPDEF BPNUM) where BPDEF +is the breakpoint definition and BPNUM the breakpoint's unique +GDS-assigned number. A breakpoint definition BPDEF is a list of the +form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug +or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file +where the breakpoint is (or will be) set, and TYPE-ARGS is: + +- the name of the procedure to break in, if TYPE is 'in + +- the line number and column number to break at, if TYPE is 'at. + +If persistent breakpoints are enabled (by configuring +gds-breakpoints-file-name), this list is initialized when GDS is +loaded by reading gds-breakpoints-file-name.") + +(defsubst gds-bpdef:behaviour (bpdef) + (nth 0 bpdef)) + +(defsubst gds-bpdef:type (bpdef) + (nth 1 bpdef)) + +(defsubst gds-bpdef:file-name (bpdef) + (nth 2 bpdef)) + +(defsubst gds-bpdef:proc-name (bpdef) + (nth 3 bpdef)) + +(defsubst gds-bpdef:lc (bpdef) + (nth 3 bpdef)) + +(defvar gds-breakpoint-number 0 + "The last assigned breakpoint number. GDS increments this whenever +it creates a new breakpoint.") + +(defvar gds-breakpoint-buffers nil + "The list of buffers that contain GDS breakpoints. When Emacs +visits a Scheme file, GDS checks to see if any of the breakpoints in +the bufferless list can be assigned to that file's buffer. If they +can, they are removed from the bufferless list and become breakpoint +overlays in that buffer. To retain the ability to enumerate all +breakpoints, therefore, we keep a list of all such buffers.") + +(defvar gds-breakpoint-programming nil + "Information about how each breakpoint is actually programmed in the +Guile clients that GDS is connected to. This is an alist of the form +\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint +number, CLIENT is the number of a GDS client, and TRAPLIST is the list +of traps that that client has created for the breakpoint concerned (in +an arbitrary but Emacs-readable format).") + +(defvar gds-breakpoint-cache nil + "Buffer-local cache of breakpoints in a particular buffer. When a +breakpoint is represented as an overlay is a Scheme mode buffer, we +need to be able to detect when the user has caused that overlay to +evaporate by deleting a region of code that included it. We do this +detection when the buffer is next saved, by comparing the current set +of overlays with this cache. The cache is a list in which each +element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already +described. The handling of such breakpoints (which we call \"lost\") +is controlled by the setting of gds-delete-lost-breakpoints.") +(make-variable-buffer-local 'gds-breakpoint-cache) + +(defface gds-breakpoint-face + '((((background dark)) (:background "red")) + (t (:background "pink"))) + "*Face used to highlight the location of a breakpoint." + :group 'gds) + +(defcustom gds-breakpoints-file-name "~/.gds-breakpoints" + "Name of file used to store GDS breakpoints between sessions. +You can disable breakpoint persistence by setting this to nil." + :group 'gds + :type '(choice (const :tag "nil" nil) file)) + +(defcustom gds-delete-lost-breakpoints nil + "Whether to delete lost breakpoints. + +A non-nil value means that the Guile clients where lost breakpoints +were programmed will be told immediately to delete their breakpoints. +\"Immediately\" means when the lost breakpoints are detected, which +means when the buffer that previously contained them is saved. Thus, +even if the affected code (which the GDS user has deleted from his/her +buffer in Emacs) is still in use in the Guile clients, the breakpoints +that were previously set in that code will no longer take effect. + +Nil (which is the default) means that GDS leaves such breakpoints +active in their Guile clients. This allows those breakpoints to +continue taking effect until the affected code is no longer used by +the Guile clients." + :group 'gds + :type 'boolean) + +(defvar gds-bpdefs-cache nil) + +(defun gds-read-breakpoints-file () + "Read the persistent breakpoints file, and use its contents to +initialize GDS's global breakpoint variables." + (let ((bpdefs (condition-case nil + (with-current-buffer + (find-file-noselect gds-breakpoints-file-name) + (goto-char (point-min)) + (read (current-buffer))) + (error nil)))) + ;; Cache the overall value so we don't unnecessarily modify the + ;; breakpoints buffer when `gds-write-breakpoints-file' is called. + (setq gds-bpdefs-cache bpdefs) + ;; Move definitions into the bufferless breakpoint list, assigning + ;; breakpoint numbers as we go. + (setq gds-bufferless-breakpoints + (mapcar (function (lambda (bpdef) + (setq gds-breakpoint-number + (1+ gds-breakpoint-number)) + (list bpdef gds-breakpoint-number))) + bpdefs)) + ;; Check each existing Scheme buffer to see if it wants to take + ;; ownership of any of these breakpoints. + (mapcar (function (lambda (buffer) + (with-current-buffer buffer + (if (eq (derived-mode-class major-mode) 'scheme-mode) + (gds-adopt-breakpoints))))) + (buffer-list)))) + +(defun gds-adopt-breakpoints () + "Take ownership of any of the breakpoints in the bufferless list +that match the current buffer." + (mapcar (function gds-adopt-breakpoint) + (copy-sequence gds-bufferless-breakpoints))) + +(defun gds-adopt-breakpoint (bpdefnum) + "Take ownership of the specified breakpoint if it matches the +current buffer." + (let ((bpdef (car bpdefnum)) + (bpnum (cadr bpdefnum))) + ;; Check if breakpoint's file name matches. If it does, try to + ;; convert the breakpoint definition to a breakpoint overlay in + ;; the current buffer. + (if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name) + (gds-make-breakpoint-overlay bpdef bpnum)) + ;; That all succeeded, so this breakpoint is no longer + ;; bufferless. + (setq gds-bufferless-breakpoints + (delq bpdefnum gds-bufferless-breakpoints))))) + +(defun gds-make-breakpoint-overlay (bpdef &optional bpnum) + ;; If no explicit number given, assign the next available breakpoint + ;; number. + (or bpnum + (setq gds-breakpoint-number (+ gds-breakpoint-number 1) + bpnum gds-breakpoint-number)) + ;; First decide where the overlay should be, and create it there. + (let ((o (cond ((eq (gds-bpdef:type bpdef) 'at) + (save-excursion + (goto-line (+ (car (gds-bpdef:lc bpdef)) 1)) + (move-to-column (cdr (gds-bpdef:lc bpdef))) + (make-overlay (point) (1+ (point))))) + ((eq (gds-bpdef:type bpdef) 'in) + (save-excursion + (goto-char (point-min)) + (and (re-search-forward (concat "^(define +(?\\(" + (regexp-quote + (gds-bpdef:proc-name + bpdef)) + "\\>\\)") + nil t) + (make-overlay (match-beginning 1) (match-end 1))))) + (t + (error "Bad breakpoint type"))))) + ;; If that succeeded, initialize the overlay's properties. + (if o + (progn + (overlay-put o 'evaporate t) + (overlay-put o 'face 'gds-breakpoint-face) + (overlay-put o 'gds-breakpoint-number bpnum) + (overlay-put o 'gds-breakpoint-definition bpdef) + (overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef)) + (overlay-put o 'priority 1000) + ;; Make sure that the current buffer is included in + ;; `gds-breakpoint-buffers'. + (or (memq (current-buffer) gds-breakpoint-buffers) + (setq gds-breakpoint-buffers + (cons (current-buffer) gds-breakpoint-buffers))) + ;; Add the new breakpoint to this buffer's cache. + (setq gds-breakpoint-cache + (cons (list bpdef bpnum) gds-breakpoint-cache)) + ;; If this buffer is associated with a client, tell the + ;; client about the new breakpoint. + (if gds-client (gds-send-breakpoint-to-client bpnum bpdef)))) + ;; Return the overlay, or nil if we weren't able to convert the + ;; breakpoint definition. + o)) + +(defun gds-send-breakpoint-to-client (bpnum bpdef) + "Send specified breakpoint to this buffer's Guile client." + (gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client)) + +(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints)) + +(defcustom gds-default-breakpoint-type 'debug + "The type of breakpoint set by `C-x SPC'." + :group 'gds + :type '(choice (const :tag "debug" debug) (const :tag "trace" trace))) + +(defun gds-set-breakpoint () + "Create a new GDS breakpoint at point." + (interactive) + ;; Set up beg and end according to whether the mark is active. + (if mark-active + ;; Set new breakpoints on all opening parentheses in the region. + (let ((beg (region-beginning)) + (end (region-end))) + (save-excursion + (goto-char beg) + (beginning-of-defun) + (let ((defun-start (point))) + (goto-char beg) + (while (search-forward "(" end t) + (let ((state (parse-partial-sexp defun-start (point))) + (pos (- (point) 1))) + (or (nth 3 state) + (nth 4 state) + (gds-breakpoint-overlays-at pos) + (gds-make-breakpoint-overlay (list gds-default-breakpoint-type + 'at + buffer-file-name + (gds-line-and-column + pos))))))))) + ;; Set a new breakpoint on the defun at point. + (let ((region (gds-defun-name-region))) + ;; Complain if there is no defun at point. + (or region + (error "Point is not in a procedure definition")) + ;; Don't create another breakpoint if there is already one here. + (if (gds-breakpoint-overlays-at (car region)) + (error "There is already a breakpoint here")) + ;; Create and return the new breakpoint overlay. + (gds-make-breakpoint-overlay (list gds-default-breakpoint-type + 'in + buffer-file-name + (buffer-substring-no-properties + (car region) + (cdr region)))))) + ;; Update the persistent breakpoints file. + (gds-write-breakpoints-file)) + +(defun gds-defun-name-region () + "If point is in a defun, return the beginning and end positions of +the identifier being defined." + (save-excursion + (let ((p (point))) + (beginning-of-defun) + ;; Check that we are looking at some kind of procedure + ;; definition. + (and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)") + (let ((beg (match-beginning 1)) + (end (match-end 1))) + (end-of-defun) + ;; Check here that we have reached past the original point + ;; position. + (and (>= (point) p) + (cons beg end))))))) + +(defun gds-breakpoint-overlays-at (pos) + "Return a list of GDS breakpoint overlays at the specified position." + (let ((os (overlays-at pos)) + (breakpoint-os nil)) + ;; Of the overlays at POS, select all those that have a + ;; gds-breakpoint-definition property. + (while os + (if (overlay-get (car os) 'gds-breakpoint-definition) + (setq breakpoint-os (cons (car os) breakpoint-os))) + (setq os (cdr os))) + breakpoint-os)) + +(defun gds-write-breakpoints-file () + "Write the persistent breakpoints file, if configured." + (if gds-breakpoints-file-name + (let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init) + (cons bpdef init))) + t))) + (or (equal bpdefs gds-bpdefs-cache) + (with-current-buffer (find-file-noselect gds-breakpoints-file-name) + (erase-buffer) + (pp (reverse bpdefs) (current-buffer)) + (setq gds-bpdefs-cache bpdefs) + (let ((auto-fill-function normal-auto-fill-function)) + (newline))))))) + +(defun gds-fold-breakpoints (fn &optional foldp init) + ;; Run through bufferless breakpoints first. + (let ((bbs gds-bufferless-breakpoints)) + (while bbs + (let ((bpnum (cadr (car bbs))) + (bpdef (caar bbs))) + (if foldp + (setq init (funcall fn bpnum bpdef init)) + (funcall fn bpnum bpdef))) + (setq bbs (cdr bbs)))) + ;; Now run through breakpoint buffers. + (let ((outbuf (current-buffer)) + (bpbufs gds-breakpoint-buffers)) + (while bpbufs + (let ((buf (car bpbufs))) + (if (buffer-live-p buf) + (with-current-buffer buf + (save-restriction + (widen) + (let ((os (overlays-in (point-min) (point-max)))) + (while os + (let ((bpnum (overlay-get (car os) + 'gds-breakpoint-number)) + (bpdef (overlay-get (car os) + 'gds-breakpoint-definition))) + (if bpdef + (with-current-buffer outbuf + (if foldp + (setq init (funcall fn bpnum bpdef init)) + (funcall fn bpnum bpdef))))) + (setq os (cdr os)))))))) + (setq bpbufs (cdr bpbufs)))) + init) + +(defun gds-delete-breakpoints () + "Delete GDS breakpoints in the region or at point." + (interactive) + (if mark-active + ;; Delete all breakpoints in the region. + (let ((os (overlays-in (region-beginning) (region-end)))) + (while os + (if (overlay-get (car os) 'gds-breakpoint-definition) + (gds-delete-breakpoint (car os))) + (setq os (cdr os)))) + ;; Delete the breakpoint "at point". + (call-interactively (function gds-delete-breakpoint)))) + +(defun gds-delete-breakpoint (o) + (interactive (list (or (gds-breakpoint-at-point) + (error "There is no breakpoint here")))) + (let ((bpdef (overlay-get o 'gds-breakpoint-definition)) + (bpnum (overlay-get o 'gds-breakpoint-number))) + ;; If this buffer is associated with a client, tell the client + ;; that the breakpoint has been deleted. + (if (and bpnum gds-client) + (gds-send (format "delete-breakpoint %d" bpnum) gds-client)) + ;; Remove this breakpoint from the cache also, so it isn't later + ;; detected as having been "lost". + (setq gds-breakpoint-cache + (delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache))) + ;; Remove the overlay from its buffer. + (delete-overlay o) + ;; If that was the last breakpoint in this buffer, remove this + ;; buffer from gds-breakpoint-buffers. + (or gds-breakpoint-cache + (setq gds-breakpoint-buffers + (delq (current-buffer) gds-breakpoint-buffers))) + ;; Update the persistent breakpoints file. + (gds-write-breakpoints-file)) + +(defun gds-breakpoint-at-point () + "Find and return the overlay for a breakpoint `at' the current +cursor position. This is intended for use in other functions' +interactive forms, so it intentionally uses the minibuffer in some +situations." + (let* ((region (gds-defun-name-region)) + (os (gds-union (gds-breakpoint-overlays-at (point)) + (and region + (gds-breakpoint-overlays-at (car region)))))) + ;; Switch depending whether we found 0, 1 or more overlays. + (cond ((null os) + ;; None found: return nil. + nil) + ((= (length os) 1) + ;; One found: return it. + (car os)) + (t + ;; More than 1 found: ask the user to choose. + (gds-user-selected-breakpoint os))))) + +(defun gds-union (first second &rest others) + (if others + (gds-union first (apply 'gds-union second others)) + (progn + (while first + (or (memq (car first) second) + (setq second (cons (car first) second))) + (setq first (cdr first))) + second))) + +(defun gds-user-selected-breakpoint (os) + "Ask the user to choose one of the given list of breakpoints, and +return the one that they chose." + (let ((table (mapcar + (lambda (o) + (cons (format "%S" + (overlay-get o 'gds-breakpoint-definition)) + o)) + os))) + (cdr (assoc (completing-read "Which breakpoint do you mean? " + table nil t) + table)))) + +(defun gds-describe-breakpoints () + "Describe all breakpoints and their programming status." + (interactive) + (with-current-buffer (get-buffer-create "*GDS Breakpoints*") + (erase-buffer) + (gds-fold-breakpoints (function gds-describe-breakpoint)) + (display-buffer (current-buffer)))) + +(defun gds-describe-breakpoint (bpnum bpdef) + (insert (format "Breakpoint %d: %S\n" bpnum bpdef)) + (let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming)))) + (mapcar (lambda (clientprog) + (let ((client (car clientprog)) + (traplist (cdr clientprog))) + (mapcar (lambda (trap) + (insert (format " Client %d: %S\n" client trap))) + traplist))) + bpproglist))) + +(defun gds-after-save-update-breakpoints () + "Function called when a buffer containing breakpoints is saved." + (if (eq (derived-mode-class major-mode) 'scheme-mode) + (save-restriction + (widen) + ;; Get the current breakpoint overlays. + (let ((os (overlays-in (point-min) (point-max))) + (cache (copy-sequence gds-breakpoint-cache))) + ;; Identify any overlays that have disappeared by comparing + ;; against this buffer's definition cache, and + ;; simultaneously rebuild the cache to reflect the current + ;; set of overlays. + (setq gds-breakpoint-cache nil) + (while os + (let* ((o (car os)) + (bpdef (overlay-get o 'gds-breakpoint-definition)) + (bpnum (overlay-get o 'gds-breakpoint-number))) + (if bpdef + ;; o and bpdef describe a current breakpoint. + (progn + ;; Remove this breakpoint from the old cache list, + ;; so we don't think it got lost. + (setq cache (delq (assq bpdef cache) cache)) + ;; Check whether this breakpoint's location has + ;; moved. If it has, update the breakpoint + ;; definition and the associated client. + (let ((lcnow (gds-line-and-column (overlay-start o)))) + (if (equal lcnow (gds-bpdef:lc bpdef)) + nil ; Breakpoint hasn't moved. + (gds-bpdef:setlc bpdef lcnow) + (if gds-client + (gds-send-breakpoint-to-client bpnum bpdef)))) + ;; Add this breakpoint to the new cache list. + (setq gds-breakpoint-cache + (cons (list bpdef bpnum) gds-breakpoint-cache))))) + (setq os (cdr os))) + ;; cache now holds the set of lost breakpoints. If we are + ;; supposed to explicitly delete these from the associated + ;; client, do that now. + (if (and gds-delete-lost-breakpoints gds-client) + (while cache + (gds-send (format "delete-breakpoint %d" (cadr (car cache))) + gds-client) + (setq cache (cdr cache))))) + ;; If this buffer now has no breakpoints, remove it from + ;; gds-breakpoint-buffers. + (or gds-breakpoint-cache + (setq gds-breakpoint-buffers + (delq (current-buffer) gds-breakpoint-buffers))) + ;; Update the persistent breakpoints file. + (gds-write-breakpoints-file)))) + +(add-hook 'after-save-hook (function gds-after-save-update-breakpoints)) + +;;;; Dispatcher for non-debug protocol. + +(defun gds-nondebug-protocol (client proc args) + (cond (;; (eval-results ...) - Results of evaluation. + (eq proc 'eval-results) + (gds-display-results client (car args) (cadr args) (cddr args)) + ;; If these results indicate an error, set + ;; gds-completion-results to non-nil in case the error arose + ;; when trying to do a completion. + (if (eq (caar args) 'error) + (setq gds-completion-results 'error))) + + (;; (completion-result ...) - Available completions. + (eq proc 'completion-result) + (setq gds-completion-results (or (car args) t))) + + (;; (breakpoint NUM STATUS) - Breakpoint set. + (eq proc 'breakpoint) + (let* ((bpnum (car args)) + (traplist (cdr args)) + (bpentry (assq bpnum gds-breakpoint-programming))) + (message "Breakpoint %d: %s" bpnum traplist) + (if bpentry + (let ((cliententry (assq client (cdr bpentry)))) + (if cliententry + (setcdr cliententry traplist) + (setcdr bpentry + (cons (cons client traplist) (cdr bpentry))))) + (setq gds-breakpoint-programming + (cons (list bpnum (cons client traplist)) + gds-breakpoint-programming))))) + + (;; (get-breakpoints) - Set all breakpoints. + (eq proc 'get-breakpoints) + (let ((gds-client client)) + (gds-fold-breakpoints (function gds-send-breakpoint-to-client))) + (gds-send "continue" client)) + + (;; (note ...) - For debugging only. + (eq proc 'note)) + + (;; (trace ...) - Tracing. + (eq proc 'trace) + (with-current-buffer (get-buffer-create "*GDS Trace*") + (save-excursion + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (insert "[client " (number-to-string client) "] " (car args) "\n")))) + + (t + ;; Unexpected. + (error "Bad protocol: %S" form)))) + +;;;; Scheme mode keymap items. + +(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun) +(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp) +(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) +(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) +(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) +(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) +(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) +(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint) + +(define-prefix-command 'gds-breakpoint-map) +(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map) +(define-key gds-breakpoint-map " " 'gds-set-breakpoint) +(define-key gds-breakpoint-map "d" + (function (lambda () + (interactive) + (let ((gds-default-breakpoint-type 'debug)) + (gds-set-breakpoint))))) +(define-key gds-breakpoint-map "t" + (function (lambda () + (interactive) + (let ((gds-default-breakpoint-type 'trace)) + (gds-set-breakpoint))))) +(define-key gds-breakpoint-map "T" + (function (lambda () + (interactive) + (let ((gds-default-breakpoint-type 'trace-subtree)) + (gds-set-breakpoint))))) +(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints) +(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints) + +;;;; The end! + +(provide 'gds-scheme) + +;;; gds-scheme.el ends here. diff --git a/emacs/gds-server.el b/emacs/gds-server.el new file mode 100644 index 000000000..cca23c836 --- /dev/null +++ b/emacs/gds-server.el @@ -0,0 +1,110 @@ +;;; gds-server.el -- infrastructure for running GDS server processes + +;;;; Copyright (C) 2003, 2004 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA + + +;;;; Customization group setup. + +(defgroup gds nil + "Customization options for Guile Emacs frontend." + :group 'scheme) + + +;;;; Communication with the (ossau gds-server) subprocess. + +;; Subprocess output goes into the `*GDS Process*' buffer, and +;; is then read from there one form at a time. `gds-read-cursor' is +;; the buffer position of the start of the next unread form. +(defvar gds-read-cursor nil) + +;; The guile executable used by the GDS server process. +(defcustom gds-guile-program "guile" + "*The guile executable used by the GDS server process." + :type 'string + :group 'gds) + +(defcustom gds-scheme-directory nil + "Where GDS's Scheme code is, if not in one of the standard places." + :group 'gds + :type '(choice (const :tag "nil" nil) directory)) + +(defun gds-start-server (procname port protocol-handler &optional bufname) + "Start a GDS server process called PROCNAME, listening on TCP port PORT. +PROTOCOL-HANDLER should be a function that accepts and processes one +protocol form. Optional arg BUFNAME specifies the name of the buffer +that is used for process output\; if not specified the buffer name is +the same as the process name." + (with-current-buffer (get-buffer-create (or bufname procname)) + (erase-buffer) + (let* ((code (format "(begin + %s + (use-modules (ossau gds-server)) + (run-server %d))" + (if gds-scheme-directory + (concat "(set! %load-path (cons " + (format "%S" gds-scheme-directory) + " %load-path))") + "") + port)) + (process-connection-type nil) ; use a pipe + (proc (start-process procname + (current-buffer) + gds-guile-program + "-q" + "--debug" + "-c" + code))) + (set (make-local-variable 'gds-read-cursor) (point-min)) + (set (make-local-variable 'gds-protocol-handler) protocol-handler) + (set-process-filter proc (function gds-filter)) + (set-process-sentinel proc (function gds-sentinel)) + (set-process-coding-system proc 'latin-1-unix) + (process-kill-without-query proc) + proc))) + +;; Subprocess output filter: inserts normally into the process buffer, +;; then tries to reread the output one form at a time and delegates +;; processing of each form to `gds-protocol-handler'. +(defun gds-filter (proc string) + (with-current-buffer (process-buffer proc) + (save-excursion + (goto-char (process-mark proc)) + (insert-before-markers string)) + (goto-char gds-read-cursor) + (while (let ((form (condition-case nil + (read (current-buffer)) + (error nil)))) + (if form + (save-excursion + (funcall gds-protocol-handler (car form) (cdr form)))) + form) + (setq gds-read-cursor (point))))) + +;; Subprocess sentinel: do nothing. (Currently just here to avoid +;; inserting un-`read'able process status messages into the process +;; buffer.) +(defun gds-sentinel (proc event) + ) + + +;;;; The end! + +(provide 'gds-server) + +;;; gds-server.el ends here. diff --git a/emacs/gds.el b/emacs/gds.el new file mode 100644 index 000000000..3ce4696b6 --- /dev/null +++ b/emacs/gds.el @@ -0,0 +1,628 @@ +;;; gds.el -- frontend for Guile development in Emacs + +;;;; Copyright (C) 2003, 2004 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA + +; TODO: +; ?transcript +; scheme-mode menu +; interrupt/sigint/async-break +; (module browsing) +; load file +; doing common protocol from debugger +; thread override for debugging + +;;;; Prerequisites. + +(require 'scheme) +(require 'cl) +(require 'gds-server) +(require 'gds-scheme) + +;; The subprocess object for the debug server. +(defvar gds-debug-server nil) + +(defun gds-run-debug-server () + "Start (or restart, if already running) the GDS debug server process." + (interactive) + (if gds-debug-server (gds-kill-debug-server)) + (setq gds-debug-server + (gds-start-server "gds-debug" 8333 'gds-debug-protocol)) + (process-kill-without-query gds-debug-server)) + +(defun gds-kill-debug-server () + "Kill the GDS debug server process." + (interactive) + (mapcar (function gds-client-gone) + (mapcar (function car) gds-client-info)) + (condition-case nil + (progn + (kill-process gds-debug-server) + (accept-process-output gds-debug-server 0 200)) + (error)) + (setq gds-debug-server nil)) + +;; Send input to the subprocess. +(defun gds-send (string client) + (with-current-buffer (get-buffer-create "*GDS Transcript*") + (goto-char (point-max)) + (insert (number-to-string client) ": (" string ")\n")) + (gds-client-put client 'thread-id nil) + (gds-show-client-status client gds-running-text) + (process-send-string gds-debug-server (format "(%S %s)\n" client string))) + + +;;;; Per-client information + +(defun gds-client-put (client property value) + (let ((client-info (assq client gds-client-info))) + (if client-info + (let ((prop-info (memq property client-info))) + (if prop-info + (setcar (cdr prop-info) value) + (setcdr client-info + (list* property value (cdr client-info))))) + (setq gds-client-info + (cons (list client property value) gds-client-info))))) + +(defun gds-client-get (client property) + (let ((client-info (assq client gds-client-info))) + (and client-info + (cadr (memq property client-info))))) + +(defvar gds-client-info '()) + +(defun gds-get-client-buffer (client) + (let ((existing-buffer (gds-client-get client 'stack-buffer))) + (if (and existing-buffer + (buffer-live-p existing-buffer)) + existing-buffer + (let ((new-buffer (generate-new-buffer (gds-client-get client 'name)))) + (with-current-buffer new-buffer + (gds-debug-mode) + (setq gds-client client) + (setq gds-stack nil)) + (gds-client-put client 'stack-buffer new-buffer) + new-buffer)))) + +(defun gds-client-gone (client &rest ignored) + ;; Kill the client's stack buffer, if it has one. + (let ((stack-buffer (gds-client-get client 'stack-buffer))) + (if (and stack-buffer + (buffer-live-p stack-buffer)) + (kill-buffer stack-buffer))) + ;; Dissociate all the client's associated buffers. + (mapcar (function (lambda (buffer) + (if (buffer-live-p buffer) + (with-current-buffer buffer + (gds-dissociate-buffer))))) + (copy-sequence (gds-client-get client 'associated-buffers))) + ;; Remove this client's record from gds-client-info. + (setq gds-client-info (delq (assq client gds-client-info) gds-client-info))) + +(defvar gds-client nil) +(make-variable-buffer-local 'gds-client) + +(defvar gds-stack nil) +(make-variable-buffer-local 'gds-stack) + +(defvar gds-tweaking nil) +(make-variable-buffer-local 'gds-tweaking) + +(defvar gds-selected-frame-index nil) +(make-variable-buffer-local 'gds-selected-frame-index) + + +;;;; Debugger protocol + +(defun gds-debug-protocol (client form) + (or (eq client '*) + (let ((proc (car form))) + (cond ((eq proc 'name) + ;; (name ...) - client name. + (gds-client-put client 'name (caddr form))) + + ((eq proc 'stack) + ;; (stack ...) - stack information. + (with-current-buffer (gds-get-client-buffer client) + (setq gds-stack (cddr form)) + (setq gds-tweaking (memq 'instead (cadr gds-stack))) + (setq gds-selected-frame-index (cadr form)) + (gds-display-stack))) + + ((eq proc 'closed) + ;; (closed) - client has gone/died. + (gds-client-gone client)) + + ((eq proc 'eval-result) + ;; (eval-result RESULT) - result of evaluation. + (if gds-last-eval-result + (message "%s" (cadr form)) + (setq gds-last-eval-result (cadr form)))) + + ((eq proc 'info-result) + ;; (info-result RESULT) - info about selected frame. + (message "%s" (cadr form))) + + ((eq proc 'thread-id) + ;; (thread-id THREAD) - says which client thread is reading. + (let ((thread-id (cadr form)) + (debug-thread-id (gds-client-get client 'debug-thread-id))) + (if (and debug-thread-id + (/= thread-id debug-thread-id)) + ;; Tell the newly reading thread to go away. + (gds-send "dismiss" client) + ;; Either there's no current debug-thread-id, or + ;; the thread now reading is the debug thread. + (if debug-thread-id + (progn + ;; Reset the debug-thread-id. + (gds-client-put client 'debug-thread-id nil) + ;; Indicate debug status in modelines. + (gds-show-client-status client gds-debug-text)) + ;; Indicate normal read status in modelines.. + (gds-show-client-status client gds-ready-text))))) + + ((eq proc 'debug-thread-id) + ;; (debug-thread-id THREAD) - debug override indication. + (gds-client-put client 'debug-thread-id (cadr form)) + ;; If another thread is already reading, send it away. + (if (gds-client-get client 'thread-id) + (gds-send "dismiss" client))) + + (t + ;; Non-debug-specific protocol. + (gds-nondebug-protocol client proc (cdr form))))))) + + +;;;; Displaying a stack + +(define-derived-mode gds-debug-mode + scheme-mode + "Guile-Debug" + "Major mode for debugging a Guile client application." + (use-local-map gds-mode-map)) + +(defun gds-display-stack-first-line () + (let ((flags (cadr gds-stack))) + (cond ((memq 'application flags) + (insert "Calling procedure:\n")) + ((memq 'evaluation flags) + (insert "Evaluating expression" + (cond ((stringp gds-tweaking) (format " (tweaked: %s)" + gds-tweaking)) + (gds-tweaking " (tweakable)") + (t "")) + ":\n")) + ((memq 'return flags) + (let ((value (cadr (memq 'return flags)))) + (while (string-match "\n" value) + (setq value (replace-match "\\n" nil t value))) + (insert "Return value" + (cond ((stringp gds-tweaking) (format " (tweaked: %s)" + gds-tweaking)) + (gds-tweaking " (tweakable)") + (t "")) + ": " value "\n"))) + ((memq 'error flags) + (let ((value (cadr (memq 'error flags)))) + (while (string-match "\n" value) + (setq value (replace-match "\\n" nil t value))) + (insert "Error: " value "\n"))) + (t + (insert "Stack: " (prin1-to-string flags) "\n"))))) + +(defun gds-display-stack () + (if gds-undisplay-timer + (cancel-timer gds-undisplay-timer)) + (setq gds-undisplay-timer nil) + ;(setq buffer-read-only nil) + (mapcar 'delete-overlay + (overlays-in (point-min) (point-max))) + (erase-buffer) + (gds-display-stack-first-line) + (let ((frames (car gds-stack))) + (while frames + (let ((frame-text (cadr (car frames))) + (frame-source (caddr (car frames)))) + (while (string-match "\n" frame-text) + (setq frame-text (replace-match "\\n" nil t frame-text))) + (insert " " + (if frame-source "s" " ") + frame-text + "\n")) + (setq frames (cdr frames)))) + ;(setq buffer-read-only t) + (gds-show-selected-frame)) + +(defun gds-tweak (expr) + (interactive "sTweak expression or return value: ") + (or gds-tweaking + (error "The current stack cannot be tweaked")) + (setq gds-tweaking + (if (> (length expr) 0) + expr + t)) + (save-excursion + (goto-char (point-min)) + (delete-region (point) (progn (forward-line 1) (point))) + (gds-display-stack-first-line))) + +(defvar gds-undisplay-timer nil) +(make-variable-buffer-local 'gds-undisplay-timer) + +(defvar gds-undisplay-wait 1) + +(defun gds-undisplay-buffer () + (if gds-undisplay-timer + (cancel-timer gds-undisplay-timer)) + (setq gds-undisplay-timer + (run-at-time gds-undisplay-wait + nil + (function kill-buffer) + (current-buffer)))) + +(defun gds-show-selected-frame () + (setq gds-local-var-cache nil) + (goto-char (point-min)) + (forward-line (+ gds-selected-frame-index 1)) + (delete-char 3) + (insert "=> ") + (beginning-of-line) + (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index + (car gds-stack))))) + +(defun gds-unshow-selected-frame () + (if gds-frame-source-overlay + (move-overlay gds-frame-source-overlay 0 0)) + (save-excursion + (goto-char (point-min)) + (forward-line (+ gds-selected-frame-index 1)) + (delete-char 3) + (insert " "))) + +;; Overlay used to highlight the source expression corresponding to +;; the selected frame. +(defvar gds-frame-source-overlay nil) + +(defcustom gds-source-file-name-transforms nil + "Alist of regexps and substitutions for transforming Scheme source +file names. Each element in the alist is (REGEXP . SUBSTITUTION). +Each source file name in a Guile backtrace is compared against each +REGEXP in turn until the first one that matches, then `replace-match' +is called with SUBSTITUTION to transform that file name. + +This mechanism targets the situation where you are working on a Guile +application and want to install it, in /usr/local say, before each +test run. In this situation, even though Guile is reading your Scheme +files from /usr/local/share/guile, you probably want Emacs to pop up +the corresponding files from your working codebase instead. Therefore +you would add an element to this alist to transform +\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"." + :type '(alist :key-type regexp :value-type string) + :group 'gds) + +(defun gds-show-selected-frame-source (source) + ;; Highlight the frame source, if possible. + (if source + (let ((filename (car source)) + (client gds-client) + (transforms gds-source-file-name-transforms)) + ;; Apply possible transforms to the source file name. + (while transforms + (if (string-match (caar transforms) filename) + (let ((trans-fn (replace-match (cdar transforms) + t nil filename))) + (if (file-readable-p trans-fn) + (setq filename trans-fn + transforms nil)))) + (setq transforms (cdr transforms))) + ;; Try to map the (possibly transformed) source file to a + ;; buffer. + (let ((source-buffer (gds-source-file-name-to-buffer filename))) + (if source-buffer + (with-current-buffer source-buffer + (if gds-frame-source-overlay + nil + (setq gds-frame-source-overlay (make-overlay 0 0)) + (overlay-put gds-frame-source-overlay 'face 'highlight) + (overlay-put gds-frame-source-overlay + 'help-echo + (function gds-show-local-var))) + ;; Move to source line. Note that Guile line numbering + ;; is 0-based, while Emacs numbering is 1-based. + (save-restriction + (widen) + (goto-line (+ (cadr source) 1)) + (move-to-column (caddr source)) + (move-overlay gds-frame-source-overlay + (point) + (if (not (looking-at ")")) + (save-excursion (forward-sexp 1) (point)) + ;; It seems that the source + ;; coordinates for backquoted + ;; expressions are at the end of the + ;; sexp rather than the beginning... + (save-excursion (forward-char 1) + (backward-sexp 1) (point))) + (current-buffer))) + ;; Record that this source buffer has been touched by a + ;; GDS client process. + (setq gds-last-touched-by client)) + (message "Source for this frame cannot be shown: %s:%d:%d" + filename + (cadr source) + (caddr source))))) + (message "Source for this frame was not recorded")) + (gds-display-buffers)) + +(defvar gds-local-var-cache nil) + +(defun gds-show-local-var (window overlay position) + (let ((frame-index gds-selected-frame-index) + (client gds-client)) + (with-current-buffer (overlay-buffer overlay) + (save-excursion + (goto-char position) + (let ((gds-selected-frame-index frame-index) + (gds-client client) + (varname (thing-at-point 'symbol)) + (state (parse-partial-sexp (overlay-start overlay) (point)))) + (when (and gds-selected-frame-index + gds-client + varname + (not (or (nth 3 state) + (nth 4 state)))) + (set-text-properties 0 (length varname) nil varname) + (let ((existing (assoc varname gds-local-var-cache))) + (if existing + (cdr existing) + (gds-evaluate varname) + (setq gds-last-eval-result nil) + (while (not gds-last-eval-result) + (accept-process-output gds-debug-server)) + (setq gds-local-var-cache + (cons (cons varname gds-last-eval-result) + gds-local-var-cache)) + gds-last-eval-result)))))))) + +(defun gds-source-file-name-to-buffer (filename) + ;; See if filename begins with gds-emacs-buffer-port-name-prefix. + (if (string-match (concat "^" + (regexp-quote gds-emacs-buffer-port-name-prefix)) + filename) + ;; It does, so get the named buffer. + (get-buffer (substring filename (match-end 0))) + ;; It doesn't, so treat as a file name. + (and (file-readable-p filename) + (find-file-noselect filename)))) + +(defun gds-select-stack-frame (&optional frame-index) + (interactive) + (let ((new-frame-index (or frame-index + (gds-current-line-frame-index)))) + (or (and (>= new-frame-index 0) + (< new-frame-index (length (car gds-stack)))) + (error (if frame-index + "No more frames in this direction" + "No frame here"))) + (gds-unshow-selected-frame) + (setq gds-selected-frame-index new-frame-index) + (gds-show-selected-frame))) + +(defun gds-up () + (interactive) + (gds-select-stack-frame (- gds-selected-frame-index 1))) + +(defun gds-down () + (interactive) + (gds-select-stack-frame (+ gds-selected-frame-index 1))) + +(defun gds-current-line-frame-index () + (- (count-lines (point-min) + (save-excursion + (beginning-of-line) + (point))) + 1)) + +(defun gds-display-buffers () + (let ((buf (current-buffer))) + ;; If there's already a window showing the buffer, use it. + (let ((window (get-buffer-window buf t))) + (if window + (progn + (make-frame-visible (window-frame window)) + (select-window window)) + (switch-to-buffer buf) + (setq window (get-buffer-window buf t)))) + ;; If there is an associated source buffer, display it as well. + (if (and gds-frame-source-overlay + (overlay-end gds-frame-source-overlay) + (> (overlay-end gds-frame-source-overlay) 1)) + (progn + (delete-other-windows) + (let ((window (display-buffer + (overlay-buffer gds-frame-source-overlay)))) + (set-window-point window + (overlay-start gds-frame-source-overlay))))))) + + +;;;; Debugger commands. + +;; Typically but not necessarily used from the `stack' view. + +(defun gds-send-tweaking () + (if (stringp gds-tweaking) + (gds-send (format "tweak %S" gds-tweaking) gds-client))) + +(defun gds-go () + (interactive) + (gds-send-tweaking) + (gds-send "continue" gds-client) + (gds-unshow-selected-frame) + (gds-undisplay-buffer)) + +(defvar gds-last-eval-result t) + +(defun gds-evaluate (expr) + (interactive "sEvaluate variable or expression: ") + (gds-send (format "evaluate %d %s" + gds-selected-frame-index + (prin1-to-string expr)) + gds-client)) + +(defun gds-frame-info () + (interactive) + (gds-send (format "info-frame %d" gds-selected-frame-index) + gds-client)) + +(defun gds-frame-args () + (interactive) + (gds-send (format "info-args %d" gds-selected-frame-index) + gds-client)) + +(defun gds-proc-source () + (interactive) + (gds-send (format "proc-source %d" gds-selected-frame-index) + gds-client)) + +(defun gds-traps-here () + (interactive) + (gds-send "traps-here" gds-client)) + +(defun gds-step-into () + (interactive) + (gds-send-tweaking) + (gds-send (format "step-into %d" gds-selected-frame-index) + gds-client) + (gds-unshow-selected-frame) + (gds-undisplay-buffer)) + +(defun gds-step-over () + (interactive) + (gds-send-tweaking) + (gds-send (format "step-over %d" gds-selected-frame-index) + gds-client) + (gds-unshow-selected-frame) + (gds-undisplay-buffer)) + +(defun gds-step-file () + (interactive) + (gds-send-tweaking) + (gds-send (format "step-file %d" gds-selected-frame-index) + gds-client) + (gds-unshow-selected-frame) + (gds-undisplay-buffer)) + + + + +;;;; Guile Interaction mode keymap and menu items. + +(defvar gds-mode-map (make-sparse-keymap)) +(define-key gds-mode-map "c" (function gds-go)) +(define-key gds-mode-map "g" (function gds-go)) +(define-key gds-mode-map "q" (function gds-go)) +(define-key gds-mode-map "e" (function gds-evaluate)) +(define-key gds-mode-map "I" (function gds-frame-info)) +(define-key gds-mode-map "A" (function gds-frame-args)) +(define-key gds-mode-map "S" (function gds-proc-source)) +(define-key gds-mode-map "T" (function gds-traps-here)) +(define-key gds-mode-map "\C-m" (function gds-select-stack-frame)) +(define-key gds-mode-map "u" (function gds-up)) +(define-key gds-mode-map [up] (function gds-up)) +(define-key gds-mode-map "\C-p" (function gds-up)) +(define-key gds-mode-map "d" (function gds-down)) +(define-key gds-mode-map [down] (function gds-down)) +(define-key gds-mode-map "\C-n" (function gds-down)) +(define-key gds-mode-map " " (function gds-step-file)) +(define-key gds-mode-map "i" (function gds-step-into)) +(define-key gds-mode-map "o" (function gds-step-over)) +(define-key gds-mode-map "t" (function gds-tweak)) + + +(defvar gds-menu nil + "Global menu for GDS commands.") +(if nil;gds-menu + nil + (setq gds-menu (make-sparse-keymap "Guile-Debug")) + (define-key gds-menu [traps-here] + '(menu-item "Show Traps Here" gds-traps-here)) + (define-key gds-menu [proc-source] + '(menu-item "Show Procedure Source" gds-proc-source)) + (define-key gds-menu [frame-args] + '(menu-item "Show Frame Args" gds-frame-args)) + (define-key gds-menu [frame-info] + '(menu-item "Show Frame Info" gds-frame-info)) + (define-key gds-menu [separator-1] + '("--")) + (define-key gds-menu [evaluate] + '(menu-item "Evaluate..." gds-evaluate)) + (define-key gds-menu [separator-2] + '("--")) + (define-key gds-menu [down] + '(menu-item "Move Down A Frame" gds-down)) + (define-key gds-menu [up] + '(menu-item "Move Up A Frame" gds-up)) + (define-key gds-menu [separator-3] + '("--")) + (define-key gds-menu [step-over] + '(menu-item "Step Over Current Expression" gds-step-over)) + (define-key gds-menu [step-into] + '(menu-item "Step Into Current Expression" gds-step-into)) + (define-key gds-menu [step-file] + '(menu-item "Step Through Current Source File" gds-step-file)) + (define-key gds-menu [separator-4] + '("--")) + (define-key gds-menu [go] + '(menu-item "Go [continue execution]" gds-go)) + (define-key gds-mode-map [menu-bar gds-debug] + (cons "Guile-Debug" gds-menu))) + + +;;;; Autostarting the GDS server. + +(defcustom gds-autorun-debug-server t + "Whether to automatically run the GDS server when `gds.el' is loaded." + :type 'boolean + :group 'gds) + + +;;;; If requested, autostart the server after loading. + +(if (and gds-autorun-debug-server + (not gds-debug-server)) + (gds-run-debug-server)) + +;; Things to do only when this file is loaded for the first time. +;; (And not, for example, when code is reevaluated by eval-buffer.) +(defvar gds-scheme-first-load t) +(if gds-scheme-first-load + (progn + ;; Read the persistent breakpoints file, if configured. + (if gds-breakpoints-file-name + (gds-read-breakpoints-file)) + ;; Note that first time load is complete. + (setq gds-scheme-first-load nil))) + + +;;;; The end! + +(provide 'gds) + +;;; gds.el ends here. From ea19f0b3cf2572b1af123c795f7651fca776d991 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 19 Jun 2006 22:37:13 +0000 Subject: [PATCH 010/116] * Makefile.am (ice9_sources): Add new files. * gds-client.scm, gds-server.scm: New files. --- ice-9/ChangeLog | 6 + ice-9/Makefile.am | 3 +- ice-9/gds-client.scm | 650 +++++++++++++++++++++++++++++++++++++++++++ ice-9/gds-server.scm | 177 ++++++++++++ 4 files changed, 835 insertions(+), 1 deletion(-) create mode 100755 ice-9/gds-client.scm create mode 100644 ice-9/gds-server.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 690a76780..dd9f17291 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2006-06-19 Neil Jerram + + * Makefile.am (ice9_sources): Add new files. + + * gds-client.scm, gds-server.scm: New files. + 2006-05-28 Kevin Ryde * documentation.scm (file-commentary): Move make-regexp into diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 734185570..412b98945 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -35,7 +35,8 @@ ice9_sources = \ streams.scm string-fun.scm syncase.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm \ pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \ - weak-vector.scm deprecated.scm list.scm serialize.scm + weak-vector.scm deprecated.scm list.scm serialize.scm \ + gds-client.scm gds-server.scm subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9 subpkgdata_DATA = $(ice9_sources) diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm new file mode 100755 index 000000000..e101c4e4d --- /dev/null +++ b/ice-9/gds-client.scm @@ -0,0 +1,650 @@ +(define-module (ice-9 gds-client) + #:use-module (oop goops) + #:use-module (oop goops describe) + #:use-module (ice-9 debugging breakpoints) + #:use-module (ice-9 debugging trace) + #:use-module (ice-9 debugging traps) + #:use-module (ice-9 debugging trc) + #:use-module (ice-9 debugging steps) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 regex) + #:use-module (ice-9 session) + #:use-module (ice-9 string-fun) + #:export (gds-debug-trap + run-utility + set-gds-breakpoints + gds-accept-input)) + +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 debugger utils))) + (else + (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger))) + (module-export! the-ice-9-debugger-module + '(source-position + write-frame-short/application + write-frame-short/expression + write-frame-args-long + write-frame-long)))) + +(use-modules (ice-9 debugger)) + +(define gds-port #f) + +;; Return an integer that somehow identifies the current thread. +(define (get-thread-id) + (let ((root (dynamic-root))) + (cond ((integer? root) + root) + ((pair? root) + (object-address root)) + (else + (error "Unexpected dynamic root:" root))))) + +;; gds-debug-read is a high-priority read. The (debug-thread-id ID) +;; form causes the frontend to dismiss any reads from threads whose id +;; is not ID, until it receives the (thread-id ...) form with the same +;; id as ID. Dismissing the reads of any other threads (by sending a +;; form that is otherwise ignored) causes those threads to release the +;; read mutex, which allows the (gds-read) here to proceed. +(define (gds-debug-read) + (write-form `(debug-thread-id ,(get-thread-id))) + (gds-read)) + +(define (gds-debug-trap trap-context) + "Invoke the GDS debugger to explore the stack at the specified trap." + (connect-to-gds) + (start-stack 'debugger + (let* ((stack (tc:stack trap-context)) + (flags1 (let ((trap-type (tc:type trap-context))) + (case trap-type + ((#:return #:error) + (list trap-type + (tc:return-value trap-context))) + (else + (list trap-type))))) + (flags (if (tc:continuation trap-context) + (cons #:continuable flags1) + flags1)) + (fired-traps (tc:fired-traps trap-context)) + (special-index (and (= (length fired-traps) 1) + (is-a? (car fired-traps) ) + (eq? (tc:type trap-context) #:return) + (- (tc:depth trap-context) + (slot-ref (car fired-traps) 'depth))))) + ;; Write current stack to the frontend. + (write-form (list 'stack + (or special-index 0) + (stack->emacs-readable stack) + (append (flags->emacs-readable flags) + (slot-ref trap-context + 'handler-return-syms)))) + ;; Now wait for instruction. + (let loop ((protocol (gds-debug-read))) + ;; Act on it. + (case (car protocol) + ((tweak) + ;; Request to tweak the handler return value. + (let ((tweaking (catch #t + (lambda () + (list (with-input-from-string + (cadr protocol) + read))) + (lambda ignored #f)))) + (if tweaking + (slot-set! trap-context + 'handler-return-value + (cons 'instead (car tweaking))))) + (loop (gds-debug-read))) + ((continue) + ;; Continue (by exiting the debugger). + *unspecified*) + ((evaluate) + ;; Evaluate expression in specified frame. + (eval-in-frame stack (cadr protocol) (caddr protocol)) + (loop (gds-debug-read))) + ((info-frame) + ;; Return frame info. + (let ((frame (stack-ref stack (cadr protocol)))) + (write-form (list 'info-result + (with-output-to-string + (lambda () + (write-frame-long frame)))))) + (loop (gds-debug-read))) + ((info-args) + ;; Return frame args. + (let ((frame (stack-ref stack (cadr protocol)))) + (write-form (list 'info-result + (with-output-to-string + (lambda () + (write-frame-args-long frame)))))) + (loop (gds-debug-read))) + ((proc-source) + ;; Show source of application procedure. + (let* ((frame (stack-ref stack (cadr protocol))) + (proc (frame-procedure frame)) + (source (and proc (procedure-source proc)))) + (write-form (list 'info-result + (if source + (sans-surrounding-whitespace + (with-output-to-string + (lambda () + (pretty-print source)))) + (if proc + "This procedure is coded in C" + "This frame has no procedure"))))) + (loop (gds-debug-read))) + ((traps-here) + ;; Show the traps that fired here. + (write-form (list 'info-result + (with-output-to-string + (lambda () + (for-each describe + (tc:fired-traps trap-context)))))) + (loop (gds-debug-read))) + ((step-into) + ;; Set temporary breakpoint on next trap. + (at-step gds-debug-trap + 1 + #f + (if (memq #:return flags) + #f + (- (stack-length stack) + (cadr protocol))))) + ((step-over) + ;; Set temporary breakpoint on exit from + ;; specified frame. + (at-exit (- (stack-length stack) (cadr protocol)) + gds-debug-trap)) + ((step-file) + ;; Set temporary breakpoint on next trap in same + ;; source file. + (at-step gds-debug-trap + 1 + (frame-file-name (stack-ref stack + (cadr protocol))) + (if (memq #:return flags) + #f + (- (stack-length stack) + (cadr protocol))))) + (else + (safely-handle-nondebug-protocol protocol) + (loop (gds-debug-read)))))))) + +(define (connect-to-gds) + (or gds-port + (begin + (set! gds-port + (let ((s (socket PF_INET SOCK_STREAM 0)) + (SOL_TCP 6) + (TCP_NODELAY 1)) + (setsockopt s SOL_TCP TCP_NODELAY 1) + (connect s AF_INET (inet-aton "127.0.0.1") 8333) + s)) + (write-form (list 'name (getpid) (format #f "PID ~A" (getpid))))))) + +(if (not (defined? 'make-mutex)) + (begin + (define (make-mutex) #f) + (define lock-mutex noop) + (define unlock-mutex noop))) + +(define write-mutex (make-mutex)) + +(define (write-form form) + ;; Write any form FORM to GDS. + (lock-mutex write-mutex) + (write form gds-port) + (newline gds-port) + (force-output gds-port) + (unlock-mutex write-mutex)) + +(define (stack->emacs-readable stack) + ;; Return Emacs-readable representation of STACK. + (map (lambda (index) + (frame->emacs-readable (stack-ref stack index))) + (iota (min (stack-length stack) + (cadr (memq 'depth (debug-options))))))) + +(define (frame->emacs-readable frame) + ;; Return Emacs-readable representation of FRAME. + (if (frame-procedure? frame) + (list 'application + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "t ")) + (write-frame-short/application frame))) + (source->emacs-readable frame)) + (list 'evaluation + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "t ")) + (write-frame-short/expression frame))) + (source->emacs-readable frame)))) + +(define (source->emacs-readable frame) + ;; Return Emacs-readable representation of the filename, line and + ;; column source properties of SOURCE. + (or (frame->source-position frame) 'nil)) + +(define (flags->emacs-readable flags) + ;; Return Emacs-readable representation of trap FLAGS. + (let ((prev #f)) + (map (lambda (flag) + (let ((erf (if (and (keyword? flag) + (not (eq? prev #:return))) + (keyword->symbol flag) + (format #f "~S" flag)))) + (set! prev flag) + erf)) + flags))) + +(define (eval-in-frame stack index expr) + (write-form + (list 'eval-result + (format #f "~S" + (catch #t + (lambda () + (local-eval (with-input-from-string expr read) + (memoized-environment + (frame-source (stack-ref stack + index))))) + (lambda args + (cons 'ERROR args))))))) + +(set! (behaviour-ordering gds-debug-trap) 100) + +;;; Code below here adds support for interaction between the GDS +;;; client program and the Emacs frontend even when not stopped in the +;;; debugger. + +;; A mutex to control attempts by multiple threads to read protocol +;; back from the frontend. +(define gds-read-mutex (make-mutex)) + +;; Read a protocol instruction from the frontend. +(define (gds-read) + ;; Acquire the read mutex. + (lock-mutex gds-read-mutex) + ;; Tell the front end something that identifies us as a thread. + (write-form `(thread-id ,(get-thread-id))) + ;; Now read, then release the mutex and return what was read. + (let ((x (catch #t + (lambda () (read gds-port)) + (lambda ignored the-eof-object)))) + (unlock-mutex gds-read-mutex) + x)) + +(define (gds-accept-input exit-on-continue) + ;; If reading from the GDS connection returns EOF, we will throw to + ;; this catch. + (catch 'server-eof + (lambda () + (let loop ((protocol (gds-read))) + (if (or (eof-object? protocol) + (and exit-on-continue + (eq? (car protocol) 'continue))) + (throw 'server-eof)) + (safely-handle-nondebug-protocol protocol) + (loop (gds-read)))) + (lambda ignored #f))) + +(define (safely-handle-nondebug-protocol protocol) + ;; This catch covers any internal errors in the GDS code or + ;; protocol. + (catch #t + (lambda () + (lazy-catch #t + (lambda () + (handle-nondebug-protocol protocol)) + save-lazy-trap-context-and-rethrow)) + (lambda (key . args) + (write-form + `(eval-results (error . ,(format #f "~s" protocol)) + ,(if last-lazy-trap-context 't 'nil) + "GDS Internal Error +Please report this to , ideally including: +- a description of the scenario in which this error occurred +- which versions of Guile and guile-debugging you are using +- the error stack, which you can get by clicking on the link below, + and then cut and paste into your report. +Thanks!\n\n" + ,(list (with-output-to-string + (lambda () + (write key) + (display ": ") + (write args) + (newline))))))))) + +;; The key that is used to signal a read error changes from 1.6 to +;; 1.8; here we cover all eventualities by discovering the key +;; dynamically. +(define read-error-key + (catch #t + (lambda () + (with-input-from-string "(+ 3 4" read)) + (lambda (key . args) + key))) + +(define (handle-nondebug-protocol protocol) + (case (car protocol) + + ((eval) + (set! last-lazy-trap-context #f) + (apply (lambda (correlator module port-name line column code) + (with-input-from-string code + (lambda () + (set-port-filename! (current-input-port) port-name) + (set-port-line! (current-input-port) line) + (set-port-column! (current-input-port) column) + (let ((m (and module (resolve-module-from-root module)))) + (catch read-error-key + (lambda () + (let loop ((exprs '()) (x (read))) + (if (eof-object? x) + ;; Expressions to be evaluated have all + ;; been read. Now evaluate them. + (let loop2 ((exprs (reverse! exprs)) + (results '()) + (n 1)) + (if (null? exprs) + (write-form `(eval-results ,correlator + ,(if last-lazy-trap-context 't 'nil) + ,@results)) + (loop2 (cdr exprs) + (append results (gds-eval (car exprs) m + (if (and (null? (cdr exprs)) + (= n 1)) + #f n))) + (+ n 1)))) + ;; Another complete expression read; add + ;; it to the list. + (begin + (for-each-breakpoint setup-after-read x) + (loop (cons x exprs) (read)))))) + (lambda (key . args) + (write-form `(eval-results + ,correlator + ,(if last-lazy-trap-context 't 'nil) + ,(with-output-to-string + (lambda () + (display ";;; Reading expressions") + (display " to evaluate\n") + (apply display-error #f + (current-output-port) args))) + ("error-in-read")))))))) + (if (string? port-name) + (without-traps + (lambda () + (for-each-breakpoint setup-after-eval port-name))))) + (cdr protocol))) + + ((complete) + (let ((matches (apropos-internal + (string-append "^" (regexp-quote (cadr protocol)))))) + (cond ((null? matches) + (write-form '(completion-result nil))) + (else + ;;(write matches (current-error-port)) + ;;(newline (current-error-port)) + (let ((match + (let loop ((match (symbol->string (car matches))) + (matches (cdr matches))) + ;;(write match (current-error-port)) + ;;(newline (current-error-port)) + ;;(write matches (current-error-port)) + ;;(newline (current-error-port)) + (if (null? matches) + match + (if (string-prefix=? match + (symbol->string (car matches))) + (loop match (cdr matches)) + (loop (substring match 0 + (- (string-length match) 1)) + matches)))))) + (if (string=? match (cadr protocol)) + (write-form `(completion-result + ,(map symbol->string matches))) + (write-form `(completion-result + ,match)))))))) + + ((debug-lazy-trap-context) + (if last-lazy-trap-context + (gds-debug-trap last-lazy-trap-context) + (error "There is no stack available to show"))) + + ((set-breakpoint) + ;; Create or update a breakpoint object according to the + ;; definition. If the target code is already loaded, note that + ;; this may immediately install a trap. + (let* ((num (cadr protocol)) + (def (caddr protocol)) + (behaviour (case (list-ref def 0) + ((debug) gds-debug-trap) + ((trace) gds-trace-trap) + ((trace-subtree) gds-trace-subtree) + (else (error "Unsupported behaviour:" + (list-ref def 0))))) + (bp (hash-ref breakpoints num))) + (trc 'existing-bp bp) + (if bp + (update-breakpoint bp (list-ref def 3)) + (begin + (set! bp + (case (list-ref def 1) + ((in) + (break-in (string->symbol (list-ref def 3)) + (list-ref def 2) + #:behaviour behaviour)) + ((at) + (break-at (list-ref def 2) + (car (list-ref def 3)) + (cdr (list-ref def 3)) + #:behaviour behaviour)) + (else + (error "Unsupported breakpoint type:" + (list-ref def 1))))) + ;; Install an observer that will tell the frontend about + ;; future changes in this breakpoint's status. + (slot-set! bp 'observer + (lambda () + (write-form `(breakpoint + ,num + ,@(map trap-description + (slot-ref bp 'traps)))))) + ;; Add this to the breakpoint hash, and return the + ;; breakpoint number and status to the front end. + (hash-set! breakpoints num bp))) + ;; Call the breakpoint's observer now. + ((slot-ref bp 'observer)))) + + ((delete-breakpoint) + (let* ((num (cadr protocol)) + (bp (hash-ref breakpoints num))) + (if bp + (begin + (hash-remove! breakpoints num) + (delete-breakpoint bp))))) + +;;; ((describe-breakpoints) +;;; ;; Describe all breakpoints. +;;; (let ((desc +;;; (with-output-to-string +;;; (lambda () +;;; (hash-fold (lambda (num bp acc) +;;; (format #t +;;; "Breakpoint ~a ~a (~a):\n" +;;; (class-name (class-of bp)) +;;; num +;;; (slot-ref bp 'status)) +;;; (for-each (lambda (trap) +;;; (write (trap-description trap)) +;;; (newline)) +;;; (slot-ref bp 'traps))) +;;; #f +;;; breakpoints))))) +;;; (write-form (list 'info-result desc)))) + + (else + (error "Unexpected protocol:" protocol)))) + +(define breakpoints (make-hash-table 11)) + +(define (resolve-module-from-root name) + (save-module-excursion + (lambda () + (set-current-module the-root-module) + (resolve-module name)))) + +(define (gds-eval x m part) + ;; Consumer to accept possibly multiple values and present them for + ;; Emacs as a list of strings. + (define (value-consumer . values) + (if (unspecified? (car values)) + '() + (map (lambda (value) + (with-output-to-string (lambda () (write value)))) + values))) + ;; Now do evaluation. + (let ((intro (if part + (format #f ";;; Evaluating expression ~A" part) + ";;; Evaluating")) + (value #f)) + (let* ((do-eval (if m + (lambda () + (display intro) + (display " in module ") + (write (module-name m)) + (newline) + (set! value + (call-with-values (lambda () + (start-stack 'gds-eval-stack + (eval x m))) + value-consumer))) + (lambda () + (display intro) + (display " in current module ") + (write (module-name (current-module))) + (newline) + (set! value + (call-with-values (lambda () + (start-stack 'gds-eval-stack + (primitive-eval x))) + value-consumer))))) + (output + (with-output-to-string + (lambda () + (catch #t + (lambda () + (lazy-catch #t + do-eval + save-lazy-trap-context-and-rethrow)) + (lambda (key . args) + (case key + ((misc-error signal unbound-variable numerical-overflow) + (apply display-error #f + (current-output-port) args) + (set! value '("error-in-evaluation"))) + (else + (display "EXCEPTION: ") + (display key) + (display " ") + (write args) + (newline) + (set! value + '("unhandled-exception-in-evaluation")))))))))) + (list output value)))) + +(define last-lazy-trap-context #f) + +(define (save-lazy-trap-context-and-rethrow key . args) + (set! last-lazy-trap-context + (throw->trap-context key args save-lazy-trap-context-and-rethrow)) + (apply throw key args)) + +(define (run-utility) + (connect-to-gds) + (set-gds-breakpoints) + (write (getpid)) + (newline) + (force-output) + (named-module-use! '(guile-user) '(ice-9 session)) + (gds-accept-input #f)) + +(define (set-gds-breakpoints) + (connect-to-gds) + (write-form '(get-breakpoints)) + (gds-accept-input #t)) + +(define-method (trap-description (trap )) + (let loop ((description (list (class-name (class-of trap)))) + (next 'installed?)) + (case next + ((installed?) + (loop (if (slot-ref trap 'installed) + (cons 'installed description) + description) + 'conditional?)) + ((conditional?) + (loop (if (slot-ref trap 'condition) + (cons 'conditional description) + description) + 'skip-count)) + ((skip-count) + (loop (let ((skip-count (slot-ref trap 'skip-count))) + (if (zero? skip-count) + description + (cons* skip-count 'skip-count description))) + 'single-shot?)) + ((single-shot?) + (loop (if (slot-ref trap 'single-shot) + (cons 'single-shot description) + description) + 'done)) + (else + (reverse! description))))) + +(define-method (trap-description (trap )) + (let ((description (next-method))) + (set-cdr! description + (cons (procedure-name (slot-ref trap 'procedure)) + (cdr description))) + description)) + +(define-method (trap-description (trap )) + (let ((description (next-method))) + (set-cdr! description + (cons (format #f "~s" (slot-ref trap 'expression)) + (cdr description))) + description)) + +(define-method (trap-description (trap )) + (let ((description (next-method))) + (set-cdr! description + (cons* (slot-ref trap 'file-regexp) + (slot-ref trap 'line) + (slot-ref trap 'column) + (cdr description))) + description)) + +(define (gds-trace-trap trap-context) + (connect-to-gds) + (gds-do-trace trap-context) + (at-exit (tc:depth trap-context) gds-do-trace)) + +(define (gds-do-trace trap-context) + (write-form (list 'trace + (format #f + "~3@a: ~a" + (trace/stack-real-depth trap-context) + (trace/info trap-context))))) + +(define (gds-trace-subtree trap-context) + (connect-to-gds) + (gds-do-trace trap-context) + (let ((step-trap (make #:behaviour gds-do-trace))) + (install-trap step-trap) + (at-exit (tc:depth trap-context) + (lambda (trap-context) + (uninstall-trap step-trap))))) + +;;; (ice-9 gds-client) ends here. diff --git a/ice-9/gds-server.scm b/ice-9/gds-server.scm new file mode 100644 index 000000000..a8e9c99c8 --- /dev/null +++ b/ice-9/gds-server.scm @@ -0,0 +1,177 @@ +;;;; Guile Debugger UI server + +;;; Copyright (C) 2003 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ice-9 gds-server) + #:export (run-server)) + +;; UI is normally via a pipe to Emacs, so make sure to flush output +;; every time we write. +(define (write-to-ui form) + (write form) + (newline) + (force-output)) + +(define (trc . args) + (write-to-ui (cons '* args))) + +(define (with-error->eof proc port) + (catch #t + (lambda () (proc port)) + (lambda args the-eof-object))) + +(define connection->id (make-object-property)) + +(define (run-server port) + + (let ((server (socket PF_INET SOCK_STREAM 0))) + + ;; Initialize server socket. + (setsockopt server SOL_SOCKET SO_REUSEADDR 1) + (bind server AF_INET INADDR_ANY port) + (listen server 5) + + (let loop ((clients '()) (readable-sockets '())) + + (define (do-read port) + (cond ((eq? port (current-input-port)) + (do-read-from-ui)) + ((eq? port server) + (accept-new-client)) + (else + (do-read-from-client port)))) + + (define (do-read-from-ui) + (trc "reading from ui") + (let* ((form (with-error->eof read (current-input-port))) + (client (assq-ref (map (lambda (port) + (cons (connection->id port) port)) + clients) + (car form)))) + (with-error->eof read-char (current-input-port)) + (if client + (begin + (write (cdr form) client) + (newline client)) + (trc "client not found"))) + clients) + + (define (accept-new-client) + (let ((new-port (car (accept server)))) + ;; Read the client's ID. + (let ((name-form (read new-port))) + ;; Absorb the following newline character. + (read-char new-port) + ;; Check that we have a name form. + (or (eq? (car name-form) 'name) + (error "Invalid name form:" name-form)) + ;; Store an association from the connection to the ID. + (set! (connection->id new-port) (cadr name-form)) + ;; Pass the name form on to Emacs. + (write-to-ui (cons (connection->id new-port) name-form))) + ;; Add the new connection to the set that we select on. + (cons new-port clients))) + + (define (do-read-from-client port) + (trc "reading from client") + (let ((next-char (with-error->eof peek-char port))) + ;;(trc 'next-char next-char) + (cond ((eof-object? next-char) + (write-to-ui (list (connection->id port) 'closed)) + (close port) + (delq port clients)) + ((char=? next-char #\() + (write-to-ui (cons (connection->id port) + (with-error->eof read port))) + clients) + (else + (with-error->eof read-char port) + clients)))) + + ;;(trc 'clients clients) + ;;(trc 'readable-sockets readable-sockets) + + (if (null? readable-sockets) + (loop clients (car (select (cons (current-input-port) + (cons server clients)) + '() + '()))) + (loop (do-read (car readable-sockets)) (cdr readable-sockets)))))) + +;; What happens if there are multiple copies of Emacs running on the +;; same machine, and they all try to start up the GDS server? They +;; can't all listen on the same TCP port, so the short answer is that +;; all of them except the first will get an EADDRINUSE error when +;; trying to bind. +;; +;; We want to be able to handle this scenario, though, so that Scheme +;; code can be evaluated, and help invoked, in any of those Emacsen. +;; So we introduce the idea of a "slave server". When a new GDS +;; server gets an EADDRINUSE bind error, the implication is that there +;; is already a GDS server running, so the new server instead connects +;; to the existing one (by issuing a connect to the GDS port number). +;; +;; Let's call the first server the "master", and the new one the +;; "slave". In principle the master can now proxy any GDS client +;; connections through to the slave, so long as there is sufficient +;; information in the protocol for it to decide when and how to do +;; this. +;; +;; The basic information and mechanism that we need for this is as +;; follows. +;; +;; - A unique ID for each Emacs; this can be each Emacs's PID. When a +;; slave server connects to the master, it announces itself by sending +;; the protocol (emacs ID). +;; +;; - A way for a client to indicate which Emacs it wants to use. At +;; the protocol level, this is an extra argument in the (name ...) +;; protocol. (The absence of this argument means "no preference". A +;; simplistic master server might then decide to use its own Emacs; a +;; cleverer one might monitor which Emacs appears to be most in use, +;; and use that one.) At the API level this can be an optional +;; argument to the `gds-connect' procedure, and the Emacs GDS code +;; would obviously set this argument when starting a client from +;; within Emacs. +;; +;; We also want a strategy for continuing seamlessly if the master +;; server shuts down. +;; +;; - Each slave server will detect this as an error on the connection +;; to the master socket. Each server then tries to bind to the GDS +;; port again (a race which the OS will resolve), and if that fails, +;; connect again. The result of this is that there should be a new +;; master, and the others all slaves connected to the new master. +;; +;; - Each client will also detect this as an error on the connection +;; to the (master) server. Either the client should try to connect +;; again (perhaps after a short delay), or the reconnection can be +;; delayed until the next time that the client requires the server. +;; (Probably the latter, all done within `gds-read'.) +;; +;; (Historical note: Before this master-slave idea, clients were +;; identified within gds-server.scm and gds*.el by an ID which was +;; actually the file descriptor of their connection to the server. +;; That is no good in the new scheme, because each client's ID must +;; persist when the master server changes, so we now use the client's +;; PID instead. We didn't use PID before because the client/server +;; code was written to be completely asynchronous, which made it +;; tricky for the server to discover each client's PID and associate +;; it with a particular connection. Now we solve that problem by +;; handling the initial protocol exchange synchronously.) +(define (run-slave-server port) + 'not-implemented) From eaa94eaaa91b8f1c57b2922f48677e32e55648e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Jul 2006 08:07:27 +0000 Subject: [PATCH 011/116] Changes from arch/CVS synchronization --- libguile/ChangeLog | 5 +++++ libguile/numbers.c | 10 ++++++---- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cb34d8d05..89dcac2c1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2006-07-12 Ludovic Courts + + * numbers.c (guile_ieee_init): Use regular ANSI C casts rather + than C++-style `X_CAST ()'. Patch posted by by Mike Gran. + 2006-06-13 Ludovic Courts * eq.c: Include "struct.h", "goops.h" and "objects.h". diff --git a/libguile/numbers.c b/libguile/numbers.c index 3b6d781af..caaa6e2fc 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -598,7 +598,7 @@ guile_ieee_init (void) #elif HAVE_DINFINITY /* OSF */ extern unsigned int DINFINITY[2]; - guile_Inf = (*(X_CAST(double *, DINFINITY))); + guile_Inf = (*((double *) (DINFINITY))); #else double tmp = 1e+10; guile_Inf = tmp; @@ -619,9 +619,11 @@ guile_ieee_init (void) /* C99 NAN, when available */ guile_NaN = NAN; #elif HAVE_DQNAN - /* OSF */ - extern unsigned int DQNAN[2]; - guile_NaN = (*(X_CAST(double *, DQNAN))); + { + /* OSF */ + extern unsigned int DQNAN[2]; + guile_NaN = (*((double *)(DQNAN))); + } #else guile_NaN = guile_Inf / guile_Inf; #endif From 08e5f840703296b40998e894ab0be9bc2ed6ba41 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Jul 2006 06:56:30 +0000 Subject: [PATCH 012/116] Add __attribute__ ((returns_twice)) to the ia64_getcontext prototype so that gcc will make the right arrangements and avoid an illegal instruction during call-with-current-continuation. --- libguile/continuations.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/continuations.c b/libguile/continuations.c index e456623f6..5ae89d836 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -101,6 +101,10 @@ struct rv long retval; long first_return; }; + +#ifdef __GNUC__ +__attribute__ ((returns_twice)) +#endif /* __GNUC__ */ extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext"); #endif /* __ia64__ */ From b49123789ffd7b61d87ed62333605b5051fe63f7 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Jul 2006 06:56:37 +0000 Subject: [PATCH 013/116] *** empty log message *** --- libguile/ChangeLog | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 89dcac2c1..f8e6c3436 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2006-07-18 Rob Browning + + * continuations.c: Add __attribute__ ((returns_twice)) to the + ia64_getcontext prototype so that gcc will make the right + arrangements and avoid an illegal instruction during + call-with-current-continuation. + 2006-07-12 Ludovic Courts * numbers.c (guile_ieee_init): Use regular ANSI C casts rather @@ -19,7 +26,7 @@ * Makefile.am (BUILT_SOURCES): Remove guile.texi, only used by maintainers (with doc/maint/docstring.el). Fixes parallel "make -j2" reported by Mattias Holm. - + 2006-06-03 Kevin Ryde * read.c (s_vector): Conditionalize on SCM_ENABLE_ELISP, to avoid From 46f7666d7f9d07484a44f438f9b51c0a29b8a0c4 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 1 Aug 2006 21:33:17 +0000 Subject: [PATCH 014/116] * scheme-debugging.texi (Debug Last Error, Interactive Debugger): Moved/merged to scheme-using.texi, as REPL features. (Examples): New. (Intro to Breakpoints): New introductory text here. Removed all subnodes except for Breakpoints Overview. * scheme-using.texi: New. * guile.texi (Programming in Scheme): Include new scheme-using.texi file. * Makefile.am (guile_TEXINFOS): Include new scheme-using.texi file. --- doc/ref/ChangeLog | 16 + doc/ref/Makefile.am | 1 + doc/ref/guile.texi | 5 +- doc/ref/scheme-debugging.texi | 884 +++++++--------------------------- doc/ref/scheme-using.texi | 411 ++++++++++++++++ 5 files changed, 608 insertions(+), 709 deletions(-) create mode 100644 doc/ref/scheme-using.texi diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 7ed1eb778..2604a2607 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,19 @@ +2006-08-01 Neil Jerram + + * scheme-debugging.texi (Debug Last Error, Interactive Debugger): + Moved/merged to scheme-using.texi, as REPL features. + (Examples): New. + (Intro to Breakpoints): New introductory text here. Removed all + subnodes except for Breakpoints Overview. + + * scheme-using.texi: New. + + * guile.texi (Programming in Scheme): Include new + scheme-using.texi file. + + * Makefile.am (guile_TEXINFOS): Include new scheme-using.texi + file. + 2006-06-16 Ludovic Courts * api-utility.texi (Equality): Mentioned the behavior of `equal?' diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 1e4f3cfee..76a66f0c9 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -56,6 +56,7 @@ guile_TEXINFOS = preface.texi \ gh.texi \ api-overview.texi \ scheme-debugging.texi \ + scheme-using.texi \ indices.texi \ script-getopt.texi \ data-rep.texi \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 8a9fbdcf6..08e8b0755 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -137,7 +137,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.44 2005-06-22 23:42:23 kryde Exp $ +@c @subtitle $Id: guile.texi,v 1.45 2006-08-01 21:33:17 ossau Exp $ @c See preface.texi for the list of authors @author The Guile Developers @@ -219,6 +219,8 @@ etc. that make up Guile's application programming interface (API), * Basic Ideas:: Basic ideas in Scheme. * Guile Scheme:: Guile's implementation of Scheme. * Guile Scripting:: How to write Guile scripts. +* Using Guile Interactively:: Guile's REPL features. +* Using Guile in Emacs:: Guile and Emacs. * Debugging Features:: Features for finding errors. * Further Reading:: Where to find out more about Scheme. @end menu @@ -226,6 +228,7 @@ etc. that make up Guile's application programming interface (API), @include scheme-ideas.texi @include scheme-intro.texi @include scheme-scripts.texi +@include scheme-using.texi @include scheme-debugging.texi @include scheme-reading.texi diff --git a/doc/ref/scheme-debugging.texi b/doc/ref/scheme-debugging.texi index 6168ac886..a9d1691d1 100644 --- a/doc/ref/scheme-debugging.texi +++ b/doc/ref/scheme-debugging.texi @@ -28,135 +28,196 @@ execution context at a breakpoint, or when the last error occurred. The details are more complex and more powerful @dots{} @menu -* Debug Last Error:: Debugging the most recent error. +* Examples:: * Intro to Breakpoints:: Setting and manipulating them. -* Interactive Debugger:: Using the interactive debugger. * Tracing:: Tracing program execution. @end menu -@node Debug Last Error -@subsection Debugging the Most Recent Error +@node Examples +@subsection Examples -When an error is signalled, Guile remembers the execution context where -the error occurred. By default, Guile then displays only the most -immediate information about where and why the error occurred, for -example: - -@lisp -(make-string (* 4 (+ 3 #\s)) #\space) -@print{} -standard input:2:19: In procedure + in expression (+ 3 #\s): -standard input:2:19: Wrong type argument: #\s -ABORT: (wrong-type-arg) - -Type "(backtrace)" to get more information or "(debug)" to enter the debugger. -@end lisp - -@noindent -However, as the message above says, you can obtain much more -information about the context of the error by typing -@code{(backtrace)} or @code{(debug)}. - -@code{(backtrace)} displays the Scheme call stack at the point where the -error occurred: - -@lisp -(backtrace) -@print{} -Backtrace: -In standard input: - 2: 0* [make-string ... - 2: 1* [* 4 ... - 2: 2* [+ 3 #\s] - -Type "(debug-enable 'backtrace)" if you would like a backtrace -automatically if an error occurs in the future. -@end lisp - -@noindent -In a more complex scenario than this one, this can be extremely useful -for understanding where and why the error occurred. For more on the -format of the displayed backtrace, see the subsection below. - -@code{(debug)} takes you into Guile's interactive debugger, which -provides commands that allow you to - -@itemize @bullet -@item -display the Scheme call stack at the point where the error occurred -(the @code{backtrace} command --- see @ref{Display Backtrace}) - -@item -move up and down the call stack, to see in detail the expression being -evaluated, or the procedure being applied, in each @dfn{frame} (the -@code{up}, @code{down}, @code{frame}, @code{position}, @code{info args} -and @code{info frame} commands --- see @ref{Frame Selection} and -@ref{Frame Information}) - -@item -examine the values of variables and expressions in the context of each -frame (the @code{evaluate} command --- see @ref{Frame Evaluation}). -@end itemize - -Use of the interactive debugger, including these commands, is described -in @ref{Interactive Debugger}. +Before we dive into the details and reference documentation of +guile-debugging's features, this chapter sets the scene by presenting a +few examples of what you can do with guile-debugging. @menu -* Backtrace Format:: How to interpret a backtrace. +* Single Stepping through a Procedure's Code:: +* Profiling or Tracing a Procedure's Code:: @end menu -@node Backtrace Format -@subsubsection How to Interpret a Backtrace +@node Single Stepping through a Procedure's Code +@subsubsection Single Stepping through a Procedure's Code + +A good way to explore in detail what a Scheme procedure does is to set a +breakpoint on it and then single step through what it does. To do this, +use the @code{break-in} procedure from the @code{(ice-9 debugging +breakpoints)} module with the @code{debug-trap} behaviour from +@code{(ice-9 debugging ice-9-debugger-extensions)}. The following +sample session illustrates this. It assumes that the file +@file{matrix.scm} defines a procedure @code{mkmatrix}, which is the one +we want to explore, and another procedure @code{do-main} which calls +@code{mkmatrix}. + +@lisp +$ /usr/bin/guile -q +guile> (use-modules (ice-9 debugger) + (ice-9 debugging ice-9-debugger-extensions) + (ice-9 debugging breakpoints)) +guile> (load "matrix.scm") +guile> (break-in 'mkmatrix #:behaviour debug-trap) +#< 808cb70> +guile> (do-main 4) +This is the Guile debugger -- for help, type `help'. +There are 3 frames on the stack. + +Frame 2 at matrix.scm:8:3 + [mkmatrix] +debug> next +Frame 3 at matrix.scm:4:3 + (let ((x 1)) (quote this-is-a-matric)) +debug> info frame +Stack frame: 3 +This frame is an evaluation. +The expression being evaluated is: +matrix.scm:4:3: + (let ((x 1)) (quote this-is-a-matric)) +debug> next +Frame 3 at matrix.scm:5:21 + (quote this-is-a-matric) +debug> bt +In unknown file: + ?: 0* [primitive-eval (do-main 4)] +In standard input: + 4: 1* [do-main 4] +In matrix.scm: + 8: 2 [mkmatrix] + ... + 5: 3 (quote this-is-a-matric) +debug> quit +this-is-a-matric +guile> +@end lisp + +Or you can use guile-debugging's Emacs interface (GDS), by using the +module @code{(ice-9 gds-client)} instead of @code{(ice-9 debugger)} and +@code{(ice-9 debugging ice-9-debugger-extensions)}, and changing +@code{debug-trap} to @code{gds-debug-trap}. Then the stack and +corresponding source locations are displayed in Emacs instead of on the +Guile command line. + + +@node Profiling or Tracing a Procedure's Code +@subsubsection Profiling or Tracing a Procedure's Code + +What if you wanted to get a trace of everything that the Guile evaluator +does within a given procedure, but without Guile stopping and waiting +for your input at every step? In this case you set a breakpoint on the +procedure using @code{break-in} (the same as in the previous example), +but use the @code{trace-trap} and @code{trace-until-exit} behaviours +provided by the @code{(ice-9 debugging trace)} module. + +@lisp +guile> (use-modules (ice-9 debugging breakpoints) (ice-9 debugging trace)) +guile> (load "matrix.scm") +guile> (break-in 'mkmatrix #:behaviour (list trace-trap trace-until-exit)) +#< 808b430> +guile> (do-main 4) +| 2: [mkmatrix] +| 3: [define (define yy 23) ((()) #)] +| 3: [define (define yy 23) ((()) #)] +| 3: =>(#@@define yy 23) +| 3: [let (let # #) (# #)] +| 3: [let (let # #) (# #)] +| 3: =>(#@@let* (x 1) #@@let (quote this-is-a-matric)) +| 2: (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric))) +| 3: [let (let # #) (# # #)] +| 3: [let (let # #) (# # #)] +| 3: =>(#@@let* (x 1) #@@let (quote this-is-a-matric)) +| 2: (let ((x 1)) (quote this-is-a-matric)) +| 3: [quote (quote this-is-a-matric) ((x . 1) ((yy) 23) (()) ...)] +| 3: [quote (quote this-is-a-matric) ((x . 1) ((yy) 23) (()) ...)] +| 3: =>(#@@quote this-is-a-matric) +| 2: (quote this-is-a-matric) +| 2: =>this-is-a-matric +this-is-a-matric +guile> (do-main 4) +| 2: [mkmatrix] +| 2: (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric))) +| 2: (let ((x 1)) (quote this-is-a-matric)) +| 2: (quote this-is-a-matric) +| 2: =>this-is-a-matric +this-is-a-matric +guile> +@end lisp + +This example shows the default configuration for how each line of trace +output is formatted, which is: + +@itemize +@item +the character @code{|}, a visual clue that the line is a line of trace +output, followed by + +@item +a number indicating the real evaluator stack depth (where ``real'' means +not counting tail-calls), followed by + +@item +a summary of the expression being evaluated (@code{(@dots{})}), the +procedure being called (@code{[@dots{}]}), or the value being returned +from an evaluation or procedure call (@code{=>@dots{}}). +@end itemize + +@noindent +You can customize @code{(ice-9 debugging trace)} to show different +information in each trace line using the @code{set-trace-layout} +procedure. The next example shows how to get the source location in +each trace line instead of the stack depth. + +@lisp +guile> (set-trace-layout "|~16@@a: ~a\n" trace/source trace/info) +guile> (do-main 4) +| matrix.scm:7:2: [mkmatrix] +| : (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric))) +| matrix.scm:3:2: (let ((x 1)) (quote this-is-a-matric)) +| matrix.scm:4:20: (quote this-is-a-matric) +| matrix.scm:4:20: =>this-is-a-matric +this-is-a-matric +guile> +@end lisp + +(For anyone wondering why the first @code{(do-main 4)} call above +generates lots more trace lines than the subsequent calls: these +examples also demonstrate how the Guile evaluator ``memoizes'' code. +When Guile evaluates a source code expression for the first time, it +changes some parts of the expression so that they will be quicker to +evaluate when that expression is evaluated again; this is called +memoization. The trace output from the first @code{(do-main 4)} call +shows memoization steps, such as an internal define being transformed to +a letrec.) @node Intro to Breakpoints @subsection Intro to Breakpoints -If you are not already familiar with the concept of breakpoints, the -first subsection below explains how they work are why they are useful. +Sometimes a piece of Scheme code isn't working and you'd like to go +through it step by step. You can do this in Guile by setting a +breakpoint at the start of the relevant code, and then using the command +line or Emacs interface to step through it. -Broadly speaking, Guile's breakpoint support consists of +A breakpoint can be specified by procedure name or by location -- the +relevant code's file name, line number and column number. For details +please see the full documentation for @code{break-in} and +@code{break-at} in @ref{Intro to Breakpoints}. -@itemize @bullet -@item -type-specific features for @emph{creating} breakpoints of various types - -@item -relatively generic features for @emph{manipulating} the behaviour of -breakpoints once they've been created. -@end itemize - -Different breakpoint types are implemented as different classes in a -GOOPS hierarchy with common base class @code{}. The magic -of generic functions then allows most of the manipulation functions to -be generic by default but specializable (by breakpoint class) if the -need arises. - -Generic breakpoint support is provided by the @code{(ice-9 debugger -breakpoints)} module, so you will almost always need to use this module -in order to access the functionality described here: - -@smalllisp -(use-modules (ice-9 debugger breakpoints)) -@end smalllisp - -@noindent -You may like to add this to your @file{.guile} file. +When you set a breakpoint, you can specify any ``behaviour'' you like +for what should happen when the breakpoint is hit; a breakpoint +``behaviour'' is just a Scheme procedure with the right signature. @menu * Breakpoints Overview:: -* Source Breakpoints:: -* Procedural Breakpoints:: -* Setting Breakpoints:: -* break! trace! trace-subtree!:: -* Accessing Breakpoints:: -* Breakpoint Behaviours:: -* Enabling and Disabling:: -* Deleting Breakpoints:: -* Breakpoint Information:: -* Other Breakpoint Types:: @end menu @@ -187,8 +248,9 @@ available: @itemize @bullet @item -all the commands as described for last error debugging (@pxref{Debug -Last Error}), which allow you to explore the stack and so on +all the commands as described for last error debugging +(@pxref{Interactive Debugger}), which allow you to explore the stack and +so on @item additional commands for continuing program execution in various ways: @@ -200,607 +262,13 @@ Use of the interactive debugger is described in @ref{Interactive Debugger}. -@node Source Breakpoints -@subsubsection Source Breakpoints - -A source breakpoint is a breakpoint that triggers whenever program -execution hits a particular source location. A source breakpoint can be -conveniently set simply by evaluating code that has @code{##} inserted -into it at the position where you want the breakpoint to be. - -For example, to set a breakpoint immediately before evaluation of -@code{(= n 0)} in the following procedure definition, evaluate: - -@smalllisp -(define (fact1 n) - (if ##(= n 0) - 1 - (* n (fact1 (- n 1))))) -@print{} -Set breakpoint 1: standard input:4:9: (= n 0) -@end smalllisp - -@noindent -Note the message confirming that you have set a breakpoint. If you -don't see this, something isn't working. - -@code{##} is provided by the @code{(ice-9 debugger breakpoints source)} module, -so you must use this module before trying to set breakpoints in this -way: - -@smalllisp -(use-modules (ice-9 debugger breakpoints source)) -@end smalllisp - -@noindent -You may like to add this to your @file{.guile} file. - -The default behaviour for source breakpoints is @code{debug-here} -(@pxref{Breakpoint Behaviours}), which means to enter the command line -debugger when the breakpoint is hit. So, if you now use @code{fact1}, -that is what happens. - -@smalllisp -guile> (fact1 3) -Hit breakpoint 1: standard input:4:9: (= n 0) -Frame 3 at standard input:4:9 - (= n 0) -debug> -@end smalllisp - - -@node Procedural Breakpoints -@subsubsection Procedural Breakpoints - -A procedural breakpoint is a breakpoint that triggers whenever Guile is -about to apply a specified procedure to its (already evaluated) -arguments. To set a procedural breakpoint, call @code{break!} with the -target procedure as a single argument. For example: - -@smalllisp -(define (fact1 n) - (if (= n 0) - 1 - (* n (fact1 (- n 1))))) - -(break! fact1) -@print{} -Set breakpoint 1: [fact1] -@result{} -#< 808b0b0> -@end smalllisp - -Alternatives to @code{break!} are @code{trace!} and -@code{trace-subtree!}. The difference is that these three calls create -a breakpoint in the same place but with three different behaviours, -respectively @code{debug-here}, @code{trace-here} and -@code{trace-subtree}. Breakpoint behaviours are documented fully later -(@pxref{Breakpoint Behaviours}), but to give a quick taste, here's an -example of running code that includes a procedural breakpoint with the -@code{trace-here} behaviour. - -@smalllisp -(trace! fact1) -@print{} -Set breakpoint 1: [fact1] -@result{} -#< 808b0b0> - -(fact1 4) -@print{} -| [fact1 4] -| | [fact1 3] -| | | [fact1 2] -| | | | [fact1 1] -| | | | | [fact1 0] -| | | | | 1 -| | | | 2 -| | | 6 -| | 24 -| 24 -@result{} -24 -@end smalllisp - -To set and use procedural breakpoints, you will need to use the -@code{(ice-9 debugger breakpoints procedural)} module: - -@smalllisp -(use-modules (ice-9 debugger breakpoints procedural)) -@end smalllisp - -@noindent -You may like to add this to your @file{.guile} file. - - -@node Setting Breakpoints -@subsubsection Setting Breakpoints - -In general, that is. We've already seen how to set source and -procedural breakpoints conveniently in practice. This section explains -how those conveniences map onto a more general mechanism. - -The general mechanism for setting breakpoints is the generic function -@code{set-breakpoint!}. Different kinds of breakpoints define -subclasses of the class @code{} and provide their own -methods for @code{set-pbreakpoint!}. - -For example, @code{(ice-9 debugger breakpoints procedural)} implements -the @code{} subclass and provides a -@code{set-breakpoint!} method that takes a procedure argument: - -@smalllisp -(set-breakpoint! @var{behavior} fact1) -@print{} -Set breakpoint 1: [fact1] -@result{} -#< 808b0b0> -@end smalllisp - -A non-type-specific @code{set-breakpoint!} method is provided by the -generic module @code{(ice-9 debugger breakpoints)}. It allows you to -change the behaviour of an existing breakpoint that is identified by -its breakpoint number. - -@smalllisp -(set-breakpoint! @var{behavior} 1) -@end smalllisp - -@node break! trace! trace-subtree! -@subsubsection break! trace! trace-subtree! - -We have already talked above about the use of @code{break!}, -@code{trace!} and @code{trace-subtree!} for setting procedural -breakpoints. Now that @code{set-breakpoint!} has been introduced, we -can reveal that @code{break!}, @code{trace!} and @code{trace-subtree!} -are in fact just wrappers for @code{set-breakpoint!} that specify -particular breakpoint behaviours, respectively @code{debug-here}, -@code{trace-here} and @code{trace-subtree}. - -@smalllisp -(break! . @var{args}) - @equiv{} (set-breakpoint! debug-here . @var{args}) -(trace! . @var{args}) - @equiv{} (set-breakpoint! trace-here . @var{args}) -(trace-subtree! . @var{args}) - @equiv{} (set-breakpoint! trace-subtree . @var{args}) -@end smalllisp - -This means that these three procedures can be used to set the -corresponding behaviours for any type of breakpoint for which a -@code{set-breakpoint!} method exists, not just procedural ones. - - -@node Accessing Breakpoints -@subsubsection Accessing Breakpoints - -Information about the state and behaviour of a breakpoint is stored in -an instance of the appropriate breakpoint class. To access and change -that information, therefore, you need to get hold of the desired -breakpoint instance. - -The generic function @code{get-breakpoint} meets this need: For every -@code{set-breakpoint!} method there is a corresponding -@code{get-breakpoint} method. Note especially the useful -type-independent case: - -@smalllisp -(get-breakpoint 1) -@result{} -#< 808b0b0> -@end smalllisp - - -@node Breakpoint Behaviours -@subsubsection Breakpoint Behaviours - -A breakpoint's @dfn{behaviour} determines what happens when that -breakpoint is hit. Several kinds of behaviour are generally useful. - -@table @code -@item debug-here -Enter the command line debugger. This gives the opportunity to explore -the stack, evaluate expressions in any of the pending stack frames, -change breakpoint properties or set new breakpoints, and continue -program execution when you are done. - -@item trace-here -Trace the current stack frame. For expressions being evaluated, this -shows the expression. For procedure applications, it shows the -procedure name and its arguments @emph{post-evaluation}. For both -expressions and applications, the indentation of the tracing indicates -whether the traced items are mutually tail recursive. - -@item trace-subtree -Trace the current stack frame, and enable tracing for all future -evaluations and applications until the current stack frame is exited. -@code{trace-subtree} is a great preliminary exploration tool when all -you know is that there is a bug ``somewhere in XXX or in something that -XXX calls''. - -@item (at-exit @var{thunk}) -Don't do anything now, but arrange for @var{thunk} to be executed when -the current stack frame is exited. For example, the operation that most -debugging tools call ``finish'' is @code{(at-exit debug-here)}. - -@item (at-next @var{count} @var{thunk}) -@dots{} arrange for @var{thunk} to be executed when beginning the -@var{count}th next evaluation or application with source location in the -current file. - -@item (at-entry @var{count} @var{thunk}) -@dots{} arrange for @var{thunk} to be executed when beginning the -@var{count}th next evaluation (regardless of source location). - -@item (at-apply @var{count} @var{thunk}) -@dots{} arrange for @var{thunk} to be executed just before performing -the @var{count}th next application (regardless of source location). - -@item (at-step @var{count} @var{thunk}) -Synthesis of @code{at-entry} and @code{at-apply}; counts both -evaluations and applications. -@end table - -Every breakpoint instance has a slot in which its behaviour is stored. -If you have a breakpoint instance in hand, you can change its behaviour -using the @code{bp-behaviour} accessor. - -An @dfn{accessor} supports the setting of a property like this: - -@smalllisp -(set! (bp-behaviour @var{breakpoint}) @var{new-behaviour}) -@end smalllisp - -@noindent -See the GOOPS manual for further information on accessors. - -Alternatively, if you know how to specify the @var{location-args} for -the breakpoint in question, you can change its behaviour using -@code{set-breakpoint!}. For example: - -@smalllisp -;; Change behaviour of breakpoint number 2. -(set-breakpoint! @var{new-behaviour} 2) - -;; Change behaviour of procedural breakpoint on [fact1]. -(set-breakpoint! @var{new-behaviour} fact1) -@end smalllisp - -In all cases, the behaviour that you specify should be either a single -thunk, or a list of thunks, to be called when the breakpoint is hit. - -The most common behaviours above are exported as thunks from the -@code{(ice-9 debugger behaviour)} module. So, if you use this module, you can -use those behaviours directly like this: - -@smalllisp -(use-modules (ice-9 debugger behaviour)) -(set-breakpoint! trace-subtree 2) -(set! (bp-behaviour (get-breakpoint 3)) debug-here) -@end smalllisp - -@noindent -You can also use the list option to combine common behaviours: - -@smalllisp -(set-breakpoint! (list trace-here debug-here) 2) -@end smalllisp - -@noindent -Or, for more customized behaviour, you could build and use your own -thunk like this: - -@smalllisp -(define (my-behaviour) - (trace-here) - (at-exit (lambda () - (display "Exiting frame of my-behaviour bp\n") - ... do something unusual ...))) - -(set-breakpoint my-behaviour 2) -@end smalllisp - - -@node Enabling and Disabling -@subsubsection Enabling and Disabling - -Independently of its behaviour, each breakpoint also keeps track of -whether it is currently enabled. This is a straightforward convenience -to allow breakpoints to be temporarily switched off without losing all -their carefully constructed properties. - -If you have a breakpoint instance in hand, you can enable or disable it -using the @code{bp-enabled?} accessor. - -Alternatively, you can enable or disable a breakpoint via its location -args by using @code{enable-breakpoint!} or @code{disable-breakpoint!}. - -@smalllisp -(disable-breakpoint! fact1) ; disable the procedural breakpoint on fact1 -(enable-breakpoint! 1) ; enable breakpoint 1 -@end smalllisp - -@code{enable-breakpoint!} and @code{disable-breakpoint!} are implemented -using @code{get-breakpoint} and @code{bp-enabled?}, so any -@var{location-args} that are valid for @code{get-breakpoint} will work -also for these procedures. - - -@node Deleting Breakpoints -@subsubsection Deleting Breakpoints - -Given a breakpoint instance in hand, you can deactivate it and remove -it from the global list of current breakpoints by calling -@code{bp-delete!}. - -Alternatively, you can delete a breakpoint by its location args: - -@smalllisp -(delete-breakpoint! 1) ; delete breakpoint 1 -@end smalllisp - -@code{delete-breakpoint!} is implemented using @code{get-breakpoint} and -@code{bp-delete!}, so any @var{location-args} that are valid for -@code{get-breakpoint} will work also for @code{delete-breakpoint!}. - -There is no way to reinstate a deleted breakpoint. Final destruction of -the breakpoint instance is determined by the usual garbage collection -rules. - - -@node Breakpoint Information -@subsubsection Breakpoint Information - -To get Guile to print a description of a breakpoint instance, use -@code{bp-describe}: - -@smalllisp -(bp-describe (get-breakpoint 1) #t) ; #t specifies standard output -@print{} -Breakpoint 1: [fact1] - enabled? = #t - behaviour = # -@end smalllisp - -Following the usual model, @code{describe-breakpoint} is also provided: - -@smalllisp -(describe-breakpoint 1) -@print{} -Breakpoint 1: [fact1] - enabled? = #t - behaviour = # -@end smalllisp - -Finally, two stragglers. @code{all-breakpoints} returns a list of all -current breakpoints. @code{describe-all-breakpoints} combines -@code{bp-describe} and @code{all-breakpoints} by printing a description -of all current breakpoints to standard output. - -@node Other Breakpoint Types -@subsubsection Other Breakpoint Types - -Besides source and procedural breakpoints, Guile includes an early -implementation of a third class of breakpoints: @dfn{range} breakpoints. -These are breakpoints that trigger when program execution enters (or -perhaps exits) a defined range of source locations. - -Sadly, these don't yet work well. The apparent problem is that the -extra methods for @code{set-breakpoint!} and @code{get-breakpoint} cause -some kind of explosion in the time taken by GOOPS to construct its -method cache and to dispatch calls involving these generic functions. -But we haven't really investigated enough to be sure that this is the -real issue. - -If you're interested in looking and/or investigating anyway, please feel -free to check out and play with the @code{(ice-9 debugger breakpoints -range)} module. - -The other kind of breakpoint that we'd like to have is watchpoints, but -this hasn't been implemented at all yet. Watchpoints may turn out to be -impractical for performance reasons. - - -@node Interactive Debugger -@subsection Using the Interactive Debugger - -Guile's interactive debugger is a command line application that accepts -commands from you for examining the stack and, if at a breakpoint, for -continuing program execution in various ways. Unlike in the normal -Guile REPL, commands are typed mostly without parentheses. - -When you first enter the debugger, it introduces itself with a message -like this: - -@lisp -This is the Guile debugger -- for help, type `help'. -There are 3 frames on the stack. - -Frame 2 at standard input:36:19 - [+ 3 #\s] -debug> -@end lisp - -@noindent -``debug>'' is the debugger's prompt, and a useful reminder that you are -not in the normal Guile REPL. The available commands are described in -detail in the following subsections. - -@menu -* Display Backtrace:: backtrace. -* Frame Selection:: up, down, frame. -* Frame Information:: info args, info frame, position. -* Frame Evaluation:: evaluate. -* Single Stepping:: step, next. -* Run To Frame Exit:: finish, trace-finish. -* Continue Execution:: continue. -* Leave Debugger:: quit. -@end menu - - -@node Display Backtrace -@subsubsection Display Backtrace - -The @code{backtrace} command, which can also be invoked as @code{bt} or -@code{where}, displays the call stack (aka backtrace) at the point where -the debugger was entered: - -@lisp -debug> bt -In standard input: - 36: 0* [make-string ... - 36: 1* [* 4 ... - 36: 2* [+ 3 #\s] -@end lisp - -@deffn {Debugger Command} backtrace [count] -@deffnx {Debugger Command} bt [count] -@deffnx {Debugger Command} where [count] -Print backtrace of all stack frames, or of the innermost @var{count} -frames. With a negative argument, print the outermost -@var{count} -frames. If the number of frames isn't explicitly given, the debug -option @code{depth} determines the maximum number of frames printed. -@end deffn - -The format of the displayed backtrace is the same as for the -@code{backtrace} procedure --- see @ref{Backtrace Format} for details. - - -@node Frame Selection -@subsubsection Frame Selection - -A call stack consists of a sequence of stack @dfn{frames}, with each -frame describing one level of the nested evaluations and applications -that the program was executing when it hit a breakpoint or an error. -Frames are numbered such that frame 0 is the outermost --- i.e. the -operation on the call stack that began least recently --- and frame N-1 -the innermost (where N is the total number of frames on the stack). - -When you enter the debugger, the innermost frame is selected, which -means that the commands for getting information about the ``current'' -frame, or for evaluating expressions in the context of the current -frame, will do so by default with respect to the innermost frame. To -select a different frame, so that these operations will apply to it -instead, use the @code{up}, @code{down} and @code{frame} commands like -this: - -@lisp -debug> up -Frame 1 at standard input:36:14 - [* 4 ... -debug> frame 0 -Frame 0 at standard input:36:1 - [make-string ... -debug> down -Frame 1 at standard input:36:14 - [* 4 ... -@end lisp - -@deffn {Debugger Command} up [n] -Move @var{n} frames up the stack. For positive @var{n}, this -advances toward the outermost frame, to higher frame numbers, to -frames that have existed longer. @var{n} defaults to one. -@end deffn - -@deffn {Debugger Command} down [n] -Move @var{n} frames down the stack. For positive @var{n}, this -advances toward the innermost frame, to lower frame numbers, to frames -that were created more recently. @var{n} defaults to one. -@end deffn - -@deffn {Debugger Command} frame [n] -Select and print a stack frame. With no argument, print the selected -stack frame. (See also ``info frame''.) An argument specifies the -frame to select; it must be a stack-frame number. -@end deffn - - -@node Frame Information -@subsubsection Frame Information - -[to be completed] - -@deffn {Debugger Command} {info frame} -All about selected stack frame. -@end deffn - -@deffn {Debugger Command} {info args} -Argument variables of current stack frame. -@end deffn - -@deffn {Debugger Command} position -Display the position of the current expression. -@end deffn - - -@node Frame Evaluation -@subsubsection Frame Evaluation - -[to be completed] - -@deffn {Debugger Command} evaluate expression -Evaluate an expression. -The expression must appear on the same line as the command, -however it may be continued over multiple lines. -@end deffn - - -@node Single Stepping -@subsubsection Single Stepping - -[to be completed] - -@deffn {Debugger Command} step [n] -Continue until entry to @var{n}th next frame. -@end deffn - -@deffn {Debugger Command} next [n] -Continue until entry to @var{n}th next frame in same file. -@end deffn - - -@node Run To Frame Exit -@subsubsection Run To Frame Exit - -[to be completed] - -@deffn {Debugger Command} finish -Continue until evaluation of the current frame is complete, and -print the result obtained. -@end deffn - -@deffn {Debugger Command} trace-finish -Trace until evaluation of the current frame is complete. -@end deffn - - -@node Continue Execution -@subsubsection Continue Execution - -[to be completed] - -@deffn {Debugger Command} continue -Continue program execution. -@end deffn - - -@node Leave Debugger -@subsubsection Leave Debugger - -[to be completed] - -@deffn {Debugger Command} quit -Exit the debugger. -@end deffn - - @node Tracing @subsection Tracing -Tracing has already been described as a breakpoint behaviour -(@pxref{Breakpoint Behaviours}), but we mention it again here because it -is so useful, and because Guile actually now has @emph{two} mechanisms -for tracing, and its worth clarifying the differences between them. +Tracing has already been described as a breakpoint behaviour, but we +mention it again here because it is so useful, and because Guile +actually now has @emph{two} mechanisms for tracing, and its worth +clarifying the differences between them. @menu * Old Tracing:: Tracing provided by (ice-9 debug). diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi new file mode 100644 index 000000000..b596ce50a --- /dev/null +++ b/doc/ref/scheme-using.texi @@ -0,0 +1,411 @@ +@c -*-texinfo-*- +@c This is part of the GNU Guile Reference Manual. +@c Copyright (C) 2006 +@c Free Software Foundation, Inc. +@c See the file guile.texi for copying conditions. + +@node Using Guile Interactively +@section Using Guile Interactively + +When you start up Guile by typing just @code{guile}, without a +@code{-c} argument or the name of a script to execute, you get an +interactive interpreter where you can enter Scheme expressions, and +Guile will evaluate them and print the results for you. Here are some +simple examples. + +@lisp +guile> (+ 3 4 5) +12 +guile> (display "Hello world!\n") +Hello world! +guile> (values 'a 'b) +a +b +@end lisp + +@noindent +This mode of use is called a @dfn{REPL}, which is short for +``Read-Eval-Print Loop'', because the Guile interpreter first reads the +expression that you have typed, then evaluates it, and then prints the +result. + +@menu +* Readline:: +* Value Historyx:: +* Error Handling:: +* Interactive Debugger:: Using the interactive debugger. +@end menu + + +@node Readline +@subsection Readline + +To make it easier for you to repeat and vary previously entered +expressions, or to edit the expression that you're typing in, Guile +can use the GNU Readline library. This is not enabled by default +because of licensing reasons, but all you need to activate Readline is +the following pair of lines. + +@lisp +guile> (use-modules (ice-9 readline)) +guile> (activate-readline) +@end lisp + +It's a good idea to put these two lines (without the ``guile>'' +prompts) in your @file{.guile} file. Guile reads this file when it +starts up interactively, so anything in this file has the same effect +as if you type it in by hand at the ``guile>'' prompt. + + +@node Value Historyx +@subsection Value History + +Just as Readline helps you to reuse a previous input line, @dfn{value +history} allows you to use the @emph{result} of a previous evaluation +in a new expression. When value history is enabled, each evaluation +result is automatically assigned to the next in the sequence of +variables @code{$1}, @code{$2}, @dots{}, and you can then use these +variables in subsequent expressions. + +@lisp +guile> (iota 10) +$1 = (0 1 2 3 4 5 6 7 8 9) +guile> (apply * (cdr $1)) +$2 = 362880 +guile> (sqrt $2) +$3 = 602.3952191045344 +guile> (cons $2 $1) +$4 = (362880 0 1 2 3 4 5 6 7 8 9) +@end lisp + +To enable value history, type @code{(use-modules (ice-9 history))} at +the Guile prompt, or add this to your @file{.guile} file. (It is not +enabled by default, to avoid the possibility of conflicting with some +other use you may have for the variables @code{$1}, @code{$2}, +@dots{}, and also because it prevents the stored evaluation results +from being garbage collected, which some people may not want.) + + +@node Error Handling +@subsection Error Handling + +When code being evaluated from the REPL hits an error, Guile remembers +the execution context where the error occurred and can give you three +levels of information about what the error was and exactly where it +occurred. + +By default, Guile then displays only the first level, which is the most +immediate information about where and why the error occurred, for +example: + +@lisp +(make-string (* 4 (+ 3 #\s)) #\space) +@print{} +standard input:2:19: In procedure + in expression (+ 3 #\s): +standard input:2:19: Wrong type argument: #\s +ABORT: (wrong-type-arg) + +Type "(backtrace)" to get more information or "(debug)" to enter the debugger. +@end lisp + +@noindent +However, as the message above says, you can obtain more information +about the context of the error by typing @code{(backtrace)} or +@code{(debug)}. + +@code{(backtrace)} displays the Scheme call stack at the point where the +error occurred: + +@lisp +(backtrace) +@print{} +Backtrace: +In standard input: + 2: 0* [make-string ... + 2: 1* [* 4 ... + 2: 2* [+ 3 #\s] + +Type "(debug-enable 'backtrace)" if you would like a backtrace +automatically if an error occurs in the future. +@end lisp + +@noindent +In a more complex scenario than this one, this can be extremely useful +for understanding where and why the error occurred. You can make Guile +show the backtrace automatically by adding @code{(debug-enable +'backtrace)} to your @file{.guile}. + +@code{(debug)} takes you into Guile's interactive debugger, which +provides commands that allow you to + +@itemize @bullet +@item +display the Scheme call stack at the point where the error occurred +(the @code{backtrace} command --- see @ref{Display Backtrace}) + +@item +move up and down the call stack, to see in detail the expression being +evaluated, or the procedure being applied, in each @dfn{frame} (the +@code{up}, @code{down}, @code{frame}, @code{position}, @code{info args} +and @code{info frame} commands --- see @ref{Frame Selection} and +@ref{Frame Information}) + +@item +examine the values of variables and expressions in the context of each +frame (the @code{evaluate} command --- see @ref{Frame Evaluation}). +@end itemize + +@noindent +This is documented further in the following section. + + +@node Interactive Debugger +@subsection Using the Interactive Debugger + +Guile's interactive debugger is a command line application that accepts +commands from you for examining the stack and, if at a breakpoint, for +continuing program execution in various ways. Unlike in the normal +Guile REPL, commands are typed mostly without parentheses. + +When you first enter the debugger, it introduces itself with a message +like this: + +@lisp +This is the Guile debugger -- for help, type `help'. +There are 3 frames on the stack. + +Frame 2 at standard input:36:19 + [+ 3 #\s] +debug> +@end lisp + +@noindent +``debug>'' is the debugger's prompt, and a reminder that you are not in +the normal Guile REPL. The available commands are described in the +following subsections. + +@menu +* Display Backtrace:: backtrace. +* Frame Selection:: up, down, frame. +* Frame Information:: info args, info frame, position. +* Frame Evaluation:: evaluate. +* Single Stepping:: step, next. +* Run To Frame Exit:: finish, trace-finish. +* Continue Execution:: continue. +* Leave Debugger:: quit. +@end menu + + +@node Display Backtrace +@subsubsection Display Backtrace + +The @code{backtrace} command, which can also be invoked as @code{bt} or +@code{where}, displays the call stack (aka backtrace) at the point where +the debugger was entered: + +@lisp +debug> bt +In standard input: + 36: 0* [make-string ... + 36: 1* [* 4 ... + 36: 2* [+ 3 #\s] +@end lisp + +@deffn {Debugger Command} backtrace [count] +@deffnx {Debugger Command} bt [count] +@deffnx {Debugger Command} where [count] +Print backtrace of all stack frames, or of the innermost @var{count} +frames. With a negative argument, print the outermost -@var{count} +frames. If the number of frames isn't explicitly given, the debug +option @code{depth} determines the maximum number of frames printed. +@end deffn + +The format of the displayed backtrace is the same as for the +@code{backtrace} procedure. + + +@node Frame Selection +@subsubsection Frame Selection + +A call stack consists of a sequence of stack @dfn{frames}, with each +frame describing one level of the nested evaluations and applications +that the program was executing when it hit a breakpoint or an error. +Frames are numbered such that frame 0 is the outermost --- i.e. the +operation on the call stack that began least recently --- and frame N-1 +the innermost (where N is the total number of frames on the stack). + +When you enter the debugger, the innermost frame is selected, which +means that the commands for getting information about the ``current'' +frame, or for evaluating expressions in the context of the current +frame, will do so by default with respect to the innermost frame. To +select a different frame, so that these operations will apply to it +instead, use the @code{up}, @code{down} and @code{frame} commands like +this: + +@lisp +debug> up +Frame 1 at standard input:36:14 + [* 4 ... +debug> frame 0 +Frame 0 at standard input:36:1 + [make-string ... +debug> down +Frame 1 at standard input:36:14 + [* 4 ... +@end lisp + +@deffn {Debugger Command} up [n] +Move @var{n} frames up the stack. For positive @var{n}, this +advances toward the outermost frame, to higher frame numbers, to +frames that have existed longer. @var{n} defaults to one. +@end deffn + +@deffn {Debugger Command} down [n] +Move @var{n} frames down the stack. For positive @var{n}, this +advances toward the innermost frame, to lower frame numbers, to frames +that were created more recently. @var{n} defaults to one. +@end deffn + +@deffn {Debugger Command} frame [n] +Select and print a stack frame. With no argument, print the selected +stack frame. (See also ``info frame''.) An argument specifies the +frame to select; it must be a stack-frame number. +@end deffn + + +@node Frame Information +@subsubsection Frame Information + +[to be completed] + +@deffn {Debugger Command} {info frame} +All about selected stack frame. +@end deffn + +@deffn {Debugger Command} {info args} +Argument variables of current stack frame. +@end deffn + +@deffn {Debugger Command} position +Display the position of the current expression. +@end deffn + + +@node Frame Evaluation +@subsubsection Frame Evaluation + +[to be completed] + +@deffn {Debugger Command} evaluate expression +Evaluate an expression. +The expression must appear on the same line as the command, +however it may be continued over multiple lines. +@end deffn + + +@node Single Stepping +@subsubsection Single Stepping + +[to be completed] + +@deffn {Debugger Command} step [n] +Continue until entry to @var{n}th next frame. +@end deffn + +@deffn {Debugger Command} next [n] +Continue until entry to @var{n}th next frame in same file. +@end deffn + + +@node Run To Frame Exit +@subsubsection Run To Frame Exit + +[to be completed] + +@deffn {Debugger Command} finish +Continue until evaluation of the current frame is complete, and +print the result obtained. +@end deffn + +@deffn {Debugger Command} trace-finish +Trace until evaluation of the current frame is complete. +@end deffn + + +@node Continue Execution +@subsubsection Continue Execution + +[to be completed] + +@deffn {Debugger Command} continue +Continue program execution. +@end deffn + + +@node Leave Debugger +@subsubsection Leave Debugger + +[to be completed] + +@deffn {Debugger Command} quit +Exit the debugger. +@end deffn + + +@node Using Guile in Emacs +@section Using Guile in Emacs + +The Guile distribution includes a rich environment for working on Guile +Scheme code within Emacs. The idea of this environment is to allow you +to work on Guile Scheme code in the same kind of way that Emacs allows +you to work on Emacs Lisp code: providing easy access to help, +evaluating arbitrary fragments of code, a nice debugging interface, and +so on.@footnote{You can also, of course, run a Guile session in Emacs +simply by typing ``guile'' in a @code{*shell*} buffer. The environment +described here provides a much better integration than that, though.} + +The thinking behind this environment is that you will usually be doing +one of two things. + +@enumerate +@item +Writing or editing code. The code will be in a normal Emacs Scheme +mode buffer, and the Guile/Emacs environment extends Scheme mode to +add keystrokes and menu items for the things that are likely to be +useful to you when working on code: + +@itemize +@item +completing the identifier at point +@item +accessing Guile's built in help +@item +evaluating fragments of code to check what they do. +@end itemize + +@item +Debugging a Guile Scheme program. When your program hits an error or +a breakpoint, the Guile/Emacs environment shows you the relevant code +and the Scheme stack, and makes it easy to + +@itemize +@item +look at the values of local variables +@item +see what is happening at all levels of the Scheme stack +@item +continue execution, either normally or step by step. +@end itemize +@end enumerate + +Combinations of these work well too. You can evaluate a fragment of +code (in a Scheme buffer) that contains a breakpoint, then use the +debugging interface to step through the code at the breakpoint. You +can also run a program until it hits a breakpoint, then examine, +modify and reevaluate some of the relevant code, and then tell the +program to continue running. + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: From c9ef37410d864b4b5b8bcc0c2500a7700d80c358 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 1 Aug 2006 21:51:12 +0000 Subject: [PATCH 015/116] * api-debug.texi (Breakpoints): Removed (all wrong). * guile.texi (API Reference): Improved summary for "Debugging" menu item. --- doc/ref/ChangeLog | 5 +++ doc/ref/api-debug.texi | 81 ------------------------------------------ doc/ref/guile.texi | 4 +-- 3 files changed, 7 insertions(+), 83 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 2604a2607..1f7b4fc83 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,5 +1,10 @@ 2006-08-01 Neil Jerram + * api-debug.texi (Breakpoints): Removed (all wrong). + + * guile.texi (API Reference): Improved summary for "Debugging" + menu item. + * scheme-debugging.texi (Debug Last Error, Interactive Debugger): Moved/merged to scheme-using.texi, as REPL features. (Examples): New. diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 458ea034e..f5aa07d0c 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -10,7 +10,6 @@ @menu * Interactive Debugging:: Functions intended for interactive use. -* Breakpoints:: * Source Properties:: Remembering the source of an expression. * Using Traps:: * Capturing the Stack or Innermost Stack Frame:: @@ -36,86 +35,6 @@ the backtrace. Invoke the Guile debugger to explore the context of the last error. @end deffn -@node Breakpoints -@subsection Breakpoints - -@deffn {Generic Function} set-breakpoint! behaviour . location-args -Set a breakpoint with behaviour @var{behaviour} at the location -specified by @var{location-args}. - -The form of the @var{location-args} depends upon what methods for -@code{set-breakpoint!} have been provided by the implementations of -subclasses of the @code{} base class. -@end deffn - -@deffn {Generic Function} get-breakpoint . location-args -Find and return the breakpoint instance at the location specified by -@var{location-args}. - -The form of the @var{location-args} depends upon what methods for -@code{get-breakpoint} have been provided by the implementations of -subclasses of the @code{} base class. -@end deffn - -@deffn {Method} set-breakpoint! behaviour (proc ) -Set a breakpoint with behaviour @var{behaviour} before applications of -the procedure @var{proc}. -@end deffn - -@deffn {Method} set-breakpoint! behaviour x-as-read (x-pairified ) -Set a breakpoint with behaviour @var{behaviour} on the source expression -@var{x-pairified}, storing @var{x-as-read} for use in messages -describing the breakpoint. -@end deffn - -@deffn {Method} set-breakpoint! behaviour (number ) -Change the behaviour of existing breakpoint number @var{number} to -@var{behaviour}. -@end deffn - -@deffn {Accessor} bp-behaviour breakpoint -Get or set the behaviour of the breakpoint instance @var{breakpoint}. -@end deffn - -@deffn {Accessor} bp-enabled? breakpoint -Get or set the enabled state of the specified @var{breakpoint}. -@end deffn - -@deffn {Procedure} enable-breakpoint! . location-args -@deffnx {Procedure} disable-breakpoint! . location-args -Enable or disable the breakpoint at the location specified by -@var{location-args}. -@end deffn - -@deffn {Generic Function} bp-delete! breakpoint -Delete breakpoint @var{breakpoint}. This means (1) doing whatever is -needed to prevent the breakpoint from triggering again, and (2) removing -it from the global list of current breakpoints. -@end deffn - -@deffn {Procedure} delete-breakpoint! . location-args -Delete the breakpoint at the location specified by @var{location-args}. -@end deffn - -@deffn {Generic Function} bp-describe breakpoint port -Print a description of @var{breakpoint} to the specified @var{port}. -@var{port} can be @code{#t} for standard output, or else any output -port. -@end deffn - -@deffn {Procedure} describe-breakpoint . location-args -Print (to standard output) a description of the breakpoint at location -specified by @var{location-args}. -@end deffn - -@deffn {Procedure} all-breakpoints -Return a list of all current breakpoints, ordered by breakpoint number. -@end deffn - -@deffn {Procedure} describe-all-breakpoints -Print a description of all current breakpoints to standard output. -@end deffn - @node Source Properties @subsection Source Properties diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 08e8b0755..627c8cbb2 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -137,7 +137,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.45 2006-08-01 21:33:17 ossau Exp $ +@c @subtitle $Id: guile.texi,v 1.46 2006-08-01 21:51:12 ossau Exp $ @c See preface.texi for the list of authors @author The Guile Developers @@ -305,7 +305,7 @@ available through both Scheme and C interfaces. * Options and Config:: Configuration, features and runtime options. * Translation:: Support for translating other languages. * Internationalization:: Support for gettext, etc. -* Debugging:: Internal debugging interface. +* Debugging:: Debugging infrastructure and Scheme interface. * GH:: The deprecated GH interface. @end menu From b0b0deff2decac0f6b3249a4e9a5f323426807b8 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 11 Aug 2006 15:33:41 +0000 Subject: [PATCH 016/116] (scm_last_stack_frame): Correct docstring (returns a frame, not a stack). --- libguile/ChangeLog | 5 +++++ libguile/stacks.c | 5 ++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f8e6c3436..11001fb3b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2006-08-11 Neil Jerram + + * stacks.c (scm_last_stack_frame): Correct docstring (returns a + frame, not a stack). + 2006-07-18 Rob Browning * continuations.c: Add __attribute__ ((returns_twice)) to the diff --git a/libguile/stacks.c b/libguile/stacks.c index 9457ccc13..de85522ca 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -581,9 +581,8 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, (SCM obj), - "Return a stack which consists of a single frame, which is the\n" - "last stack frame for @var{obj}. @var{obj} must be either a\n" - "debug object or a continuation.") + "Return the last (innermost) frame of @var{obj}, which must be\n" + "either a debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { scm_t_debug_frame *dframe; From 5af872e136b2e7c74b566b68bbab97b288464578 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 11 Aug 2006 15:38:19 +0000 Subject: [PATCH 017/116] (Debugging): New intro text. New subsection "Evaluation Model". Moved existing subsections "Capturing the Stack or Innermost Stack Frame", "Examining the Stack", "Examining Stack Frames", "Source Properties", "Decoding Memoized Source Expressions" and "Starting a New Stack" under "Evaluation Model". (Capturing the Stack or Innermost Stack Frame): Some new text, and correction to doc for last-stack-frame. (Debug on Error): Renamed from "Interactive Debugging". --- doc/ref/ChangeLog | 11 ++ doc/ref/api-debug.texi | 427 +++++++++++++++++++++++------------------ 2 files changed, 254 insertions(+), 184 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 1f7b4fc83..982871ee6 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,14 @@ +2006-08-11 Neil Jerram + + * api-debug.texi (Debugging): New intro text. New subsection + "Evaluation Model". Moved existing subsections "Capturing the + Stack or Innermost Stack Frame", "Examining the Stack", "Examining + Stack Frames", "Source Properties", "Decoding Memoized Source + Expressions" and "Starting a New Stack" under "Evaluation Model". + (Capturing the Stack or Innermost Stack Frame): Some new text, and + correction to doc for last-stack-frame. + (Debug on Error): Renamed from "Interactive Debugging". + 2006-08-01 Neil Jerram * api-debug.texi (Breakpoints): Removed (all wrong). diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index f5aa07d0c..42527b7ec 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -8,36 +8,234 @@ @node Debugging @section Debugging Infrastructure +In order to understand Guile's debugging facilities, you first need to +understand a little about how the evaluator works and what the Scheme +stack is. With that in place we explain the low level trap calls that +the evaluator can be configured to make, and the trap and breakpoint +infrastructure that builds on top of those calls. + @menu -* Interactive Debugging:: Functions intended for interactive use. -* Source Properties:: Remembering the source of an expression. +* Evaluation Model:: Evaluation and the Scheme stack. +* Debug on Error:: Debugging when an error occurs. * Using Traps:: +@end menu + +@node Evaluation Model +@subsection Evaluation and the Scheme Stack + +The idea of the Scheme stack is central to a lot of debugging. It +always exists implicitly, as a result of the way that the Guile +evaluator works, and can be summoned into concrete existence as a +first-class Scheme value by the @code{make-stack} call, so that an +introspective Scheme program -- such as a debugger -- can present it in +some way and allow the user to query its details. The first thing to +understand, therefore, is how the workings of the evaluator build up the +stack. + +@cindex Evaluations +@cindex Applications +Broadly speaking, the evaluator performs @dfn{evaluations} and +@dfn{applications}. An evaluation means that it is looking at a source +code expression like @code{(+ x 5)} or @code{(if msg (loop))}, deciding +whether the top level of the expression is a procedure call, macro, +builtin syntax, or whatever, and doing some appropriate processing in +each case. (In the examples here, @code{(+ x 5)} would normally be a +procedure call, and @code{(if msg (loop))} builtin syntax.) For a +procedure call, ``appropriate processing'' includes evaluating the +procedure's arguments, as that must happen before the procedure itself +can be called. An application means calling a procedure once its +arguments have been calculated. + +@cindex Stack +@cindex Frames +@cindex Stack frames +Typically evaluations and applications alternate with each other, and +together they form a @dfn{stack} of operations pending completion. This +is because, on the one hand, evaluation of an expression like @code{(+ x +5)} requires --- once its arguments have been calculated --- an +application (in this case, of the procedure @code{+}) before it can +complete and return a result, and, on the other hand, the application of +a procedure written in Scheme involves evaluating the sequence of +expressions that constitute that procedure's code. Each level on this +stack is called a @dfn{frame}. + +Therefore, when an error occurs in a running program, or the program +hits a breakpoint, or in fact at any point that the programmer chooses, +its state at that point can be represented by a @dfn{stack} of all the +evaluations and procedure applications that are logically in progress at +that time, each of which is known as a @dfn{frame}. The programmer can +learn more about the program's state at that point by inspecting the +stack and its frames. + +@menu * Capturing the Stack or Innermost Stack Frame:: * Examining the Stack:: * Examining Stack Frames:: +* Source Properties:: Remembering the source of an expression. * Decoding Memoized Source Expressions:: * Starting a New Stack:: @end menu -@node Interactive Debugging -@subsection Interactive Debugging +@node Capturing the Stack or Innermost Stack Frame +@subsubsection Capturing the Stack or Innermost Stack Frame -@deffn {Scheme Procedure} backtrace [highlights] -@deffnx {C Function} scm_backtrace_with_highlights (highlights) -@deffnx {C Function} scm_backtrace () -Display a backtrace of the stack saved by the last error -to the current output port. When @var{highlights} is given, +A Scheme program can use the @code{make-stack} primitive anywhere in its +code, with first arg @code{#t}, to construct a Scheme value that +describes the Scheme stack at that point. + +@lisp +(make-stack #t) +@result{} +# +@end lisp + +@deffn {Scheme Procedure} make-stack obj . args +@deffnx {C Function} scm_make_stack (obj, args) +Create a new stack. If @var{obj} is @code{#t}, the current +evaluation stack is used for creating the stack frames, +otherwise the frames are taken from @var{obj} (which must be +either a debug object or a continuation). + +@var{args} should be a list containing any combination of +integer, procedure and @code{#t} values. + +These values specify various ways of cutting away uninteresting +stack frames from the top and bottom of the stack that +@code{make-stack} returns. They come in pairs like this: +@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2} +@var{outer_cut_2} @dots{})}. + +Each @var{inner_cut_N} can be @code{#t}, an integer, or a +procedure. @code{#t} means to cut away all frames up to but +excluding the first user module frame. An integer means to cut +away exactly that number of frames. A procedure means to cut +away all frames up to but excluding the application frame whose +procedure matches the specified one. + +Each @var{outer_cut_N} can be an integer or a procedure. An +integer means to cut away that number of frames. A procedure +means to cut away frames down to but excluding the application +frame whose procedure matches the specified one. + +If the @var{outer_cut_N} of the last pair is missing, it is +taken as 0. +@end deffn + +@deffn {Scheme Procedure} last-stack-frame obj +@deffnx {C Function} scm_last_stack_frame (obj) +Return the last (innermost) frame of @var{obj}, which must be +either a debug object or a continuation. +@end deffn + + +@node Examining the Stack +@subsubsection Examining the Stack + +@deffn {Scheme Procedure} stack? obj +@deffnx {C Function} scm_stack_p (obj) +Return @code{#t} if @var{obj} is a calling stack. +@end deffn + +@deffn {Scheme Procedure} stack-id stack +@deffnx {C Function} scm_stack_id (stack) +Return the identifier given to @var{stack} by @code{start-stack}. +@end deffn + +@deffn {Scheme Procedure} stack-length stack +@deffnx {C Function} scm_stack_length (stack) +Return the length of @var{stack}. +@end deffn + +@deffn {Scheme Procedure} stack-ref stack index +@deffnx {C Function} scm_stack_ref (stack, index) +Return the @var{index}'th frame from @var{stack}. +@end deffn + +@deffn {Scheme Procedure} display-backtrace stack port [first [depth [highlights]]] +@deffnx {C Function} scm_display_backtrace_with_highlights (stack, port, first, depth, highlights) +@deffnx {C Function} scm_display_backtrace (stack, port, first, depth) +Display a backtrace to the output port @var{port}. @var{stack} +is the stack to take the backtrace from, @var{first} specifies +where in the stack to start and @var{depth} how much frames +to display. Both @var{first} and @var{depth} can be @code{#f}, +which means that default values will be used. +When @var{highlights} is given, it should be a list and all members of it are highligthed in the backtrace. @end deffn -@deffn {Scheme Procedure} debug -Invoke the Guile debugger to explore the context of the last error. + +@node Examining Stack Frames +@subsubsection Examining Stack Frames + +@deffn {Scheme Procedure} frame? obj +@deffnx {C Function} scm_frame_p (obj) +Return @code{#t} if @var{obj} is a stack frame. +@end deffn + +@deffn {Scheme Procedure} frame-number frame +@deffnx {C Function} scm_frame_number (frame) +Return the frame number of @var{frame}. +@end deffn + +@deffn {Scheme Procedure} frame-previous frame +@deffnx {C Function} scm_frame_previous (frame) +Return the previous frame of @var{frame}, or @code{#f} if +@var{frame} is the first frame in its stack. +@end deffn + +@deffn {Scheme Procedure} frame-next frame +@deffnx {C Function} scm_frame_next (frame) +Return the next frame of @var{frame}, or @code{#f} if +@var{frame} is the last frame in its stack. +@end deffn + +@deffn {Scheme Procedure} frame-source frame +@deffnx {C Function} scm_frame_source (frame) +Return the source of @var{frame}. +@end deffn + +@deffn {Scheme Procedure} frame-procedure? frame +@deffnx {C Function} scm_frame_procedure_p (frame) +Return @code{#t} if a procedure is associated with @var{frame}. +@end deffn + +@deffn {Scheme Procedure} frame-procedure frame +@deffnx {C Function} scm_frame_procedure (frame) +Return the procedure for @var{frame}, or @code{#f} if no +procedure is associated with @var{frame}. +@end deffn + +@deffn {Scheme Procedure} frame-arguments frame +@deffnx {C Function} scm_frame_arguments (frame) +Return the arguments of @var{frame}. +@end deffn + +@deffn {Scheme Procedure} frame-evaluating-args? frame +@deffnx {C Function} scm_frame_evaluating_args_p (frame) +Return @code{#t} if @var{frame} contains evaluated arguments. +@end deffn + +@deffn {Scheme Procedure} frame-overflow? frame +@deffnx {C Function} scm_frame_overflow_p (frame) +Return @code{#t} if @var{frame} is an overflow frame. +@end deffn + +@deffn {Scheme Procedure} frame-real? frame +@deffnx {C Function} scm_frame_real_p (frame) +Return @code{#t} if @var{frame} is a real frame. +@end deffn + +@deffn {Scheme Procedure} display-application frame [port [indent]] +@deffnx {C Function} scm_display_application (frame, port, indent) +Display a procedure application @var{frame} to the output port +@var{port}. @var{indent} specifies the indentation of the +output. @end deffn @node Source Properties -@subsection Source Properties +@subsubsection Source Properties @cindex source properties As Guile reads in Scheme code from file or from standard input, it @@ -135,178 +333,8 @@ that will avoid bloating the source property hash table, which is really only intended for the specific purposes described in this section. -@node Using Traps -@subsection Using Traps - -@deffn {Scheme Procedure} with-traps thunk -@deffnx {C Function} scm_with_traps (thunk) -Call @var{thunk} with traps enabled. -@end deffn - -@deffn {Scheme Procedure} debug-object? obj -@deffnx {C Function} scm_debug_object_p (obj) -Return @code{#t} if @var{obj} is a debug object. -@end deffn - - -@node Capturing the Stack or Innermost Stack Frame -@subsection Capturing the Stack or Innermost Stack Frame - -When an error occurs in a running program, or the program hits a -breakpoint, its state at that point can be represented by a @dfn{stack} -of all the evaluations and procedure applications that are logically in -progress at that time, each of which is known as a @dfn{frame}. The -programmer can learn more about the program's state at the point of -interruption or error by inspecting the stack and its frames. - -@deffn {Scheme Procedure} make-stack obj . args -@deffnx {C Function} scm_make_stack (obj, args) -Create a new stack. If @var{obj} is @code{#t}, the current -evaluation stack is used for creating the stack frames, -otherwise the frames are taken from @var{obj} (which must be -either a debug object or a continuation). - -@var{args} should be a list containing any combination of -integer, procedure and @code{#t} values. - -These values specify various ways of cutting away uninteresting -stack frames from the top and bottom of the stack that -@code{make-stack} returns. They come in pairs like this: -@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2} -@var{outer_cut_2} @dots{})}. - -Each @var{inner_cut_N} can be @code{#t}, an integer, or a -procedure. @code{#t} means to cut away all frames up to but -excluding the first user module frame. An integer means to cut -away exactly that number of frames. A procedure means to cut -away all frames up to but excluding the application frame whose -procedure matches the specified one. - -Each @var{outer_cut_N} can be an integer or a procedure. An -integer means to cut away that number of frames. A procedure -means to cut away frames down to but excluding the application -frame whose procedure matches the specified one. - -If the @var{outer_cut_N} of the last pair is missing, it is -taken as 0. -@end deffn - -@deffn {Scheme Procedure} last-stack-frame obj -@deffnx {C Function} scm_last_stack_frame (obj) -Return a stack which consists of a single frame, which is the -last stack frame for @var{obj}. @var{obj} must be either a -debug object or a continuation. -@end deffn - - -@node Examining the Stack -@subsection Examining the Stack - -@deffn {Scheme Procedure} stack? obj -@deffnx {C Function} scm_stack_p (obj) -Return @code{#t} if @var{obj} is a calling stack. -@end deffn - -@deffn {Scheme Procedure} stack-id stack -@deffnx {C Function} scm_stack_id (stack) -Return the identifier given to @var{stack} by @code{start-stack}. -@end deffn - -@deffn {Scheme Procedure} stack-length stack -@deffnx {C Function} scm_stack_length (stack) -Return the length of @var{stack}. -@end deffn - -@deffn {Scheme Procedure} stack-ref stack index -@deffnx {C Function} scm_stack_ref (stack, index) -Return the @var{index}'th frame from @var{stack}. -@end deffn - -@deffn {Scheme Procedure} display-backtrace stack port [first [depth [highlights]]] -@deffnx {C Function} scm_display_backtrace_with_highlights (stack, port, first, depth, highlights) -@deffnx {C Function} scm_display_backtrace (stack, port, first, depth) -Display a backtrace to the output port @var{port}. @var{stack} -is the stack to take the backtrace from, @var{first} specifies -where in the stack to start and @var{depth} how much frames -to display. Both @var{first} and @var{depth} can be @code{#f}, -which means that default values will be used. -When @var{highlights} is given, -it should be a list and all members of it are highligthed in -the backtrace. -@end deffn - - -@node Examining Stack Frames -@subsection Examining Stack Frames - -@deffn {Scheme Procedure} frame? obj -@deffnx {C Function} scm_frame_p (obj) -Return @code{#t} if @var{obj} is a stack frame. -@end deffn - -@deffn {Scheme Procedure} frame-number frame -@deffnx {C Function} scm_frame_number (frame) -Return the frame number of @var{frame}. -@end deffn - -@deffn {Scheme Procedure} frame-previous frame -@deffnx {C Function} scm_frame_previous (frame) -Return the previous frame of @var{frame}, or @code{#f} if -@var{frame} is the first frame in its stack. -@end deffn - -@deffn {Scheme Procedure} frame-next frame -@deffnx {C Function} scm_frame_next (frame) -Return the next frame of @var{frame}, or @code{#f} if -@var{frame} is the last frame in its stack. -@end deffn - -@deffn {Scheme Procedure} frame-source frame -@deffnx {C Function} scm_frame_source (frame) -Return the source of @var{frame}. -@end deffn - -@deffn {Scheme Procedure} frame-procedure? frame -@deffnx {C Function} scm_frame_procedure_p (frame) -Return @code{#t} if a procedure is associated with @var{frame}. -@end deffn - -@deffn {Scheme Procedure} frame-procedure frame -@deffnx {C Function} scm_frame_procedure (frame) -Return the procedure for @var{frame}, or @code{#f} if no -procedure is associated with @var{frame}. -@end deffn - -@deffn {Scheme Procedure} frame-arguments frame -@deffnx {C Function} scm_frame_arguments (frame) -Return the arguments of @var{frame}. -@end deffn - -@deffn {Scheme Procedure} frame-evaluating-args? frame -@deffnx {C Function} scm_frame_evaluating_args_p (frame) -Return @code{#t} if @var{frame} contains evaluated arguments. -@end deffn - -@deffn {Scheme Procedure} frame-overflow? frame -@deffnx {C Function} scm_frame_overflow_p (frame) -Return @code{#t} if @var{frame} is an overflow frame. -@end deffn - -@deffn {Scheme Procedure} frame-real? frame -@deffnx {C Function} scm_frame_real_p (frame) -Return @code{#t} if @var{frame} is a real frame. -@end deffn - -@deffn {Scheme Procedure} display-application frame [port [indent]] -@deffnx {C Function} scm_display_application (frame, port, indent) -Display a procedure application @var{frame} to the output port -@var{port}. @var{indent} specifies the indentation of the -output. -@end deffn - - @node Decoding Memoized Source Expressions -@subsection Decoding Memoized Source Expressions +@subsubsection Decoding Memoized Source Expressions @deffn {Scheme Procedure} memoized? obj @deffnx {C Function} scm_memoized_p (obj) @@ -325,7 +353,7 @@ Return the environment of the memoized expression @var{m}. @node Starting a New Stack -@subsection Starting a New Stack +@subsubsection Starting a New Stack @deffn {Scheme Syntax} start-stack id exp Evaluate @var{exp} on a new calling stack with identity @var{id}. If @@ -336,6 +364,37 @@ a convenience to the user. @end deffn +@node Debug on Error +@subsection Debugging when an error occurs + +@deffn {Scheme Procedure} backtrace [highlights] +@deffnx {C Function} scm_backtrace_with_highlights (highlights) +@deffnx {C Function} scm_backtrace () +Display a backtrace of the stack saved by the last error +to the current output port. When @var{highlights} is given, +it should be a list and all members of it are highligthed in +the backtrace. +@end deffn + +@deffn {Scheme Procedure} debug +Invoke the Guile debugger to explore the context of the last error. +@end deffn + + +@node Using Traps +@subsection Using Traps + +@deffn {Scheme Procedure} with-traps thunk +@deffnx {C Function} scm_with_traps (thunk) +Call @var{thunk} with traps enabled. +@end deffn + +@deffn {Scheme Procedure} debug-object? obj +@deffnx {C Function} scm_debug_object_p (obj) +Return @code{#t} if @var{obj} is a debug object. +@end deffn + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From 62ae95577a503e89114584ae8571b2b128d79ca5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 11 Aug 2006 16:21:14 +0000 Subject: [PATCH 018/116] * scheme-using.texi (Run To Frame Exit): Improved doc for finish. (Continue Execution): Improved doc for continue. (Using Guile in Emacs): Lots of new docs about the Emacs interface. * api-debug.texi (Low Level Trap Calls): New. (Using Traps): Removed, material incorporated into Low Level Trap Calls. (High Level Traps): New. (Breakpoints): New. * scheme-using.texi (Single Stepping): Improve doc for step and next. * api-debug.texi (Debug on Error): Note need to handling of errors in C. --- doc/ref/ChangeLog | 17 + doc/ref/api-debug.texi | 1265 ++++++++++++++++++++++++++++++++++++- doc/ref/scheme-using.texi | 783 ++++++++++++++++++++++- 3 files changed, 2057 insertions(+), 8 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 982871ee6..451c6f575 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,5 +1,22 @@ 2006-08-11 Neil Jerram + * scheme-using.texi (Run To Frame Exit): Improved doc for finish. + (Continue Execution): Improved doc for continue. + (Using Guile in Emacs): Lots of new docs about the Emacs + interface. + + * api-debug.texi (Low Level Trap Calls): New. + (Using Traps): Removed, material incorporated into Low Level Trap + Calls. + (High Level Traps): New. + (Breakpoints): New. + + * scheme-using.texi (Single Stepping): Improve doc for step and + next. + + * api-debug.texi (Debug on Error): Note need to handling of errors + in C. + * api-debug.texi (Debugging): New intro text. New subsection "Evaluation Model". Moved existing subsections "Capturing the Stack or Innermost Stack Frame", "Examining the Stack", "Examining diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 42527b7ec..6868ef211 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -17,7 +17,9 @@ infrastructure that builds on top of those calls. @menu * Evaluation Model:: Evaluation and the Scheme stack. * Debug on Error:: Debugging when an error occurs. -* Using Traps:: +* Low Level Trap Calls:: +* High Level Traps:: +* Breakpoints:: @end menu @node Evaluation Model @@ -380,9 +382,48 @@ the backtrace. Invoke the Guile debugger to explore the context of the last error. @end deffn +[Should also cover how to catch and debug errors from C, including +discussion of lazy/pre-unwind handlers.] -@node Using Traps -@subsection Using Traps + +@node Low Level Trap Calls +@subsection Low Level Trap Calls + +@cindex Low level trap calls +@cindex Evaluator trap calls +Guile's evaluator can be configured to call three user-specified +procedures at various points in its operation: an +@dfn{apply-frame-handler} procedure, an @dfn{enter-frame-handler} +procedure, and an @dfn{exit-frame-handler} procedure. These procedures, +and the circumstances under which the evaluator calls them, are +configured by the ``evaluator trap options'' interface (@pxref{Evaluator +trap options}), and by the @code{trace} and @code{breakpoints} fields of +the ``debug options'' interface (@pxref{Debugger options}). + +It is not necessary to understand the fine details of these low level +calls, and of the options which configure them, in order to use the +class-based trap interface effectively. @code{guile-debugging} takes +care of setting these options as required for whatever set of +installed trap objects the user specifies.@footnote{And consequently, +when using the class-based trap interface, users/applications should +@emph{not} modify these options themselves, to avoid interfering with +@code{guile-debugging}'s option settings.} It is useful, though, to +have a overall idea of how the evaluator works and when these low +level calls can happen, as follows. + +@cindex Frame entry +@cindex Frame exit +On the basis of this description, we can now specify the points where +low level trap calls may occur (subject to configuration). Namely, +whenever a new frame is added to the stack, because the evaluator is +about to begin a new evaluation or to perform a new application, and +whenever a frame is being removed from the stack because the +computation that it refers to has completed and is returning its +value@footnote{If this raises the question of how expressions with +no return value are handled, the answer is that all computations in +Guile return a value. Those that appear to have no return value do so +by using the special @code{*unspecified*} value, which the Guile REPL +avoids displaying to the user.} to its caller. @deffn {Scheme Procedure} with-traps thunk @deffnx {C Function} scm_with_traps (thunk) @@ -395,6 +436,1224 @@ Return @code{#t} if @var{obj} is a debug object. @end deffn +@node High Level Traps +@subsection High Level Traps + +@cindex Traps +@cindex Evaluator trap calls +@cindex Breakpoints +@cindex Trace +@cindex Tracing +@cindex Code coverage +@cindex Profiling +The low level C code of Guile's evaluator can be configured to call +out at key points to arbitrary user-specified code. In principle this +allows Scheme code to implement any model it chooses for examining the +evaluation stack as program execution proceeds, and for suspending +execution to be resumed later. Possible applications of this feature +include breakpoints, runtime tracing, code coverage, and profiling. + +@cindex Trap classes +@cindex Trap objects +Based on these low level trap calls, the enhancements described here +provide a much higher level, object-oriented interface for the +manipulation of traps. Different kinds of trap are represented as +GOOPS classes; for example, the @code{} class +describes traps that are triggered by invocation of a specified +procedure. A particular instance of a trap class --- or @dfn{trap +object} --- describes the condition under which a single trap will be +triggered, and what will happen then; for example, an instance of +@code{} whose @code{procedure} and @code{behaviour} +slots contain @code{my-factorial} and @code{debug-trap} would be a +trap that enters the command line debugger when the +@code{my-factorial} procedure is invoked. + +The following subsubsections describe all this in greater detail, for both +the user wanting to use traps, and the developer interested in +understanding how the interface hangs together. + + +@subsubsection A Quick Note on Terminology + +@cindex Trap terminology +It feels natural to use the word ``trap'' in some form for all levels +of the structure just described, so we need to be clear on the +terminology we use to describe each particular level. The terminology +used in this subsection is as follows. + +@itemize @bullet +@item +@cindex Evaluator trap calls +@cindex Low level trap calls +``Low level trap calls'', or ``low level traps'', are the calls made +directly from the C code of the Guile evaluator. + +@item +@cindex Trap classes +``Trap classes'' are self-explanatory. + +@item +@cindex Trap objects +``Trap objects'', ``trap instances'', or just ``traps'', are instances +of a trap class, and each describe a single logical trap condition +plus behaviour as specified by the user of this interface. +@end itemize + +A good example of when it is important to be clear, is when we talk +below of behaviours that should only happen once per low level trap. +A single low level trap call will typically map onto the processing of +several trap objects, so ``once per low level trap'' is significantly +different from ``once per trap''. + + +@menu +* How to Set a Trap:: +* Specifying Trap Behaviour:: +* Trap Context:: +* Tracing Examples:: +* Tracing Configuration:: +* Tracing and (ice-9 debug):: +* Traps Installing More Traps:: +* Common Trap Options:: +* Procedure Traps:: +* Exit Traps:: +* Entry Traps:: +* Apply Traps:: +* Step Traps:: +* Source Traps:: +* Location Traps:: +* Trap Shorthands:: +* Trap Utilities:: +@end menu + + +@node How to Set a Trap +@subsubsection How to Set a Trap + +@cindex Setting traps +@cindex Installing and uninstalling traps +Setting a trap is done in two parts. First the trap is defined by +creating an instance of the appropriate trap class, with slot values +specifying the condition under which the trap will fire and the action +to take when it fires. Secondly the trap object thus created must be +@dfn{installed}. + +To make this immediately concrete, here is an example that sets a trap +to fire on the next application of the @code{facti} procedure, and to +handle the trap by entering the command line debugger. + +@lisp +(install-trap (make + #:procedure facti + #:single-shot #t + #:behaviour debug-trap)) +@end lisp + +@noindent +Briefly, the elements of this incantation are as follows. (All of +these are described more fully in the following subsubsections.) + +@itemize @bullet +@item +@code{} is the trap class for trapping on invocation +of a specific procedure. + +@item +@code{#:procedure facti} says that the specific procedure to trap on for this +trap object is @code{facti}. + +@item +@code{#:single-shot #t} says that this trap should only fire on the +@emph{next} invocation of @code{facti}, not on all future invocations +(which is the default if the @code{#:single-shot} option is not +specified). + +@item +@code{#:behaviour debug-trap} says that the trap infrastructure should +call the procedure @code{debug-trap} when this trap fires. + +@item +Finally, the @code{install-trap} call installs the trap immediately. +@end itemize + +@noindent +It is of course possible for the user to define more convenient +shorthands for setting common kinds of traps. @xref{Trap Shorthands}, +for some examples. + +The ability to install, uninstall and reinstall a trap without losing +its definition is @code{guile-debugging}'s equivalent of the +disable/enable commands provided by debuggers like GDB. + +@deffn {Generic Function} install-trap trap +Install the trap object @var{trap}, so that its behaviour will be +executed when the conditions for the trap firing are met. +@end deffn + +@deffn {Generic Function} uninstall-trap trap +Uninstall the trap object @var{trap}, so that its behaviour will +@emph{not} be executed even if the conditions for the trap firing are +met. +@end deffn + + +@node Specifying Trap Behaviour +@subsubsection Specifying Trap Behaviour + +@cindex Trap behaviour +@code{guile-debugging} provides several ``out-of-the-box'' behaviours +for common needs. All of the following can be used directly as the +value of the @code{#:behaviour} option when creating a trap object. + +@deffn {Procedure} debug-trap trap-context +Enter Guile's command line debugger to explore the stack at +@var{trap-context}, and to single-step or continue program execution +from that point. +@end deffn + +@deffn {Procedure} gds-debug-trap trap-context +Use the GDS debugging interface, which displays the stack and +corresponding source code via Emacs, to explore the stack at +@var{trap-context} and to single-step or continue program execution +from that point. +@end deffn + +@cindex Trace +@cindex Tracing +@deffn {Procedure} trace-trap trap-context +Display trace information to summarize the current @var{trap-context}. +@end deffn + +@deffn {Procedure} trace-at-exit trap-context +Install a further trap to cause the return value of the application or +evaluation just starting (as described by @var{trap-context}) to be +traced using @code{trace-trap}, when this application or evaluation +completes. The extra trap is automatically uninstalled after the +return value has been traced. +@end deffn + +@deffn {Procedure} trace-until-exit trap-context +Install a further trap so that every step that the evaluator performs +as part of the application or evaluation just starting (as described +by @var{trap-context}) is traced using @code{trace-trap}. The extra +trap is automatically uninstalled when the application or evaluation +is complete. @code{trace-until-exit} can be very useful as a first +step when all you know is that there is a bug ``somewhere in XXX or in +something that XXX calls''. +@end deffn + +@noindent +@code{debug-trap} and @code{gds-debug-trap} are provided by the modules +@code{(ice-9 debugger)} and @code{(ice-9 gds-client)} respectively, and +their behaviours are fairly self-explanatory. For more information on +the operation of the GDS interface via Emacs, see @ref{Using Guile in +Emacs}. The tracing behaviours are explained more fully below. + +@cindex Trap context +More generally, the @dfn{behaviour} specified for a trap can be any +procedure that expects to be called with one @dfn{trap context} +argument. A trivial example would be: + +@lisp +(define (report-stack-depth trap-context) + (display "Stack depth at the trap is: ") + (display (tc:depth trap-context)) + (newline)) +@end lisp + + +@node Trap Context +@subsubsection Trap Context + +The @dfn{trap context} is an object that caches information about the +low level trap call and the stack at the point of the trap, and is +passed as the only argument to all behaviour procedures. The +information in the trap context can be accessed through the procedures +beginning @code{tc:} that are exported by the @code{(ice-9 debugging +traps)} module@footnote{Plus of course any procedures that build on +these, such as the @code{trace/@dots{}} procedures exported by +@code{(ice-9 debugging trace)} (@pxref{Tracing Configuration}).}; the +most useful of these are as follows. + +@deffn {Generic Function} tc:type trap-context +Indicates the type of the low level trap by returning one of the +keywords @code{#:application}, @code{#:evaluation}, @code{#:return} or +@code{#:error}. +@end deffn + +@deffn {Generic Function} tc:return-value trap-context +When @code{tc:type} gives @code{#:return}, this provides the value +that is being returned. +@end deffn + +@deffn {Generic Function} tc:stack trap-context +Provides the stack at the point of the trap (as computed by +@code{make-stack}, but cached so that the lengthy @code{make-stack} +operation is not performed more than once for the same low level +trap). +@end deffn + +@deffn {Generic Function} tc:frame trap-context +The innermost frame of the stack at the point of the trap. +@end deffn + +@deffn {Generic Function} tc:depth trap-context +The number of frames (including tail recursive non-real frames) in the +stack at the point of the trap. +@end deffn + +@deffn {Generic Function} tc:real-depth trap-context +The number of real frames (that is, excluding the non-real frames that +describe tail recursive calls) in the stack at the point of the trap. +@end deffn + + +@node Tracing Examples +@subsubsection Tracing Examples + +The following examples show what tracing is and the kind of output that +it generates. In the first example, we define a recursive function for +reversing a list, then watch the effect of the recursive calls by +tracing each call and return value. + +@lisp +guile> (define (rev ls) + (if (null? ls) + ls + (append (rev (cdr ls)) + (list (car ls))))) +guile> (use-modules (ice-9 debugging traps) (ice-9 debugging trace)) +guile> (define t1 (make + #:procedure rev + #:behaviour (list trace-trap + trace-at-exit))) +guile> (install-trap t1) +guile> (rev '(a b c)) +| 2: [rev (a b c)] +| 3: [rev (b c)] +| 4: [rev (c)] +| 5: [rev ()] +| 5: =>() +| 4: =>(c) +| 3: =>(c b) +| 2: =>(c b a) +(c b a) +@end lisp + +@noindent +The number before the colon in this output (which follows @code{(ice-9 +debugging trace)}'s default output format) is the number of real frames +on the stack. The fact that this number increases for each recursive +call confirms that the implementation above of @code{rev} is not +tail-recursive. + +In the next example, we probe the @emph{internal} workings of +@code{rev} in more detail by using the @code{trace-until-exit} +behaviour. + +@lisp +guile> (uninstall-trap t1) +guile> (define t2 (make + #:procedure rev + #:behaviour (list trace-trap + trace-until-exit))) +guile> (install-trap t2) +guile> (rev '(a b)) +| 2: [rev (a b)] +| 2: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls)))) +| 3: (null? ls) +| 3: [null? (a b)] +| 3: =>#f +| 2: (append (rev (cdr ls)) (list (car ls))) +| 3: (rev (cdr ls)) +| 4: (cdr ls) +| 4: [cdr (a b)] +| 4: =>(b) +| 3: [rev (b)] +| 3: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls)))) +| 4: (null? ls) +| 4: [null? (b)] +| 4: =>#f +| 3: (append (rev (cdr ls)) (list (car ls))) +| 4: (rev (cdr ls)) +| 5: (cdr ls) +| 5: [cdr (b)] +| 5: =>() +| 4: [rev ()] +| 4: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls)))) +| 5: (null? ls) +| 5: [null? ()] +| 5: =>#t +| 4: (list (car ls)) +| 5: (car ls) +| 5: [car (b)] +| 5: =>b +| 4: [list b] +| 4: =>(b) +| 3: [append () (b)] +| 3: =>(b) +| 3: (list (car ls)) +| 4: (car ls) +| 4: [car (a b)] +| 4: =>a +| 3: [list a] +| 3: =>(a) +| 2: [append (b) (a)] +| 2: =>(b a) +(b a) +@end lisp + +@noindent +The output in this case shows every step that the evaluator performs +in evaluating @code{(rev '(a b))}. + + +@node Tracing Configuration +@subsubsection Tracing Configuration + +The detail of what gets printed in each trace line, and the port to +which tracing is written, can be configured by the procedures +@code{set-trace-layout} and @code{trace-port}, both exported by the +@code{(ice-9 debugging trace)} module. + +@deffn {Procedure with Setter} trace-port +Get or set the port to which tracing is printed. The default is the +value of @code{(current-output-port)} when the @code{(ice-9 debugging +trace)} module is first loaded. +@end deffn + +@deffn {Procedure} set-trace-layout format-string . arg-procs +Layout each trace line using @var{format-string} and @var{arg-procs}. +For each trace line, the list of values to be printed is obtained by +calling all the @var{arg-procs}, passing the trap context as the only +parameter to each one. This list of values is then formatted using +the specified @var{format-string}. +@end deffn + +@noindent +The @code{(ice-9 debugging trace)} module exports a set of arg-proc +procedures to cover most common needs, with names beginning +@code{trace/}. These are all implemented on top of the @code{tc:} trap +context accessor procedures documented in @ref{Trap Context}, and if any +trace output not provided by the following is needed, it should be +possible to implement based on a combination of the @code{tc:} +procedures. + +@deffn {Procedure} trace/pid trap-context +An arg-proc that returns the current process ID. +@end deffn + +@deffn {Procedure} trace/stack-id trap-context +An arg-proc that returns the stack ID of the stack in which the +current trap occurred. +@end deffn + +@deffn {Procedure} trace/stack-depth trap-context +An arg-proc that returns the length (including non-real frames) of the +stack at the point of the current trap. +@end deffn + +@deffn {Procedure} trace/stack-real-depth trap-context +An arg-proc that returns the length excluding non-real frames of the +stack at the point of the current trap. +@end deffn + +@deffn {Procedure} trace/stack trap-context +An arg-proc that returns a string summarizing stack information. This +string includes the stack ID, real depth, and count of additional +non-real frames, with the format @code{"~a:~a+~a"}. +@end deffn + +@deffn {Procedure} trace/source-file-name trap-context +An arg-proc that returns the name of the source file for the innermost +stack frame, or an empty string if source is not available for the +innermost frame. +@end deffn + +@deffn {Procedure} trace/source-line trap-context +An arg-proc that returns the line number of the source code for the +innermost stack frame, or zero if source is not available for the +innermost frame. +@end deffn + +@deffn {Procedure} trace/source-column trap-context +An arg-proc that returns the column number of the start of the source +code for the innermost stack frame, or zero if source is not available +for the innermost frame. +@end deffn + +@deffn {Procedure} trace/source trap-context +An arg-proc that returns the source location for the innermost stack +frame. This is a string composed of file name, line and column number +with the format @code{"~a:~a:~a"}, or an empty string if source is not +available for the innermost frame. +@end deffn + +@deffn {Procedure} trace/type trap-context +An arg-proc that returns a three letter abbreviation indicating the +type of the current trap: @code{"APP"} for an application frame, +@code{"EVA"} for an evaluation, @code{"RET"} for an exit trap, or +@code{"ERR"} for an error (pseudo-)trap. +@end deffn + +@deffn {Procedure} trace/real? trap-context +An arg-proc that returns @code{" "} if the innermost stack frame is a +real frame, or @code{"t"} if it is not. +@end deffn + +@deffn {Procedure} trace/info trap-context +An arg-proc that returns a string describing the expression being +evaluated, application being performed, or return value, according to +the current trap type. +@end deffn + +@noindent +@code{trace/stack-depth} and @code{trace/stack-real-depth} are identical +to the trap context methods @code{tc:depth} and @code{tc:real-depth} +described before (@pxref{Trap Context}), but renamed here for +convenience. + +The default trace layout, as exhibited by the examples of the previous +subsubsubsection, is set by this line of code from the @code{(ice-9 debugging +traps)} module: + +@lisp +(set-trace-layout "|~3@@a: ~a\n" trace/stack-real-depth trace/info) +@end lisp + +@noindent +If we rerun the first of those examples, but with trace layout +configured to show source location and trap type in addition, the +output looks like this: + +@lisp +guile> (set-trace-layout "| ~25a ~3@@a: ~a ~a\n" + trace/source + trace/stack-real-depth + trace/type + trace/info) +guile> (rev '(a b c)) +| standard input:29:0 2: APP [rev (a b c)] +| standard input:4:21 3: APP [rev (b c)] +| standard input:4:21 4: APP [rev (c)] +| standard input:4:21 5: APP [rev ()] +| standard input:2:9 5: RET =>() +| standard input:4:13 4: RET =>(c) +| standard input:4:13 3: RET =>(c b) +| standard input:4:13 2: RET =>(c b a) +(c b a) +@end lisp + + +@node Tracing and (ice-9 debug) +@subsubsection Tracing and (ice-9 debug) + +The @code{(ice-9 debug)} module of the core Guile distribution +provides a tracing facility that is roughly similar to that described +here, but there are important differences. + +@itemize @bullet +@item +The @code{(ice-9 debug)} trace gives a nice pictorial view of changes +in stack depth, by using indentation like this: + +@lisp +[fact1 4] +| [fact1 3] +| | [fact1 2] +| | | [fact1 1] +| | | | [fact1 0] +| | | | 1 +| | | 1 +| | 2 +| 6 +24 +@end lisp + +However its output can @emph{only} show the information seen here, +which corresponds to @code{guile-debugging}'s @code{trace/info} +procedure; it cannot be configured to show other pieces of information +about the trap context in the way that @code{guile-debugging}'s trace +feature can. + +@item +The @code{(ice-9 debug)} trace only allows the tracing of procedure +applications and their return values, whereas @code{guile-debugging}'s +trace allows any kind of trap to be traced. + +It's interesting to note that @code{(ice-9 debug)}'s restriction here, +which might initially appear to be just a straightforward consequence +of its implementation, is also somewhat dictated by its pictorial +display. The use of indentation in the output relies on hooking into +the low level trap calls in such a way that the trapped application +entries and exits exactly balance each other. +@code{guile-debugging}'s more general traps interface allows traps to +be installed such that entry and exit traps don't necessarily balance, +which means that, in general, indentation diagrams like the one above +don't work. +@end itemize + +It isn't currently possible to use both @code{(ice-9 debug)} trace and +@code{guile-debugging} in the same Guile session, because their settings +of the low level trap options conflict with each other. (It should be +possible to fix this, by modifying @code{(ice-9 debug)} to use +@code{guile-debugging}'s trap installation interface, but only if and +when @code{guile-debugging} is integrated into the core Guile +distribution.) + + +@node Traps Installing More Traps +@subsubsection Traps Installing More Traps + +Sometimes it is desirable for the behaviour at one trap to install +further traps. In other words, the behaviour is something like +``Don't do much right now, but set things up to stop after two or +three more steps'', or ``@dots{} when this frame completes''. This is +absolutely fine. For example, it is easy to code a generic ``do +so-and-so when the current frame exits'' procedure, which can be used +wherever a trap context is available, as follows. + +@lisp +(define (at-exit trap-context behaviour) + (install-trap (make + #:depth (tc:depth trap-context) + #:single-shot #t + #:behaviour behaviour))) +@end lisp + +To continue and pin down the example, this could then be used as part +of a behaviour whose purpose was to measure the accumulated time spent +in and below a specified procedure. + +@lisp +(define calls 0) +(define total 0) + +(define accumulate-time + (lambda (trap-context) + (set! calls (+ calls 1)) + (let ((entry (current-time))) + (at-exit trap-context + (lambda (ignored) + (set! total + (+ total (- (current-time) + entry)))))))) + +(install-trap (make + #:procedure my-proc + #:behaviour accumulate-time)) +@end lisp + + +@node Common Trap Options +@subsubsection Common Trap Options + +When creating any kind of trap object, settings for the trap being +created are specified as options on the @code{make} call using syntax +like this: + +@lisp +(make <@var{trap-class}> + #:@var{option-keyword} @var{setting} + @dots{}) +@end lisp + +The following common options are provided by the base class +@code{}, and so can be specified for any kind of trap. + +@deffn {Class} +Base class for trap objects. +@end deffn + +@deffn {Trap Option} #:condition thunk +If not @code{#f}, this is a thunk which is called when the trap fires, +to determine whether trap processing should proceed any further. If +the thunk returns @code{#f}, the trap is basically suppressed. +Otherwise processing continues normally. (Default value @code{#f}.) +@end deffn + +@deffn {Trap Option} #:skip-count count +A count of valid (after @code{#:condition} processing) firings of this +trap to skip. (Default value 0.) +@end deffn + +@deffn {Trap Option} #:single-shot boolean +If not @code{#f}, this indicates that the trap should be automatically +uninstalled after it has successfully fired (after @code{#:condition} +and @code{#:skip-count} processing) for the first time. (Default +value @code{#f}.) +@end deffn + +@deffn {Trap Option} #:behaviour behaviour-proc +A trap behaviour procedure --- as discussed in the preceding subsubsection +--- or a list of such procedures, in which case each procedure is +called in turn when the trap fires. (Default value @code{'()}.) +@end deffn + +@deffn {Trap Option} #:repeat-identical-behaviour boolean +Normally, if multiple trap objects are triggered by the same low level +trap, and they request the same behaviour, it's only actually useful +to do that behaviour once (per low level trap); so by default multiple +requests for the same behaviour are coalesced. If this option is set +other than @code{#f}, the contents of the @code{#:behaviour} option +are uniquified so that they avoid being coalesced in this way. +(Default value @code{#f}.) +@end deffn + + +@node Procedure Traps +@subsubsection Procedure Traps + +The @code{} class implements traps that are triggered +upon application of a specified procedure. Instances of this class +should use the @code{#:procedure} option to specify the procedure to +trap on. + +@deffn {Class} +Class for traps triggered by application of a specified procedure. +@end deffn + +@deffn {Trap Option} #:procedure procedure +Specifies the procedure to trap on. +@end deffn + +@noindent +Example: + +@lisp +(install-trap (make + #:procedure my-proc + #:behaviour (list trace-trap + trace-until-exit))) +@end lisp + + +@node Exit Traps +@subsubsection Exit Traps + +The @code{} class implements traps that are triggered upon +stack frame exit past a specified stack depth. Instances of this +class should use the @code{#:depth} option to specify the target stack +depth. + +@deffn {Class} +Class for traps triggered by exit past a specified stack depth. +@end deffn + +@deffn {Trap Option} #:depth depth +Specifies the reference depth for the trap. +@end deffn + +@noindent +Example: + +@lisp +(define (trace-at-exit trap-context) + (install-trap (make + #:depth (tc:depth trap-context) + #:single-shot #t + #:behaviour trace-trap))) +@end lisp + +@noindent +(This is the actual definition of the @code{trace-at-exit} behaviour.) + + +@node Entry Traps +@subsubsection Entry Traps + +The @code{} class implements traps that are triggered upon +any stack frame entry. No further parameters are needed to specify an +instance of this class, so there are no class-specific trap options. +Note that it remains possible to use the common trap options +(@pxref{Common Trap Options}), for example to set a trap for the +@var{n}th next frame entry. + +@deffn {Class} +Class for traps triggered by any stack frame entry. +@end deffn + +@noindent +Example: + +@lisp +(install-trap (make + #:skip-count 5 + #:behaviour gds-debug-trap)) +@end lisp + + +@node Apply Traps +@subsubsection Apply Traps + +The @code{} class implements traps that are triggered upon +any procedure application. No further parameters are needed to +specify an instance of this class, so there are no class-specific trap +options. Note that it remains possible to use the common trap options +(@pxref{Common Trap Options}), for example to set a trap for the next +application where some condition is true. + +@deffn {Class} +Class for traps triggered by any procedure application. +@end deffn + +@noindent +Example: + +@lisp +(install-trap (make + #:condition my-condition + #:behaviour gds-debug-trap)) +@end lisp + + +@node Step Traps +@subsubsection Step Traps + +The @code{} class implements traps that do single-stepping +through a program's execution. They come in two flavours, with and +without a specified file name. If a file name is specified, the trap +is triggered by the next evaluation, application or frame exit +pertaining to source code from the specified file. If a file name is +not specified, the trap is triggered by the next evaluation, +application or frame exit from any file (or for code whose source +location was not recorded), in other words by the next evaluator step +of any kind. + +The design goal of the @code{} class is to match what a +user would intuitively think of as single-stepping through their code, +either through code in general (roughly corresponding to GDB's +@code{step} command, for example), or through code from a particular +source file (roughly corresponding to GDB's @code{next}). Therefore +if you are using @code{guile-debugging} to single-step through code +and finding its behaviour counter-intuitive, please let me know so +that I can improve it. + +The implementation and options of the @code{} class are +complicated by the fact that it is unreliable to determine whether a +low level frame exit trap is applicable to a specified file by +examining the details of the reported frame. This is a consequence of +tail recursion, which has the effect that many frames can be removed +from the stack at once, with only the outermost frame being reported +by the low level trap call. The effects of this on the +@code{} class are such as to require the introduction of +the strange-looking @code{#:exit-depth} option, for the following +reasons. + +@itemize @bullet +@item +When stopped at the start of an application or evaluation frame, and +it is desired to continue execution until the next ``step'' in the same +source file, that next step could be the start of a nested application +or evaluation frame, or --- if the procedure definition is in a +different file, for example --- it could be the exit from the current +frame. + +@item +Because of the effects of tail recursion noted above, the current +frame exit possibility must be expressed as frame exit past a +specified stack depth. When an instance of the @code{} +class is installed from the context of an application or evaluation +frame entry, the @code{#:exit-depth} option should be used to specify +this stack depth. + +@item +When stopped at a frame exit, on the other hand, we know that the next +step must be an application or evaluation frame entry. In this +context the @code{#:exit-depth} option is not needed and should be +omitted or set to @code{#f}. +@end itemize + +@noindent +When a step trap is installed without @code{#:single-shot #t}, such +that it keeps firing, the @code{} code automatically +updates its idea of the @code{#:exit-depth} setting each time, so that +the trap always fires correctly for the following step. + +@deffn {Class} +Class for single-stepping traps. +@end deffn + +@deffn {Trap Option} #:file-name name +If not @code{#f}, this is a string containing the name of a source +file, and restricts the step trap to evaluation steps within that +source file. (Default value @code{#f}.) +@end deffn + +@deffn {Trap Option} #:exit-depth depth +If not @code{#f}, this is a positive integer implying that the next +step may be frame exit past the stack depth @var{depth}. See the +discussion above for more details. (Default value @code{#f}.) +@end deffn + +@noindent +Example: + +@lisp +(install-trap (make + #:file-name (frame-file-name + (stack-ref stack index)) + #:exit-depth (- (stack-length stack) + (stack-ref stack index)) + #:single-shot #t + #:behaviour debug-trap)) +@end lisp + + +@node Source Traps +@subsubsection Source Traps + +The @code{} class implements traps that are attached to a +precise source code expression, as read by the reader, and which fire +each time that that expression is evaluated. These traps use a low +level Guile feature which can mark individual expressions for +trapping, and are relatively efficient. But it can be tricky to get +at the source expression in the first place, and these traps are +liable to become irrelevant if the procedure containing the expression +is reevaluated; these issues are discussed further below. + +@deffn {Class} +Class for traps triggered by evaluation of a specific Scheme +expression. +@end deffn + +@deffn {Trap Option} #:expression expr +Specifies the Scheme expression to trap on. +@end deffn + +@noindent +Example: + +@lisp +(display "Enter an expression: ") +(let ((x (read))) + (install-trap (make + #:expression x + #:behaviour (list trace-trap + trace-at-exit))) + (primitive-eval x)) +@print{} +Enter an expression: (+ 1 2 3 4 5 6) +| 3: (+ 1 2 3 4 5 6) +| 3: =>21 +21 +@end lisp + +The key point here is that the expression specified by the +@code{#:expression} option must be @emph{exactly} (i.e. @code{eq?} to) +what is going to be evaluated later. It doesn't work, for example, to +say @code{#:expression '(+ x 3)}, with the expectation that the trap +will fire whenever evaluating any expression @code{(+ x 3)}. + +The @code{trap-here} macro can be used in source code to create and +install a source trap correctly. Take for example the factorial +function defined in the @code{(ice-9 debugging example-fns)} module: + +@lisp +(define (fact1 n) + (if (= n 0) + 1 + (* n (fact1 (- n 1))))) +@end lisp + +@noindent +To set a source trap on a particular expression --- let's say the +expression @code{(= n 0)} --- edit the code so that the expression is +enclosed in a @code{trap-here} macro call like this: + +@lisp +(define (fact1 n) + (if (trap-here (= n 0) #:behaviour debug-trap) + 1 + (* n (fact1 (- n 1))))) +@end lisp + +@deffn {Macro} trap-here expression . trap-options +Install a source trap with options @var{trap-options} on +@var{expression}, then return with the whole call transformed to +@code{(begin @var{expression})}. +@end deffn + +Note that if the @code{trap-here} incantation is removed, and +@code{fact1} then redefined by reloading its source file, the effect +of the source trap is lost, because the text ``(= n 0)'' is read again +from scratch and becomes a new expression @code{(= n 0)} which does +not have the ``trap here'' mark on it. + +If the semantics and setting of source traps seem unwieldy, location +traps may meet your need more closely; these are described in the +following subsubsection. + + +@node Location Traps +@subsubsection Location Traps + +The @code{} class implements traps that are triggered +by evaluation of code at a specific source location or within a +specified range of source locations. When compared with source traps, +they are easier to set, and do not become irrelevant when the relevant +code is reloaded; but unfortunately they are considerably less +efficient, as they require running some ``are we in the right place +for a trap'' code on every low level frame entry trap call. + +@deffn {Class} +Class for traps triggered by evaluation of code at a specific source +location or in a specified range of source locations. +@end deffn + +@deffn {Trap Option} #:file-regexp regexp +A regular expression specifying the filenames that will match this +trap. This option must be specified when creating a location trap. +@end deffn + +@deffn {Trap Option} #:line line-spec +If specified, @var{line-spec} describes either a single line, in which +case it is a single integer, or a range of lines, in which case it is +a pair of the form @code{(@var{min-line} . @var{max-line})}. All line +numbers are 0-based, and the range form is inclusive-inclusive. If +@code{#f} or not specified, the trap is not restricted by line number. +(Default value @code{#f}.) +@end deffn + +@deffn {Trap Option} #:column column-spec +If specified, @var{column-spec} describes either a single column, in +which case it is a single integer, or a range of columns, in which +case it is a pair of the form @code{(@var{min-column} +. @var{max-column})}. All column numbers are 0-based, and the range +form is inclusive-inclusive. If @code{#f} or not specified, the trap +is not restricted by column number. (Default value @code{#f}.) +@end deffn + +@noindent +Example: + +@lisp +(install-trap (make + #:file-regexp "example-fns.scm" + #:line '(11 . 13) + #:behaviour gds-debug-trap)) +@end lisp + + +@node Trap Shorthands +@subsubsection Trap Shorthands + +If the code described in the preceding subsubsections for creating and +manipulating traps seems a little long-winded, it is of course +possible to define more convenient shorthand forms for typical usage +patterns. For example, my own @file{.guile} file contains the +following definitions for setting breakpoints and for tracing. + +@lisp +(define (break! proc) + (install-trap (make + #:procedure proc + #:behaviour gds-debug-trap))) + +(define (trace! proc) + (install-trap (make + #:procedure proc + #:behaviour (list trace-trap + trace-at-exit)))) + +(define (trace-subtree! proc) + (install-trap (make + #:procedure proc + #:behaviour (list trace-trap + trace-until-exit)))) +@end lisp + +Definitions like these are not provided out-of-the-box by +@code{guile-debugging}, because different users will have different +ideas about what their default debugger should be, or, for example, +which of the common trap options (@pxref{Common Trap Options}) it +might be useful to expose through such shorthand procedures. + + +@node Trap Utilities +@subsubsection Trap Utilities + +@code{list-traps} can be used to print a description of all known trap +objects. This uses a weak value hash table, keyed by a trap index +number. Each trap object has its index number assigned, and is added +to the hash table, when it is created by a @code{make @var{trap-class} +@dots{}} call. When a trap object is GC'd, it is automatically +removed from the hash table, and so no longer appears in the output +from @code{list-traps}. + +@deffn {Variable} all-traps +Weak value hash table containing all known trap objects. +@end deffn + +@deffn {Procedure} list-traps +Print a description of all known trap objects. +@end deffn + +The following example shows a single trap that traces applications of +the procedure @code{facti}. + +@lisp +guile> (list-traps) +#< 100d2e30> is an instance of class +Slots are: + number = 1 + installed = #t + condition = #f + skip-count = 0 + single-shot = #f + behaviour = (#) + repeat-identical-behaviour = #f + procedure = # +@end lisp + +When @code{all-traps} or @code{list-traps} reveals a trap that you +want to modify but no longer have a reference to, you can retrieve the +trap object by calling @code{get-trap} with the trap's number. For +example, here's how you could change the behaviour of the trap listed +just above. + +@lisp +(slot-set! (get-trap 1) 'behaviour (list debug-trap)) +@end lisp + +@deffn {Procedure} get-trap number +Return the trap object with the specified @var{number}, or @code{#f} +if there isn't one. +@end deffn + + +@node Breakpoints +@subsection Breakpoints + +While they are an important piece of infrastructure, and directly +usable in some scenarios, traps are still too low level to meet some +of the requirements of interactive development. + +For example, in my experience a common scenario is that a newly +written procedure is not working properly, and so you'd like to be +able to step or trace through its code to find out why. Ideally this +should be possible from the IDE and without having to modify the +source code. There are two problems with using traps directly in this +scenario. + +@enumerate +@item +They are too detailed: constructing and installing a trap requires you +to say what kind of trap you want and to specify fairly low level +options for it, whereas what you really want is just to say ``break +here using the most efficient means possible.'' + +@item +The most efficient kinds of trap --- that is, @code{} +and @code{} --- can only be specified and installed +@emph{after} the code that they refer to has been loaded. This is an +inconvenient detail for the user to deal with, and in some +applications it might be very difficult to insert an instruction to +install the required trap in between when the code is loaded and when +the procedure concerned is first called. It would be better to be +able to tell Guile about the requirement upfront, and for it to deal +with installing the trap when possible. +@end enumerate + +We solve these problems by introducing breakpoints. A breakpoint is +something which says ``I want to break at location X, or in procedure +P --- just make it happen'', and can be set regardless of whether the +relevant code has already been loaded. Breakpoints use traps to do +their work, but that is a detail that the user will usually not have +to care about. + +Breakpoints are provided by a combination of Scheme code in the client +program, and facilities for setting and managing breakpoints in the +GDS front end. On the Scheme side the entry points are as follows. + +@deffn {Getter with Setter} default-breakpoint-behaviour +A ``getter with setter'' procedure that can be used to get or set the +default behaviour for new breakpoints. When a new default behaviour +is set, by calling + +@lisp +(set! (default-breakpoint-behaviour) @var{new-behaviour}) +@end lisp + +@noindent +the new behaviour applies to all following @code{break-in} and +@code{break-at} calls, but does not affect breakpoints which have +already been set. @var{new-behaviour} should be a behaviour procedure +with the signature + +@lisp +(lambda (trap-context) @dots{}) +@end lisp + +@noindent +as described in @ref{Specifying Trap Behaviour}. +@end deffn + +@deffn {Procedure} break-in procedure-name [module-or-file-name] [options] +Set a breakpoint on entry to the procedure named @var{procedure-name}, +which should be a symbol. @var{module-or-file-name}, if present, is +the name of the module (a list of symbols) or file (a string) which +includes the target procedure. If @var{module-or-file-name} is +absent, the target procedure is assumed to be in the current module. + +The available options are any of the common trap options +(@pxref{Common Trap Options}), and are used when creating the +breakpoint's underlying traps. The default breakpoint behaviour +(given earlier to @code{default-breakpoint-behaviour}) is only used if +these options do not include @code{#:behaviour @var{behaviour}}. +@end deffn + +@deffn {Procedure} break-at file-name line column [options] +Set a breakpoint on the expression in file @var{file-name} whose +opening parenthesis is on line @var{line} at column @var{column}. +@var{line} and @var{column} both count from 0 (not from 1). + +The available options are any of the common trap options +(@pxref{Common Trap Options}), and are used when creating the +breakpoint's underlying traps. The default breakpoint behaviour +(given earlier to @code{default-breakpoint-behaviour}) is only used if +these options do not include @code{#:behaviour @var{behaviour}}. +@end deffn + +@deffn {Procedure} set-gds-breakpoints +Ask the GDS front end for a list of breakpoints to set, and set these +using @code{break-in} and @code{break-at} as appropriate. +@end deffn + +@code{default-breakpoint-behaviour}, @code{break-in} and +@code{break-at} allow an application's startup code to specify any +breakpoints that it needs inline in that code. For example, to trace +calls and arguments to a group of procedures to handle HTTP requests, +one might write something like this: + +@lisp +(use-modules (ice-9 debugging breakpoints) + (ice-9 debugging trace)) + +(set! (default-breakpoint-behaviour) trace-trap) + +(break-in 'handle-http-request '(web http)) +(break-in 'read-http-request '(web http)) +(break-in 'decode-form-data '(web http)) +(break-in 'send-http-response '(web http)) +@end lisp + +@code{set-gds-breakpoints} can be used as well as or instead of the +above, and is intended to be the most practical option if you are +using GDS. The idea is that you only need to add this one call +somewhere in your application's startup code, like this: + +@lisp +(use-modules (ice-9 gds-client)) +(set-gds-breakpoints) +@end lisp + +@noindent +and then all the details of the breakpoints that you want to set can +be managed through GDS. For the details of GDS's breakpoints +interface, see @ref{Setting and Managing Breakpoints}. + + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index b596ce50a..f7f49a45d 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -309,11 +309,16 @@ however it may be continued over multiple lines. [to be completed] @deffn {Debugger Command} step [n] -Continue until entry to @var{n}th next frame. +Tell the debugged program to do @var{n} single-steps to the next frame +entry or exit of any kind. @var{n} defaults to 1. @end deffn @deffn {Debugger Command} next [n] -Continue until entry to @var{n}th next frame in same file. +Tell the debugged program to do @var{n} single-steps to the entry or +exit of a frame whose code comes from the same source file as the +selected stack frame. (See @ref{Step Traps} for the details of how +this works.) If the selected stack frame has no source, the effect of +this command is the same as of @code{step}. @var{n} defaults to 1. @end deffn @@ -323,8 +328,9 @@ Continue until entry to @var{n}th next frame in same file. [to be completed] @deffn {Debugger Command} finish -Continue until evaluation of the current frame is complete, and -print the result obtained. +Tell the program being debugged to continue running until the +completion of the selected stack frame, and at that time to print the +result and reenter the command line debugger. @end deffn @deffn {Debugger Command} trace-finish @@ -338,7 +344,7 @@ Trace until evaluation of the current frame is complete. [to be completed] @deffn {Debugger Command} continue -Continue program execution. +Tell the program being debugged to continue running. @end deffn @@ -405,7 +411,774 @@ can also run a program until it hits a breakpoint, then examine, modify and reevaluate some of the relevant code, and then tell the program to continue running. +@ignore +GDS is a user interface for working on Guile Scheme programs in Emacs. +It aims to provide whatever facilities are needed to make the writing, +debugging and maintenance of Scheme code in Emacs as fluid and +productive as possible. These facilities currently include the +following. +@table @asis +@item Displaying the Scheme stack +When running Scheme code hits a trap or throws an exception, GDS can +display the stack at the point of the trap or exception. The +presentation makes it very easy to move up and down the stack, showing +whenever possible the source code for each frame in another Emacs +buffer, and allowing you to evaluate test expressions in the context of +the selected frame. + +@item Continuing execution from a trap +When GDS is showing the stack for code that has hit a trap, it also +allows you to control how execution continues from that point. For +example you can select a stack frame and tell Guile to run until that +frame completes, at which point GDS will display the frame's return +value. + +@item Evaluating Scheme code +GDS allows you to select a region of a Scheme buffer and send it to +Guile for evaluation, or to enter a Scheme expression to be evaluated in +the Emacs minibuffer. In both cases the evaluation results are popped +up in a temporary Emacs window. + +@item Setting breakpoints in Scheme code +GDS makes it easy to set breakpoints in Scheme code from within Emacs. +Deep down this uses the traps described in previous chapters, but GDS +makes the practicalities as simple as typing @kbd{C-x @key{SPC}}. When +a GDS breakpoint is hit, the stack at that point is popped up in Emacs. +GDS also remembers your breakpoints between editing sessions, so you +don't have to set them again when you visit the relevant files. + +@item Access to Guile's built in help system +GDS makes it easy to query Guile's ``help'' and ``apropos'' commands, +and pops up the results in a temporary Emacs window. + +@item Symbol completion +GDS provides a keystroke which tries to complete a partially entered +symbol by asking Guile to match it against all the accessible bindings. +@end table + +(For a hands-on, tutorial introduction to using GDS, use Emacs to open +the file @file{gds-tutorial.txt}, which is included with the +guile-debugging distribution, and then follow the steps in that file.) + +GDS can provide these facilities for any number of Guile Scheme programs +(which we often call ``clients'') at once, and these programs can be +started either completely independently of GDS, including outside Emacs, +or specifically @emph{by} GDS. The two common cases are: + +@itemize +@item +a Guile application, such as @uref{http://www.gnucash.org, GnuCash}, +which is started from your desktop, and which connects to GDS as a +result of some incantation added to its startup code + +@item +a ``utility'' Guile process which is run by GDS to provide help, +completion and evaluation for Scheme code that you are working on in +Emacs. +@end itemize + +@noindent +The user experience --- in other words the ways that the GDS front end +allows you to interact with the client --- is much the same in all +cases. + +Communication between the Guile client program and GDS uses a TCP +socket, which means that it is orthogonal to any other interfaces that +the client program has. In particular GDS does not interfere with a +program's standard input and output. +@end ignore + +@menu +* GDS Setup:: +* How To Use GDS:: +* Displaying the Scheme Stack:: +* Continuing Execution:: +* Evaluating Scheme Code:: +* Setting and Managing Breakpoints:: +* Access to Guile Help and Completion:: +* Associating Buffers with Clients:: +* An Example GDS Session:: +* GDS Architecture:: +@end menu + + +@node GDS Setup +@subsection GDS Setup + +GDS's Scheme and Emacs Lisp files will have been installed in +the correct places system-wide when the @code{guile-debugging} package +as a whole was installed. To enable the use of GDS in your own Emacs +sessions, simply add + +@lisp +(require 'gds) +@end lisp + +@noindent +somewhere in your @file{.emacs} file. + + +@node How To Use GDS +@subsection How To Use GDS + +There are lots of ways to use GDS, but they boil down to two overall +approaches. + +@enumerate +@item +When you are writing Scheme code in Emacs, you can use GDS while you are +writing to help with things like name completion, looking up help, and +evaluating fragments of code to check that they do what you expect. + +The first time you do something that needs a running Guile process, GDS +will automatically create one as an Emacs subprocess. This Guile +program does nothing but wait for and act on instructions from GDS, and +we refer to it as a @dfn{utility} Guile client. + +Over time this utility Guile will accumulate the code that you ask it to +evaluate, and you can also tell it to load complete files or modules by +sending it @code{load} or @code{use-modules} expressions. You can set +breakpoints and evaluate code which hits those breakpoints, and GDS will +pop up the stack at the breakpoint so you can explore your code by +single-stepping and evaluating test expressions. + +@item +Alternatively, you can use GDS to explore and debug a Guile program or +script which is started independently of GDS. This could be a script +that you invoke from the command line, or a graphical Guile-using +application which is launched from your desktop's start menu. + +In this case the program has to put something in its startup code to +cause it to connect to GDS at some point: either immediately during the +startup processing, or later when an error occurs or a trap is hit. +Several possibilities for this are described below. + +Under certain conditions, then, the program will stop, pass its current +Scheme stack to GDS, and then wait for instruction before continuing +execution. At such points you can use GDS to explore the stack, +obviously, but also to set or delete other breakpoints, modify the +program's code (by editing and then reevaluating it from Emacs), and use +the help and completion facilities, before eventually telling the +program to single-step or to continue running normally. +@end enumerate + +Here are some of the ways that a Guile program or script can arrange in +its startup code to use GDS. + +@subsubsection Invoking GDS when an Exception Occurs + +@lisp +(use-modules (ice-9 gds-client) + (ice-9 debugging traps)) + +(on-lazy-handler-dispatch gds-debug-trap) +@end lisp + +This means that the program will use GDS to display the stack whenever +it hits an exception that is protected by a @code{lazy-catch} using +Guile's standard @code{lazy-catch-handler} (defined in +@file{boot-9.scm}). + +@code{lazy-catch-handler} is used by the @code{stack-catch} procedure, +provided by the @code{(ice-9 stack-catch)} module, so this will include +exceptions within a @code{stack-catch}. @code{lazy-catch-handler} is +also used by the standard Guile REPL, when you run Guile interactively, +so you can add the above lines to your @file{.guile} file if you want to +use GDS whenever something that you type into the REPL throws an +exception. + +@subsubsection Setting GDS-managed Breakpoints + +@lisp +(use-modules (ice-9 gds-client)) +(set-gds-breakpoints) +@end lisp + +These lines tell the program to connect to GDS immediately and download +a set of breakpoint definitions. The program sets those breakpoints in +its code, then continues running. + +When the program later hits one of the breakpoints, it will use GDS to +display the stack and wait for instruction on what to do next, as +described above. + +@subsubsection Setting Specific Breakpoints + +@lisp +(use-modules (ice-9 debugging breakpoints) + (ice-9 gds-client)) + +(break-in 'fact2 "ice-9/debugging/example-fns" + #:behaviour gds-debug-trap) +@end lisp + +In this example, the program chooses to define its breakpoint explicitly +in its code, rather than downloading definitions from GDS, but it still +uses GDS to control what happens when the breakpoint is hit, by +specifying @code{gds-debug-trap} as the breakpoint behaviour. + +@subsubsection Accepting GDS Instructions at Any Time + +In addition to setting breakpoints and/or an exception handler as +described above, a Guile program can in principle set itself up to +accept new instructions from GDS at any time, not just when it has +stopped at a breakpoint or exception. This would allow the GDS user to +set new breakpoints or to evaluate code in the context of the running +program, without having to wait for the program to stop first. + +@lisp +(use-modules (ice-9 gds-client)) +(gds-accept-input #t) +@end lisp + +@code{gds-accept-input} causes the calling program to loop processing +instructions from GDS, until GDS sends the @code{continue} instruction. +This blocks the thread that calls it, however, so it will normally be +more practical for the program to set up a dedicated GDS thread and call +@code{gds-accept-input} from that thread. + +For @code{select}-driven applications, an alternative approach would be +for the GDS client code to provide an API which allowed the application +to + +@itemize +@item +discover the file descriptors (or Scheme ports) that are used for +receiving instruction from the GDS front end, so that it could include +these in its @code{select} call + +@item +call the GDS instruction handler when @code{select} indicated data +available for reading on those descriptors/ports. +@end itemize + +@noindent +This approach is not yet implemented, though. + +@subsubsection Utility Guile Implementation + +We bring this subsection full circle by noting that the ``utility'' Guile +client, which GDS starts automatically when you use GDS as described +under approach 1 above, is really just a special case of ``a Guile +program or script which is started independently'' (approach 2), and +provides the services that the GDS front end needs by a simple +combination of some of the code fragments just described. + +To be precise, the code for the utility Guile client is essentially +this: + +@lisp +(use-modules (ice-9 gds-client)) + +(set-gds-breakpoints) +(named-module-use! '(guile-user) '(ice-9 session)) +(gds-accept-input #f)) +@end lisp + +@code{set-gds-breakpoints} works as already described. The +@code{named-module-use!} line ensures that the client can process +@code{help} and @code{apropos} expressions, which is what the front end +sends to implement lookups in Guile's online help. The @code{#f} +parameter to @code{gds-accept-input} means that the @code{continue} +instruction will not cause the instruction loop to exit, which makes +sense here because the utility client has nothing to do except to +process GDS instructions. + +(The utility client does not use @code{on-lazy-handler-dispatch}, +because it has its own mechanism for catching and reporting exceptions +in the code that it is asked to evaluate. This mechanism summarizes the +exception and gives the user a button they can click to see the full +stack, so the end result is very similar to what +@code{on-lazy-handler-dispatch} provides.) + + +@node Displaying the Scheme Stack +@subsection Displaying the Scheme Stack + +When you specify @code{gds-debug-trap} as the behaviour for a trap or +a breakpoint and the Guile program concerned hits that trap or +breakpoint, GDS displays the stack and the relevant Scheme source code +in Emacs, allowing you to explore the state of the program and then +decide what to do next. The same applies if the program calls +@code{(on-lazy-handler-dispatch gds-debug-trap)} and then throws an +exception that passes through @code{lazy-handler-dispatch}, except +that in this case you can only explore; it isn't possible to continue +normal execution after an exception. + +The following commands are available in the stack buffer for exploring +the state of the program. + +@table @asis +@item @kbd{u}, @kbd{C-p}, @kbd{@key{up}} +@findex gds-up +Select the stack frame one up from the currently selected frame +(@code{gds-up}). GDS displays stack frames with the innermost at the +top, so moving ``up'' means selecting a more ``inner'' frame. + +@item @kbd{d}, @kbd{C-n}, @kbd{@key{down}} +@findex gds-down +Select the stack frame one down from the currently selected frame +(@code{gds-down}). GDS displays stack frames with the innermost at the +top, so moving ``down'' means selecting a more ``outer'' frame. + +@item @kbd{@key{RET}} +@findex gds-select-stack-frame +Select the stack frame at point (@code{gds-select-stack-frame}). This +is useful after clicking somewhere in the stack trace with the mouse. +@end table + +Selecting a frame means that GDS will display the source code +corresponding to that frame in the adjacent window, and that +subsequent frame-sensitive commands, such as @code{gds-evaluate} (see +below) and @code{gds-step-over} (@pxref{Continuing Execution}), will +refer to that frame. + +@table @kbd +@item e +@findex gds-evaluate +Evaluate a variable or expression in the local environment of the +selected stack frame (@code{gds-evaluate}). The result is displayed in +the echo area. + +@item I +@findex gds-frame-info +Show summary information about the selected stack frame +(@code{gds-frame-info}). This includes what type of frame it is, the +associated expression, and the frame's source location, if any. + +@item A +@findex gds-frame-args +For an application frame, display the frame's arguments +(@code{gds-frame-args}). + +@item S +@findex gds-proc-source +For an application frame, show the Scheme source code of the procedure +being called (@code{gds-proc-source}). The source code (where +available) is displayed in the echo area. +@end table + +@kbd{S} (@code{gds-proc-source}) is useful when the procedure being +called was created by an anonymous @code{(lambda @dots{})} expression. +Such procedures appear in the stack trace as @code{}, which doesn't give you much clue as to what will happen +next. @kbd{S} will show you the procedure's code, which is usually +enough for you to identify it. + + +@node Continuing Execution +@subsection Continuing Execution + +If it makes sense to continue execution from the stack which is being +displayed, GDS provides the following further commands in the stack +buffer. + +@table @asis +@item @kbd{g}, @kbd{c}, @kbd{q} +@findex gds-go +Tell the program to continue running (@code{gds-go}). It may of course +stop again if it hits another trap, or another occurrence of the same +trap. + +The multiple keystrokes reflect that you can think of this as ``going'', +``continuing'' or ``quitting'' (in the sense of quitting the GDS +display). + +@item @kbd{@key{SPC}} +@findex gds-step-file +Tell the program to do a single-step to the next entry or exit of a +frame whose code comes from the same source file as the selected stack +frame (@code{gds-step-file}). + +In other words, you can hit @kbd{@key{SPC}} repeatedly to step through +the code in a given file, automatically stepping @emph{over} any +evaluations or procedure calls that use code from other files (or from +no file). + +If the selected stack frame has no source, the effect of this command is +the same as that of @kbd{i}, described next. + +@item @kbd{i} +@findex gds-step-into +Tell the debugged program to do a single-step to the next frame entry or +exit of any kind (@code{gds-step-into}). @kbd{i} therefore steps +through code at the most detailed level possible. + +@item @kbd{o} +@findex gds-step-over +Tell the debugged program to continue running until the selected stack +frame completes, and then to display its result (@code{gds-step-over}). +Note that the program may stop before then if it hits another trap; in +this case the trap telling it to stop when the marked frame completes +remains in place and so will still fire at the appropriate point. +@end table + + +@node Evaluating Scheme Code +@subsection Evaluating Scheme Code + +The following keystrokes and commands provide various ways of sending +code to a Guile client process for evaluation. + +@table @kbd +@item M-C-x +@findex gds-eval-defun +Evaluate the ``top level defun'' that the cursor is in, in other words +the smallest balanced expression which includes the cursor and whose +opening parenthesis is in column 0 (@code{gds-eval-defun}). + +@item C-x C-e +@findex gds-eval-last-sexp +Evaluate the expression that ends just before the cursor +(@code{gds-eval-last-sexp}). This is designed so that it is easy to +evaluate an expression that you have just finished typing. + +@item C-c C-e +@findex gds-eval-expression +Read a Scheme expression using the minibuffer, and evaluate that +expression (@code{gds-eval-expression}). + +@item C-c C-r +@findex gds-eval-region +Evaluate the Scheme code in the marked region of the current buffer +(@code{gds-eval-region}). Note that GDS does not check whether the +region contains a balanced expression, or try to expand the region so +that it does; it uses the region exactly as it is. +@end table + + +@node Setting and Managing Breakpoints +@subsection Setting and Managing Breakpoints + +You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a +Scheme mode buffer. To create a breakpoint on calls to a procedure +--- i.e. the equivalent of calling @code{break-in} --- place the +cursor on the procedure's name and type @kbd{C-x @key{SPC}}. To +create breakpoints on a particular expression, or on the series of +expressions in a particular region --- i.e. as with @code{break-at} +--- select the expression or region in the usual way and type @kbd{C-x +@key{SPC}}. In general, GDS assumes that you want a @code{break-at} +breakpoint if there is an active region, and a @code{break-in} +breakpoint otherwise. + +When you create a breakpoint like this, two things happen. Firstly, +if the current buffer is associated with a Guile client program, the +new breakpoint definition is immediately sent to that client (or, if +the client cannot accept input immediately, it is held in readiness to +pass to the client at the next possible opportunity). This allows the +new breakpoint to take effect as soon as possible in the relevant +client program. + +Secondly, it is added to GDS's @emph{global} list of all breakpoints. +This list holds the breakpoint information that will be given to any +client program that asks for it by calling @code{set-gds-breakpoints}. +The fact that this list is global, rather than client-specific, means +that the breakpoints you have set will automatically be recreated if +the program you are debugging has to be stopped and restarted --- +which in my experience happens often.@footnote{An important point here +is that there is nothing that unambiguously relates two subsequent +runs of the same client program, which might allow GDS to pass on +breakpoint settings more precisely.} + +(The only possible downside of this last point is that if you are +debugging two programs in parallel, which have some code in common, +you might not want a common code breakpoint in one program to be set +in the other program as well. But this feels like a small concern in +comparison to the benefit of breakpoints persisting as just described.) + + +@node Access to Guile Help and Completion +@subsection Access to Guile Help and Completion + +The following keystrokes provide fast and convenient access to Guile's +built in help, and to completion with respect to the set of defined and +accessible symbols. + +@table @kbd +@item C-h g +@findex gds-help-symbol +Get Guile help for a particular symbol, with the same results as if +you had typed @code{(help SYMBOL)} into the Guile REPL +(@code{gds-help-symbol}). The symbol to query defaults to the word at +or before the cursor but can also be entered or edited in the +minibuffer. The available help is popped up in a temporary Emacs +window. + +@item C-h C-g +@findex gds-apropos +List all accessible Guile symbols matching a given regular expression, +with the same results as if you had typed @code{(apropos REGEXP)} into +the Guile REPL (@code{gds-apropos}). The regexp to query defaults to +the word at or before the cursor but can also be entered or edited in +the minibuffer. The list of matching symbols is popped up in a +temporary Emacs window. + +@item M-@key{TAB} +@findex gds-complete-symbol +Try to complete the symbol at the cursor by matching it against the +set of all defined and accessible bindings in the associated Guile +process (@code{gds-complete-symbol}). If there are any extra +characters that can be definitively added to the symbol at point, they +are inserted. Otherwise, if there are any completions available, they +are popped up in a temporary Emacs window, where one of them can be +selected using either @kbd{@key{RET}} or the mouse. +@end table + + +@node Associating Buffers with Clients +@subsection Associating Buffers with Clients + +The first time that you use one of GDS's evaluation, help or completion +commands from a given Scheme mode buffer, GDS will ask which Guile +client program you want to use for the operation, or if you want to +start up a new ``utility'' client. After that GDS considers the buffer +to be ``associated'' with the selected client, and so sends all further +requests to that client, but you can override this by explicitly +associating the buffer with a different client, or by removing the +default association. + +@table @kbd +@item M-x gds-associate-buffer +Associate (or re-associate) the current buffer with a particular Guile +client program. The available clients are listed, and you can also +choose to start up a new ``utility'' client for this buffer to associate +with. + +@item M-x gds-dissociate-buffer +Dissociate the current buffer from its client, if any. This means that +the next time you use an evaluation, help or completion command, GDS +will ask you again which client to send the request to. +@end table + +When a buffer is associated with a client program, the buffer's modeline +shows whether the client is currently able to accept instruction from +GDS. This is done by adding one of the following suffixes to the +``Scheme'' major mode indicator: + +@table @asis +@item :ready +The client program (or one of its threads, if multithreaded) is +currently ready to accept instruction from GDS. In other words, if you +send it a help or evaluation request, you should see the result pretty +much immediately. + +@item :running +The client program is not currently able to accept instruction from +GDS. This means that it (or all of its threads, if multithreaded) is +busy, or waiting for input other than from GDS. + +@item :debug +The client program (or one of its threads, if multithreaded) is stopped +in ``debugging mode'' with GDS displaying the stack for a trap or +exception. It is waiting for instruction from GDS on what to do next. +@end table + + +@node An Example GDS Session +@subsection An Example GDS Session + +Create a file, @file{testgds.scm} say, for experimenting with GDS and +Scheme code, and type this into it: + +@lisp +(use-modules (ice-9 debugging traps) + (ice-9 gds-client) + (ice-9 debugging example-fns)) +(install-trap (make + #:behaviour gds-debug-trap + #:procedure fact1)) +@end lisp + +@noindent +Now select all of this code and type @kbd{C-c C-r} to send the selected +region to Guile for evaluation. GDS will ask you which Guile process to +use; unless you know that you already have another Guile application +running and connected to GDS, choose the ``Start a new Guile'' option, +which starts one of the ``utility'' processes described in @ref{How To +Use GDS}. + +The results of the evaluation pop up in a window like this: + +@lisp +(use-modules (ice-9 debugging traps)\n @dots{} + +;;; Evaluating subexpression 1 in current module (guile-user) + @result{} no (or unspecified) value + +;;; Evaluating subexpression 2 in current module (guile-user) + @result{} no (or unspecified) value + +--:** *Guile Evaluation* (Scheme:ready)--All------------ +@end lisp + +@noindent +this tells you that the evaluation was successful but that the return +values were unspecified. Its effect was to load a module of example +functions and set a trap on one of these functions, @code{fact1}, that +calculates the factorial of its argument. + +If you now call @code{fact1}, you can see the trap and GDS's stack +display in action. To do this add + +@lisp +(fact1 4) +@end lisp + +@noindent +to your @file{testgds.scm} buffer and type @kbd{C-x C-e} (which +evaluates the expression that the cursor is just after the end of). The +result is: + +@lisp +(fact1 4) + +;;; Evaluating in current module (guile-user) + @result{} 24 + +--:** *Guile Evaluation* (Scheme:ready)--All------------ +@end lisp + +@noindent +which is correct, but indicates that we forgot the step needed to enable +the trap mechanism. To do this, type @kbd{C-c C-e} and then enter + +@lisp +(trap-enable 'traps) +@end lisp + +@noindent +into the minibuffer. (You could equally have typed this into your test +file and evaluated it from there; we use @kbd{C-c C-e} here to +demonstrate the minibuffer option and because you typically wouldn't +want to leave this kind of global setting in the source code that you +are working on.) + +If you now type @kbd{C-x C-e} to evaluate @code{(fact1 4)} again, a GDS +stack window like the following appears: + +@lisp +Calling procedure: +=> s [fact1 4] + s [primitive-eval (fact1 4)] + + +--:** PID 28729 (Guile-Debug)--All------------ +@end lisp + +GDS's most compelling feature is its single-stepping. To get an +immediate feel for what this is like, make sure your Emacs is prepared +as described in @ref{GDS Setup}, then type the following code into an +interactive Guile session. + +@lisp +(fact1 4) +@end lisp + +@noindent +This will cause the GDS Guile-Debug window to pop up in Emacs, where +you can then press @kbd{i} once and @kbd{@key{SPC}} repeatedly to +single-step through the code from the point of the initial trap. + +(@kbd{i} is needed as the first keystroke rather than @kbd{@key{SPC}}, +because the aim here is to step through code in the @code{(ice-9 +debugging example-fns)} module, whose source file is +@file{@dots{}/ice-9/debugging/example-fns.scm}, but the initial +@code{(fact1 4)} call comes from the Guile session, whose ``source +file'' Guile presents as @file{standard input}. If the user starts by +pressing @kbd{@key{SPC}} instead of @kbd{i}, the effect is that the +program runs until it hits the first recursive call @code{(fact1 (- n +1))}, where it stops because of the trap on @code{fact1} firing again. +At this point, the source file @emph{is} +@file{@dots{}/ice-9/debugging/example-fns.scm}, because the recursive +@code{(fact1 (- n 1))} call comes from code in that file, so further +pressing of @kbd{@key{SPC}} successfully single-steps through this +file.) + + +@node GDS Architecture +@subsection GDS Architecture + +Ths following information may be of interest to readers who would like +to know how GDS works. Please note that understanding the details of +this subsection is completely optional so far as just using GDS is +concerned! + +GDS consists of three components. + +@itemize +@item +The GDS @dfn{interface} code is written in Emacs Lisp and runs inside +Emacs. This code, consisting of the installed files @file{gds.el} and +@file{gds-server.el}, is responsible for displaying information from +Guile in Emacs windows, and for responding to Emacs commands and +keystrokes by sending instructions back to the Guile program being +debugged. + +@item +The GDS @dfn{server} code is written in Scheme and runs as an Emacs +inferior process. It acts as a multiplexer between the (possibly +multiple) Guile programs being debugged and the interface code running +in Emacs. The server code is the installed file +@file{gds-server.scm}. + +@item +The GDS @dfn{client} code is written in Scheme (installed file +@file{gds-client.scm}), and is loaded as a module by each Guile +program that wants to use GDS for debugging. When a trap occurs whose +behaviour is @code{gds-debug-trap}, it feeds information about the +trap context through the server to Emacs, then waits for instruction +back from the Emacs interface on what to do next. +@end itemize + +@noindent +Summarized in glorious ASCII art, this looks as follows. + +@example ++------------+ +| Program #1 | +| | +| +--------+ | +| | Client |-_ +| +--------+ |-_ +---------------+ ++------------+ -_TCP | Emacs | + -_ | | + -_+--------+ | +-----------+ | + _| Server |-----| Interface | | ++------------+ _- +--------+ | +-----------+ | +| Program #2 | _- +---------------+ +| | _- TCP +| +--------+ _- +| | Client |-| +| +--------+ | ++------------+ +@end example + +@noindent +@cindex TCP, use of +The communication between the client and server components is over a +TCP connection, which has two implications. Firstly, that GDS is +independent of whatever other interfaces the programs being debugged +have, whether graphical or through standard input and output. +Secondly, that the server and Emacs interface can be on a different +computer from the programs being debugged (only theoretically, though, +because GDS doesn't yet provide an interface to connect to any server +other than the default, on localhost at TCP port 8333). The data +exchanged between client and server components, and between server and +interface components, is in the form of sexps that are organized so as +to be directly readable by both Scheme and Emacs Lisp. + + +@subsubsection Security Note + +@cindex Security +GDS currently has no authentication between its client and server +components, so in an untrusted environment the use of TCP probably +raises important security issues. If you are thinking of using GDS in +such an environment, please consider any such issues carefully before +proceeding! + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From 9837893af2727944637b99a9b9625f034bf83d9a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 13:14:46 +0000 Subject: [PATCH 019/116] (Using Guile in Emacs): Unignore extra GDS intro text. (I will edit this down later. For now it's convenient to have it all appearing, so it's visible on paper.) --- doc/ref/ChangeLog | 6 ++++++ doc/ref/scheme-using.texi | 2 -- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 451c6f575..b75cdf259 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2006-08-18 Neil Jerram + + * scheme-using.texi (Using Guile in Emacs): Unignore extra GDS + intro text. (I will edit this down later. For now it's + convenient to have it all appearing, so it's visible on paper.) + 2006-08-11 Neil Jerram * scheme-using.texi (Run To Frame Exit): Improved doc for finish. diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index f7f49a45d..fc6821fc0 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -411,7 +411,6 @@ can also run a program until it hits a breakpoint, then examine, modify and reevaluate some of the relevant code, and then tell the program to continue running. -@ignore GDS is a user interface for working on Guile Scheme programs in Emacs. It aims to provide whatever facilities are needed to make the writing, debugging and maintenance of Scheme code in Emacs as fluid and @@ -487,7 +486,6 @@ Communication between the Guile client program and GDS uses a TCP socket, which means that it is orthogonal to any other interfaces that the client program has. In particular GDS does not interfere with a program's standard input and output. -@end ignore @menu * GDS Setup:: From 8746959cd3078c54a5760dcc7ee1e3451d21e1fd Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 13:41:45 +0000 Subject: [PATCH 020/116] * configure.in: Generate Makefile for ice-9/debugging. * debugging/trc.scm: New file. * debugging/traps.scm: New file. * debugging/trace.scm: New file. * debugging/steps.scm: New file. * debugging/load-hooks.scm: New file. * debugging/ice-9-debugger-extensions.scm: New file. * debugging/example-fns.scm: New file. * debugging/breakpoints.scm: New file. * debugging/Makefile.am: New. * Makefile.am (SUBDIRS): Add debugging. --- ChangeLog | 4 + configure.in | 1 + ice-9/ChangeLog | 22 + ice-9/Makefile.am | 2 +- ice-9/debugging/Makefile.am | 33 + ice-9/debugging/breakpoints.scm | 415 +++++++ ice-9/debugging/example-fns.scm | 17 + ice-9/debugging/ice-9-debugger-extensions.scm | 154 +++ ice-9/debugging/load-hooks.scm | 33 + ice-9/debugging/steps.scm | 106 ++ ice-9/debugging/trace.scm | 157 +++ ice-9/debugging/traps.scm | 1037 +++++++++++++++++ ice-9/debugging/trc.scm | 63 + 13 files changed, 2043 insertions(+), 1 deletion(-) create mode 100644 ice-9/debugging/Makefile.am create mode 100644 ice-9/debugging/breakpoints.scm create mode 100644 ice-9/debugging/example-fns.scm create mode 100644 ice-9/debugging/ice-9-debugger-extensions.scm create mode 100644 ice-9/debugging/load-hooks.scm create mode 100644 ice-9/debugging/steps.scm create mode 100644 ice-9/debugging/trace.scm create mode 100755 ice-9/debugging/traps.scm create mode 100644 ice-9/debugging/trc.scm diff --git a/ChangeLog b/ChangeLog index 0f32c104a..9739d8e9f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2006-08-18 Neil Jerram + + * configure.in: Generate Makefile for ice-9/debugging. + 2006-06-13 Ludovic Courts * NEWS: Mentioned the new behavior of `equal?' for structures. diff --git a/configure.in b/configure.in index 1bb3ea7a4..c216c7ef1 100644 --- a/configure.in +++ b/configure.in @@ -1231,6 +1231,7 @@ AC_CONFIG_FILES([ guile-config/Makefile ice-9/Makefile ice-9/debugger/Makefile + ice-9/debugging/Makefile lang/Makefile lang/elisp/Makefile lang/elisp/internals/Makefile diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index dd9f17291..c2ff7715a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,25 @@ +2006-08-18 Neil Jerram + + * debugging/trc.scm: New file. + + * debugging/traps.scm: New file. + + * debugging/trace.scm: New file. + + * debugging/steps.scm: New file. + + * debugging/load-hooks.scm: New file. + + * debugging/ice-9-debugger-extensions.scm: New file. + + * debugging/example-fns.scm: New file. + + * debugging/breakpoints.scm: New file. + + * debugging/Makefile.am: New. + + * Makefile.am (SUBDIRS): Add debugging. + 2006-06-19 Neil Jerram * Makefile.am (ice9_sources): Add new files. diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 412b98945..0eb1ac8f2 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -21,7 +21,7 @@ AUTOMAKE_OPTIONS = gnu -SUBDIRS = debugger +SUBDIRS = debugger debugging # These should be installed and distributed. ice9_sources = \ diff --git a/ice-9/debugging/Makefile.am b/ice-9/debugging/Makefile.am new file mode 100644 index 000000000..5fbe9c6de --- /dev/null +++ b/ice-9/debugging/Makefile.am @@ -0,0 +1,33 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2006 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE 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 General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth +## Floor, Boston, MA 02110-1301 USA + +AUTOMAKE_OPTIONS = gnu + +# These should be installed and distributed. +ice9_debugging_sources = breakpoints.scm example-fns.scm \ + ice-9-debugger-extensions.scm load-hooks.scm \ + steps.scm trace.scm traps.scm trc.scm + +subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging +subpkgdata_DATA = $(ice9_debugging_sources) +TAGS_FILES = $(subpkgdata_DATA) + +EXTRA_DIST = $(ice9_debugging_sources) diff --git a/ice-9/debugging/breakpoints.scm b/ice-9/debugging/breakpoints.scm new file mode 100644 index 000000000..132746f17 --- /dev/null +++ b/ice-9/debugging/breakpoints.scm @@ -0,0 +1,415 @@ +;;;; (ice-9 debugging breakpoints) -- practical breakpoints + +;;; Copyright (C) 2005 Neil Jerram +;;; +;; 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; This module provides a practical interface for setting and +;;; manipulating breakpoints. + +(define-module (ice-9 debugging breakpoints) + #:use-module (ice-9 debugger) + #:use-module (ice-9 ls) + #:use-module (ice-9 optargs) + #:use-module (ice-9 regex) + #:use-module (oop goops) + #:use-module (ice-9 debugging ice-9-debugger-extensions) + #:use-module (ice-9 debugging traps) + #:use-module (ice-9 debugging trc) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (break-in + break-at + default-breakpoint-behaviour + delete-breakpoint + for-each-breakpoint + setup-before-load + setup-after-load + setup-after-read + setup-after-eval)) + +;; If the running Guile does not provide before- and after- load hooks +;; itself, install them using the (ice-9 debugging load-hooks) module. +(or (defined? 'after-load-hook) + (begin + (use-modules (ice-9 debugging load-hooks)) + (install-load-hooks))) + +;; Getter/setter for default breakpoint behaviour. +(define default-breakpoint-behaviour + (let ((behaviour debug-trap)) + (make-procedure-with-setter + ;; Getter: return current default behaviour. + (lambda () + behaviour) + ;; Setter: set default behaviour to given procedure. + (lambda (new-behaviour) + (set! behaviour new-behaviour))))) + +;; Base class for breakpoints. (We don't need to use GOOPS to +;; represent breakpoints, but it's a nice way to describe a composite +;; object.) +(define-class () + ;; This breakpoint's trap options, which include its behaviour. + (trap-options #:init-keyword #:trap-options) + ;; All the traps relating to this breakpoint. + (traps #:init-value '()) + ;; Observer. This is a procedure that is called when the breakpoint + ;; trap list changes. + (observer #:init-value #f)) + +;; Noop base class definitions of all the possible setup methods. +(define-method (setup-before-load (bp ) filename) + *unspecified*) +(define-method (setup-after-load (bp ) filename) + *unspecified*) +(define-method (setup-after-read (bp ) x) + *unspecified*) +(define-method (setup-after-eval (bp ) filename) + *unspecified*) + +;; Call the breakpoint's observer, if it has one. +(define-method (call-observer (bp )) + (cond ((slot-ref bp 'observer) + => + (lambda (proc) + (proc))))) + +;; Delete a breakpoint. +(define (delete-breakpoint bp) + ;; Remove this breakpoint from the global list. + (set! breakpoints (delq! bp breakpoints)) + ;; Uninstall and discard all its traps. + (for-each uninstall-trap (slot-ref bp 'traps)) + (slot-set! bp 'traps '())) + +;; Class for `break-in' breakpoints. +(define-class () + ;; The name of the procedure to break in. + (procedure-name #:init-keyword #:procedure-name) + ;; The name of the module or file that the procedure is defined in. + ;; A module name is a list of symbols that exactly names the + ;; relevant module. A file name is a string, which can in fact be + ;; any substring of the relevant full file name. + (module-or-file-name #:init-keyword #:module-or-file-name)) + +;; Class for `break-at' breakpoints. +(define-class () + ;; The name of the file to break in. This is a string, which can in + ;; fact be any substring of the relevant full file name. + (file-name #:init-keyword #:file-name) + ;; Line and column number to break at. + (line #:init-keyword #:line) + (column #:init-keyword #:column)) + +;; Global list of non-deleted breakpoints. +(define breakpoints '()) + +;; Add to the above list. +(define-method (add-to-global-breakpoint-list (bp )) + (set! breakpoints (append! breakpoints (list bp)))) + +;; break-in: create a `break-in' breakpoint. +(define (break-in procedure-name . options) + ;; Sort out the optional args. + (let* ((module-or-file-name+options + (cond ((and (not (null? options)) + (or (string? (car options)) + (list? (car options)))) + options) + (else + (cons (module-name (current-module)) options)))) + (module-or-file-name (car module-or-file-name+options)) + (trap-options (cdr module-or-file-name+options)) + ;; Create the new breakpoint object. + (bp (make + #:procedure-name procedure-name + #:module-or-file-name module-or-file-name + #:trap-options (if (memq #:behaviour trap-options) + trap-options + (cons* #:behaviour + (default-breakpoint-behaviour) + trap-options))))) + ;; Add it to the global breakpoint list. + (add-to-global-breakpoint-list bp) + ;; Set the new breakpoint, if possible, in already loaded code. + (set-in-existing-code bp) + ;; Return the breakpoint object to our caller. + bp)) + +;; break-at: create a `break-at' breakpoint. +(define (break-at file-name line column . trap-options) + ;; Create the new breakpoint object. + (let* ((bp (make + #:file-name file-name + #:line line + #:column column + #:trap-options (if (memq #:behaviour trap-options) + trap-options + (cons* #:behaviour + (default-breakpoint-behaviour) + trap-options))))) + ;; Add it to the global breakpoint list. + (add-to-global-breakpoint-list bp) + ;; Set the new breakpoint, if possible, in already loaded code. + (set-in-existing-code bp) + ;; Return the breakpoint object to our caller. + bp)) + +;; Set a `break-in' breakpoint in already loaded code, if possible. +(define-method (set-in-existing-code (bp )) + ;; Get the module or file name that was specified for this + ;; breakpoint. + (let ((module-or-file-name (slot-ref bp 'module-or-file-name))) + ;; Handling is simpler for a module name. + (cond ((list? module-or-file-name) + ;; See if the named module exists yet. + (let ((m (module-if-already-loaded module-or-file-name))) + (maybe-break-in-module-proc m bp))) + ((string? module-or-file-name) + ;; Try all loaded modules. + (or-map (lambda (m) + (maybe-break-in-module-proc m bp)) + (all-loaded-modules))) + (else + (error "Bad module-or-file-name:" module-or-file-name))))) + +(define (make-observer bp trap) + (lambda (event) + (trap-target-gone bp trap))) + +;; Set a `break-at' breakpoint in already loaded code, if possible. +(define-method (set-in-existing-code (bp ) . code) + ;; Procedure to install a source trap on each expression that we + ;; find matching this breakpoint. + (define (install-source-trap x) + (or (or-map (lambda (trap) + (and (is-a? trap ) + (eq? (slot-ref trap 'expression) x))) + (slot-ref bp 'traps)) + (let ((trap (apply make + #:expression x + (slot-ref bp 'trap-options)))) + (slot-set! trap 'observer (make-observer bp trap)) + (install-trap trap) + (trc 'install-source-trap (object-address trap) (object-address x)) + (trap-installed bp trap #t)))) + ;; Scan the source whash, and install a trap on all code matching + ;; this breakpoint. + (trc 'set-in-existing-code (length code)) + (if (null? code) + (scan-source-whash (slot-ref bp 'file-name) + (slot-ref bp 'line) + (slot-ref bp 'column) + install-source-trap) + (scan-code (car code) + (slot-ref bp 'file-name) + (slot-ref bp 'line) + (slot-ref bp 'column) + install-source-trap))) + +;; Temporary implementation of scan-source-whash - this _really_ needs +;; to be implemented in C. +(define (scan-source-whash file-name line column proc) + ;; Procedure to call for each source expression in the whash. + (define (folder x props acc) + (if (and (= line (source-property x 'line)) + (= column (source-property x 'column)) + (let ((fn (source-property x 'filename))) + (trc 'scan-source-whash fn) + (and (string? fn) + (string-contains fn file-name)))) + (proc x))) + ;; Tracing. + (trc 'scan-source-whash file-name line column) + ;; Apply this procedure to the whash. + (hash-fold folder 0 source-whash)) + +(define (scan-code x file-name line column proc) + (trc 'scan-code file-name line column) + (if (pair? x) + (begin + (if (and (eq? line (source-property x 'line)) + (eq? column (source-property x 'column)) + (let ((fn (source-property x 'filename))) + (trc 'scan-code fn) + (and (string? fn) + (string-contains fn file-name)))) + (proc x)) + (scan-code (car x) file-name line column proc) + (scan-code (cdr x) file-name line column proc)))) + +;; If a module named MODULE-NAME has been loaded, return its module +;; object; otherwise return #f. +(define (module-if-already-loaded module-name) + (nested-ref the-root-module (append '(app modules) module-name))) + +;; Construct and return a list of all loaded modules. +(define (all-loaded-modules) + ;; This is the list that accumulates known modules. It has to be + ;; defined outside the following functions, and accumulated using + ;; set!, so as to avoid infinite loops - because of the fact that + ;; all non-pure modules have a variable `app'. + (define known-modules '()) + ;; Return an alist of submodules of the given PARENT-MODULE-NAME. + ;; Each element of the alist is (NAME . MODULE), where NAME is the + ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and + ;; MODULE is the module object. By a "submodule of a parent + ;; module", we mean any module value that is bound to a symbol in + ;; the parent module, and which is not an interface module. + (define (direct-submodules parent-module-name) + (filter (lambda (name+value) + (and (module? (cdr name+value)) + (not (eq? (module-kind (cdr name+value)) 'interface)))) + (map (lambda (name) + (cons name (local-ref (append parent-module-name + (list name))))) + (cdar (lls parent-module-name))))) + ;; Add all submodules (direct and indirect) of the module named + ;; PARENT-MODULE-NAME to `known-modules', if not already there. + (define (add-submodules-of parent-module-name) + (let ((ds (direct-submodules parent-module-name))) + (for-each + (lambda (name+module) + (or (memq (cdr name+module) known-modules) + (begin + (set! known-modules (cons (cdr name+module) known-modules)) + (add-submodules-of (append parent-module-name + (list (car name+module))))))) + ds))) + ;; Add submodules recursively, starting from the root of all + ;; modules. + (add-submodules-of '(app modules)) + ;; Return the result. + known-modules) + +;; Before-load setup for `break-at' breakpoints. +(define-method (setup-before-load (bp ) filename) + (let ((trap (apply make + #:file-regexp (regexp-quote (slot-ref bp 'file-name)) + #:line (slot-ref bp 'line) + #:column (slot-ref bp 'column) + (slot-ref bp 'trap-options)))) + (install-trap trap) + (trap-installed bp trap #f) + (letrec ((uninstaller + (lambda (file-name) + (uninstall-trap trap) + (remove-hook! after-load-hook uninstaller)))) + (add-hook! after-load-hook uninstaller)))) + +;; After-load setup for `break-in' breakpoints. +(define-method (setup-after-load (bp ) filename) + ;; Get the module that the loaded file created or was loaded into, + ;; and the module or file name that were specified for this + ;; breakpoint. + (let ((m (current-module)) + (module-or-file-name (slot-ref bp 'module-or-file-name))) + ;; Decide whether the breakpoint spec matches this load. + (if (or (and (string? module-or-file-name) + (string-contains filename module-or-file-name)) + (and (list? module-or-file-name) + (equal? (module-name (current-module)) module-or-file-name))) + ;; It does, so try to install the breakpoint. + (maybe-break-in-module-proc m bp)))) + +;; After-load setup for `break-at' breakpoints. +(define-method (setup-after-load (bp ) filename) + (if (string-contains filename (slot-ref bp 'file-name)) + (set-in-existing-code bp))) + +(define (maybe-break-in-module-proc m bp) + "If module M defines a procedure matching the specification of +breakpoint BP, install a trap on it." + (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f))) + (if (and proc + (procedure? proc) + (let ((module-or-file-name (slot-ref bp 'module-or-file-name))) + (if (string? module-or-file-name) + (source-file-matches (procedure-source proc) + module-or-file-name) + #t)) + (not (or-map (lambda (trap) + (and (is-a? trap ) + (eq? (slot-ref trap 'procedure) proc))) + (slot-ref bp 'traps)))) + ;; There is, so install a on it. + (letrec ((trap (apply make + #:procedure proc + (slot-ref bp 'trap-options)))) + (slot-set! trap 'observer (make-observer bp trap)) + (install-trap trap) + (trap-installed bp trap #t) + ;; Tell caller that we installed a trap. + #t) + ;; Tell caller that we did not install a trap. + #f))) + +;; After-read setup for `break-at' breakpoints. +(define-method (setup-after-read (bp ) x) + (set-in-existing-code bp x)) + +;; Common code for associating a newly created and installed trap with +;; a breakpoint object. +(define (trap-installed bp trap record?) + (if record? + ;; Remember this trap in the breakpoint object. + (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap)))) + ;; Update the breakpoint status. + (call-observer bp)) + +;; Common code for handling when the target of one of a breakpoint's +;; traps is being GC'd. +(define (trap-target-gone bp trap) + (trc 'trap-target-gone (object-address trap)) + ;; Remove this trap from the breakpoint's list. + (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps))) + ;; Update the breakpoint status. + (call-observer bp)) + +(define (source-file-matches source file-name) + "Return #t if any of the expressions in SOURCE have a 'filename +source property that includes FILE-NAME; otherwise return #f." + (and (pair? source) + (or (let ((source-file-name (source-property source 'filename))) + (and source-file-name + (string? source-file-name) + (string-contains source-file-name file-name))) + (let loop ((source source)) + (and (pair? source) + (or (source-file-matches (car source) file-name) + (loop (cdr source)))))))) + +;; Install load hook functions. +(add-hook! before-load-hook + (lambda (fn) + (for-each-breakpoint setup-before-load fn))) + +(add-hook! after-load-hook + (lambda (fn) + (for-each-breakpoint setup-after-load fn))) + +;;; Apply generic function GF to each breakpoint, passing the +;;; breakpoint object and ARGS as args on each call. +(define (for-each-breakpoint gf . args) + (for-each (lambda (bp) + (apply gf bp args)) + breakpoints)) + +;; Make sure that recording of source positions is enabled. Without +;; this break-at breakpoints will obviously not work. +(read-enable 'positions) + +;;; (ice-9 debugging breakpoints) ends here. diff --git a/ice-9/debugging/example-fns.scm b/ice-9/debugging/example-fns.scm new file mode 100644 index 000000000..30d412f00 --- /dev/null +++ b/ice-9/debugging/example-fns.scm @@ -0,0 +1,17 @@ +(define-module (ice-9 debugging example-fns) + #:export (fact1 fact2 facti)) + +(define (fact1 n) + (if (= n 0) + 1 + (* n (fact1 (- n 1))))) + +(define (facti n a) + (if (= n 0) + a + (facti (- n 1) (* a n)))) + +(define (fact2 n) + (facti n 1)) + +; Test: (fact2 3) diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm new file mode 100644 index 000000000..dc1eb8fc8 --- /dev/null +++ b/ice-9/debugging/ice-9-debugger-extensions.scm @@ -0,0 +1,154 @@ + +(define-module (ice-9 debugging ice-9-debugger-extensions) + #:use-module (ice-9 debugger)) + +;;; Upgrade the debugger state object so that it can carry a flag +;;; indicating whether the debugging session is continuable. + +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 debugger state)) + (define-module (ice-9 debugger state))) + (else + (define-module (ice-9 debugger)))) + +(set! state-rtd (make-record-type "debugger-state" '(stack index flags))) +(set! state? (record-predicate state-rtd)) +(set! make-state + (let ((make-state-internal (record-constructor state-rtd + '(stack index flags)))) + (lambda (stack index . flags) + (make-state-internal stack index flags)))) +(set! state-stack (record-accessor state-rtd 'stack)) +(set! state-index (record-accessor state-rtd 'index)) + +(define state-flags (record-accessor state-rtd 'flags)) + +;;; Add commands that (ice-9 debugger) doesn't currently have, for +;;; continuing or single stepping program execution. + +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 debugger command-loop)) + (define-module (ice-9 debugger command-loop)) + (define new-define-command define-command) + (set! define-command + (lambda (name argument-template documentation procedure) + (new-define-command name argument-template procedure)))) + (else + (define-module (ice-9 debugger)))) + +(use-modules (ice-9 debugging steps)) + +(define (assert-continuable state) + ;; Check that debugger is in a state where `continuing' makes sense. + ;; If not, signal an error. + (or (memq #:continuable (state-flags state)) + (user-error "This debug session is not continuable."))) + +(define (debugger:continue state) + "Continue program execution." + (assert-continuable state) + (throw 'exit-debugger)) + +(define (debugger:finish state) + "Continue until evaluation of the current frame is complete, and +print the result obtained." + (assert-continuable state) + (at-exit (- (stack-length (state-stack state)) + (state-index state)) + (list trace-trap debug-trap)) + (debugger:continue state)) + +(define (debugger:step state n) + "Continue until entry to @var{n}th next frame." + (assert-continuable state) + (at-step debug-trap (or n 1)) + (debugger:continue state)) + +(define (debugger:next state n) + "Continue until entry to @var{n}th next frame in same file." + (assert-continuable state) + (at-step debug-trap + (or n 1) + (frame-file-name (stack-ref (state-stack state) + (state-index state))) + (if (memq #:return (state-flags state)) + #f + (- (stack-length (state-stack state)) (state-index state)))) + (debugger:continue state)) + +(define-command "continue" '() + "Continue program execution." + debugger:continue) + +(define-command "finish" '() + "Continue until evaluation of the current frame is complete, and +print the result obtained." + debugger:finish) + +(define-command "step" '('optional exact-integer) + "Continue until entry to @var{n}th next frame." + debugger:step) + +(define-command "next" '('optional exact-integer) + "Continue until entry to @var{n}th next frame in same file." + debugger:next) + +;;; Export a couple of procedures for use by (ice-9 debugging trace). + +(cond ((string>=? (version) "1.7")) + (else + (define-module (ice-9 debugger)) + (export write-frame-short/expression + write-frame-short/application))) + +;;; Provide a `debug-trap' entry point in (ice-9 debugger). This is +;;; designed so that it can be called to explore the stack at a +;;; breakpoint, and to single step from the breakpoint. + +(define-module (ice-9 debugger)) + +(use-modules (ice-9 debugging traps)) + +(define *not-yet-introduced* #t) + +(define-public (debug-trap trap-context) + "Invoke the Guile debugger to explore the stack at the specified @var{trap}." + (start-stack 'debugger + (let* ((stack (tc:stack trap-context)) + (flags1 (let ((trap-type (tc:type trap-context))) + (case trap-type + ((#:return #:error) + (list trap-type + (tc:return-value trap-context))) + (else + (list trap-type))))) + (flags (if (tc:continuation trap-context) + (cons #:continuable flags1) + flags1)) + (state (apply make-state stack 0 flags))) + (if *not-yet-introduced* + (let ((ssize (stack-length stack))) + (display "This is the Guile debugger -- for help, type `help'.\n") + (set! *not-yet-introduced* #f) + (if (= ssize 1) + (display "There is 1 frame on the stack.\n\n") + (format #t "There are ~A frames on the stack.\n\n" ssize)))) + (write-state-short-with-source-location state) + (read-and-dispatch-commands state (current-input-port))))) + +(define write-state-short-with-source-location + (cond ((string>=? (version) "1.7") + write-state-short) + (else + (lambda (state) + (let* ((frame (stack-ref (state-stack state) (state-index state))) + (source (frame-source frame)) + (position (and source (source-position source)))) + (format #t "Frame ~A at " (frame-number frame)) + (if position + (display-position position) + (display "unknown source location")) + (newline) + (write-char #\tab) + (write-frame-short frame) + (newline)))))) diff --git a/ice-9/debugging/load-hooks.scm b/ice-9/debugging/load-hooks.scm new file mode 100644 index 000000000..fb869ed23 --- /dev/null +++ b/ice-9/debugging/load-hooks.scm @@ -0,0 +1,33 @@ + +(define-module (ice-9 debugging load-hooks) + #:export (before-load-hook + after-load-hook + install-load-hooks + uninstall-load-hooks)) + +;; real-primitive-load: holds the real (C-implemented) definition of +;; primitive-load, when the load hooks are installed. +(define real-primitive-load #f) + +;; The load hooks themselves. These are called with one argument, the +;; name of the file concerned. +(define before-load-hook (make-hook 1)) +(define after-load-hook (make-hook 1)) + +;; primitive-load-with-hooks: our new definition for primitive-load. +(define (primitive-load-with-hooks filename) + (run-hook before-load-hook filename) + (real-primitive-load filename) + (run-hook after-load-hook filename)) + +(define (install-load-hooks) + (if real-primitive-load + (error "load hooks are already installed")) + (set! real-primitive-load primitive-load) + (set! primitive-load primitive-load-with-hooks)) + +(define (uninstall-load-hooks) + (or real-primitive-load + (error "load hooks are not installed")) + (set! primitive-load real-primitive-load) + (set! real-primitive-load #f)) diff --git a/ice-9/debugging/steps.scm b/ice-9/debugging/steps.scm new file mode 100644 index 000000000..fedbc6a32 --- /dev/null +++ b/ice-9/debugging/steps.scm @@ -0,0 +1,106 @@ +;;;; (ice-9 debugging steps) -- stepping through code from the debugger + +;;; Copyright (C) 2002, 2004 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ice-9 debugging steps) + #:use-module (ice-9 debugging traps) + #:use-module (ice-9 and-let-star) + #:use-module (ice-9 debugger) + #:use-module (ice-9 optargs) + #:export (at-exit + at-entry + at-apply + at-step + at-next)) + +;;; at-exit DEPTH BEHAVIOUR +;;; +;;; Install a behaviour to run when we exit the current frame. + +(define (at-exit depth behaviour) + (install-trap (make + #:depth depth + #:single-shot #t + #:behaviour behaviour))) + +;;; at-entry BEHAVIOUR [COUNT] +;;; +;;; Install a behaviour to run when we get to the COUNT'th next frame +;;; entry. COUNT defaults to 1. + +(define* (at-entry behaviour #:optional (count 1)) + (install-trap (make + #:skip-count (- count 1) + #:single-shot #t + #:behaviour behaviour))) + +;;; at-apply BEHAVIOUR [COUNT] +;;; +;;; Install a behaviour to run when we get to the COUNT'th next +;;; application. COUNT defaults to 1. + +(define* (at-apply behaviour #:optional (count 1)) + (install-trap (make + #:skip-count (- count 1) + #:single-shot #t + #:behaviour behaviour))) + +;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]] +;;; +;;; Install BEHAVIOUR to run on the COUNT'th next application, frame +;;; entry or frame exit. COUNT defaults to 1. If FILENAME is +;;; specified and not #f, only frames that begin in the named file are +;;; counted. + +(define* (at-step behaviour #:optional (count 1) filename (depth 1000)) + (install-trap (make + #:file-name filename + #:exit-depth depth + #:skip-count (- count 1) + #:single-shot #t + #:behaviour behaviour))) + +;; (or count (set! count 1)) +;; (letrec ((proc (lambda (trap-context) +;; ;; Behaviour whenever we enter or exit a frame. +;; (set! count (- count 1)) +;; (if (= count 0) +;; (begin +;; (remove-enter-frame-hook! step) +;; (remove-apply-frame-hook! step) +;; (behaviour trap-context))))) +;; (step (lambda (trap-context) +;; ;; Behaviour on frame entry: both execute the above +;; ;; and install it as an exit hook. +;; (if (or (not filename) +;; (equal? (frame-file-name (tc:frame trap-context)) +;; filename)) +;; (begin +;; (proc trap-context) +;; (at-exit (tc:depth trap-context) proc)))))) +;; (at-exit depth proc) +;; (add-enter-frame-hook! step) +;; (add-apply-frame-hook! step))) + +;;; at-next BEHAVIOUR [COUNT] +;;; +;;; Install a behaviour to run when we get to the COUNT'th next frame +;;; entry in the same source file as the current location. COUNT +;;; defaults to 1. If the current location has no filename, fall back +;;; silently to `at-entry' behaviour. + +;;; (ice-9 debugging steps) ends here. diff --git a/ice-9/debugging/trace.scm b/ice-9/debugging/trace.scm new file mode 100644 index 000000000..ad3015ddf --- /dev/null +++ b/ice-9/debugging/trace.scm @@ -0,0 +1,157 @@ +;;;; (ice-9 debugging trace) -- breakpoint trace behaviour + +;;; Copyright (C) 2002 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ice-9 debugging trace) + #:use-module (ice-9 debug) + #:use-module (ice-9 debugger) + #:use-module (ice-9 debugging ice-9-debugger-extensions) + #:use-module (ice-9 debugging steps) + #:use-module (ice-9 debugging traps) + #:export (trace-trap + trace-port + set-trace-layout + trace/pid + trace/stack-id + trace/stack-depth + trace/stack-real-depth + trace/stack + trace/source-file-name + trace/source-line + trace/source-column + trace/source + trace/type + trace/real? + trace/info + trace-at-exit + trace-until-exit)) + +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 debugger utils)))) + +(define trace-format-string #f) +(define trace-arg-procs #f) + +(define (set-trace-layout format-string . arg-procs) + (set! trace-format-string format-string) + (set! trace-arg-procs arg-procs)) + +(define (trace/pid trap-context) + (getpid)) + +(define (trace/stack-id trap-context) + (stack-id (tc:stack trap-context))) + +(define (trace/stack-depth trap-context) + (tc:depth trap-context)) + +(define (trace/stack-real-depth trap-context) + (tc:real-depth trap-context)) + +(define (trace/stack trap-context) + (format #f "~a:~a+~a" + (stack-id (tc:stack trap-context)) + (tc:real-depth trap-context) + (- (tc:depth trap-context) (tc:real-depth trap-context)))) + +(define (trace/source-file-name trap-context) + (cond ((frame->source-position (tc:frame trap-context)) => car) + (else ""))) + +(define (trace/source-line trap-context) + (cond ((frame->source-position (tc:frame trap-context)) => cadr) + (else 0))) + +(define (trace/source-column trap-context) + (cond ((frame->source-position (tc:frame trap-context)) => caddr) + (else 0))) + +(define (trace/source trap-context) + (cond ((frame->source-position (tc:frame trap-context)) + => + (lambda (pos) + (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos)))) + (else ""))) + +(define (trace/type trap-context) + (case (tc:type trap-context) + ((#:application) "APP") + ((#:evaluation) "EVA") + ((#:return) "RET") + ((#:error) "ERR") + (else "???"))) + +(define (trace/real? trap-context) + (if (frame-real? (tc:frame trap-context)) " " "t")) + +(define (trace/info trap-context) + (with-output-to-string + (lambda () + (if (memq (tc:type trap-context) '(#:application #:evaluation)) + ((if (tc:expression trap-context) + write-frame-short/expression + write-frame-short/application) (tc:frame trap-context)) + (begin + (display "=>") + (write (tc:return-value trap-context))))))) + +(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info) + +;;; trace-trap +;;; +;;; Trace the current location, and install a hook to trace the return +;;; value when we exit the current frame. + +(define (trace-trap trap-context) + (apply format + (trace-port) + trace-format-string + (map (lambda (arg-proc) + (arg-proc trap-context)) + trace-arg-procs))) + +(set! (behaviour-ordering trace-trap) 50) + +;;; trace-port +;;; +;;; The port to which trace information is printed. + +(define trace-port + (let ((port (current-output-port))) + (make-procedure-with-setter + (lambda () port) + (lambda (new) (set! port new))))) + +;;; trace-at-exit +;;; +;;; Trace return value on exit from the current frame. + +(define (trace-at-exit trap-context) + (at-exit (tc:depth trap-context) trace-trap)) + +;;; trace-until-exit +;;; +;;; Trace absolutely everything until exit from the current frame. + +(define (trace-until-exit trap-context) + (let ((step-trap (make #:behaviour trace-trap))) + (install-trap step-trap) + (at-exit (tc:depth trap-context) + (lambda (trap-context) + (uninstall-trap step-trap))))) + +;;; (ice-9 debugging trace) ends here. diff --git a/ice-9/debugging/traps.scm b/ice-9/debugging/traps.scm new file mode 100755 index 000000000..080d7bc31 --- /dev/null +++ b/ice-9/debugging/traps.scm @@ -0,0 +1,1037 @@ +;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface + +;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. +;;; Copyright (C) 2005 Neil Jerram +;;; +;; 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; This module provides an abstraction around Guile's low level trap +;;; handler interface; its aim is to make the low level trap mechanism +;;; shareable between the debugger and other applications, and to +;;; insulate the rest of the debugger code a bit from changes that may +;;; occur in the low level trap interface in future. + +(define-module (ice-9 debugging traps) + #:use-module (ice-9 regex) + #:use-module (oop goops) + #:use-module (oop goops describe) + #:use-module (ice-9 debugging trc) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:export (tc:type + tc:continuation + tc:expression + tc:return-value + tc:stack + tc:frame + tc:depth + tc:real-depth + tc:exit-depth + tc:fired-traps + ;; Interface for users of subclasses defined in + ;; this module. + add-trapped-stack-id! + remove-trapped-stack-id! + + + + + + + + install-trap + uninstall-trap + all-traps + get-trap + list-traps + trap-ordering + behaviour-ordering + throw->trap-context + on-lazy-handler-dispatch + ;; Interface for authors of new subclasses. + + + trap->behaviour + trap-runnable? + install-apply-frame-trap + install-breakpoint-trap + install-enter-frame-trap + install-exit-frame-trap + install-trace-trap + uninstall-apply-frame-trap + uninstall-breakpoint-trap + uninstall-enter-frame-trap + uninstall-exit-frame-trap + uninstall-trace-trap + frame->source-position + frame-file-name + without-traps + guile-trap-features) + #:re-export (make) + #:export-syntax (trap-here)) + +;; How to debug the debugging infrastructure, when needed. Grep for +;; "(trc " to find other symbols that can be passed to trc-add. +;; (trc-add 'after-gc-hook) + +;; In Guile 1.7 onwards, weak-vector and friends are provided by the +;; (ice-9 weak-vector) module. +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 weak-vector)))) + +;;; The current low level traps interface is as follows. +;;; +;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled +;;; by the `traps' setting of `(evaluator-traps-interface)' but also +;;; (and more relevant in most cases) by the `with-traps' procedure. +;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of +;;; its thunk parameter. +;;; +;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0 +;;; for the duration of the call, to avoid nasty recursive trapping +;;; loops. If a trap handler knows what it is doing, it can override +;;; this by `(trap-enable traps)'. +;;; +;;; The apply-frame handler is called when Guile is about to perform +;;; an application if EITHER the `apply-frame' evaluator trap option +;;; is set, OR the `trace' debug option is set and the procedure to +;;; apply has its `trace' procedure property set. The arguments +;;; passed are: +;;; +;;; - the symbol 'apply-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - a boolean indicating whether the application is tail-recursive. +;;; +;;; The enter-frame handler is called when the evaluator begins a new +;;; evaluation frame if EITHER the `enter-frame' evaluator trap option +;;; is set, OR the `breakpoints' debug option is set and the code to +;;; be evaluated has its `breakpoint' source property set. The +;;; arguments passed are: +;;; +;;; - the symbol 'enter-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - a boolean indicating whether the application is tail-recursive. +;;; +;;; - an unmemoized copy of the expression to be evaluated. +;;; +;;; If the `enter-frame' evaluator trap option is set, the enter-frame +;;; handler is also called when about to perform an application in +;;; SCM_APPLY, immediately before possibly calling the apply-frame +;;; handler. (I don't totally understand this.) In this case, the +;;; arguments passed are: +;;; +;;; - the symbol 'enter-frame +;;; +;;; - a continuation or debug object describing the current stack. +;;; +;;; The exit-frame handler is called when Guile exits an evaluation +;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if +;;; EITHER the `exit-frame' evaluator trap option is set, OR the +;;; `trace' debug option is set and the frame is marked as having been +;;; traced. The frame will be marked as having been traced if the +;;; apply-frame handler was called for this frame. (This is trickier +;;; than it sounds because of tail recursion: the same debug frame +;;; could have been used for multiple applications, only some of which +;;; were traced - I think.) The arguments passed are: +;;; +;;; - the symbol 'exit-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - the result of the evaluation or application. + +;;; {Trap Context} +;;; +;;; A trap context is a GOOPS object that encapsulates all the useful +;;; information about a particular trap. Encapsulating this +;;; information in a single object also allows us: +;;; +;;; - to defer the calculation of information that is time-consuming +;;; to calculate, such as the stack, and to cache such information so +;;; that it is only ever calculated once per trap +;;; +;;; - to pass all interesting information to trap behaviour procedures +;;; in a single parameter, which (i) is convenient and (ii) makes for +;;; a more future-proof interface. +;;; +;;; It also allows us - where very carefully documented! - to pass +;;; information from one behaviour procedure to another. + +(define-class () + ;; Information provided directly by the trap calls from the + ;; evaluator. The "type" slot holds a keyword indicating the type + ;; of the trap: one of #:evaluation, #:application, #:return, + ;; #:error. + (type #:getter tc:type + #:init-keyword #:type) + ;; The "continuation" slot holds the continuation (or debug object, + ;; if "cheap" traps are enabled, which is the default) at the point + ;; of the trap. For an error trap it is #f. + (continuation #:getter tc:continuation + #:init-keyword #:continuation) + ;; The "expression" slot holds the source code expression, for an + ;; evaluation trap. + (expression #:getter tc:expression + #:init-keyword #:expression + #:init-value #f) + ;; The "return-value" slot holds the return value, for a return + ;; trap, or the error args, for an error trap. + (return-value #:getter tc:return-value + #:init-keyword #:return-value + #:init-value #f) + ;; The list of trap objects which fired in this trap context. + (fired-traps #:getter tc:fired-traps + #:init-value '()) + ;; The set of symbols which, if one of them is set in the CAR of the + ;; handler-return-value slot, will cause the CDR of that slot to + ;; have an effect. + (handler-return-syms #:init-value '()) + ;; The value which the trap handler should return to the evaluator. + (handler-return-value #:init-value #f) + ;; Calculated and cached information. "stack" is the stack + ;; (computed from the continuation (or debug object) by make-stack, + ;; or else (in the case of an error trap) by (make-stack #t ...). + (stack #:init-value #f) + (frame #:init-value #f) + (depth #:init-value #f) + (real-depth #:init-value #f) + (exit-depth #:init-value #f)) + +(define-method (tc:stack (ctx )) + (or (slot-ref ctx 'stack) + (let ((stack (make-stack (tc:continuation ctx)))) + (slot-set! ctx 'stack stack) + stack))) + +(define-method (tc:frame (ctx )) + (or (slot-ref ctx 'frame) + (let ((frame (cond ((tc:continuation ctx) => last-stack-frame) + (else (stack-ref (tc:stack ctx) 0))))) + (slot-set! ctx 'frame frame) + frame))) + +(define-method (tc:depth (ctx )) + (or (slot-ref ctx 'depth) + (let ((depth (stack-length (tc:stack ctx)))) + (slot-set! ctx 'depth depth) + depth))) + +(define-method (tc:real-depth (ctx )) + (or (slot-ref ctx 'real-depth) + (let* ((stack (tc:stack ctx)) + (real-depth (apply + + (map (lambda (i) + (if (frame-real? (stack-ref stack i)) + 1 + 0)) + (iota (tc:depth ctx)))))) + (slot-set! ctx 'real-depth real-depth) + real-depth))) + +(define-method (tc:exit-depth (ctx )) + (or (slot-ref ctx 'exit-depth) + (let* ((stack (tc:stack ctx)) + (depth (tc:depth ctx)) + (exit-depth (let loop ((exit-depth depth)) + (if (or (zero? exit-depth) + (frame-real? (stack-ref stack + (- depth + exit-depth)))) + exit-depth + (loop (- exit-depth 1)))))) + (slot-set! ctx 'exit-depth exit-depth) + exit-depth))) + +;;; {Stack IDs} +;;; +;;; Mechanism for limiting trapping to contexts whose stack ID matches +;;; one of a registered set. The default is for traps to fire +;;; regardless of stack ID. + +(define trapped-stack-ids (list #t)) +(define all-stack-ids-trapped? #t) + +(define (add-trapped-stack-id! id) + "Add ID to the set of stack ids for which traps are active. +If `#t' is in this set, traps are active regardless of stack context. +To remove ID again, use `remove-trapped-stack-id!'. If you add the +same ID twice using `add-trapped-stack-id!', you will need to remove +it twice." + (set! trapped-stack-ids (cons id trapped-stack-ids)) + (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) + +(define (remove-trapped-stack-id! id) + "Remove ID from the set of stack ids for which traps are active." + (set! trapped-stack-ids (delq1! id trapped-stack-ids)) + (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) + +(define (trap-here? cont) + ;; Return true if the stack id of the specified continuation (or + ;; debug object) is in the set that we should trap for; otherwise + ;; false. + (or all-stack-ids-trapped? + (memq (stack-id cont) trapped-stack-ids))) + +;;; {Global State} +;;; +;;; Variables tracking registered handlers, relevant procedures, and +;;; what's turned on as regards the evaluator's debugging options. + +(define enter-frame-traps '()) +(define apply-frame-traps '()) +(define exit-frame-traps '()) +(define breakpoint-traps '()) +(define trace-traps '()) + +(define (non-null? hook) + (not (null? hook))) + +;; The low level frame handlers must all be initialized to something +;; harmless. Otherwise we hit a problem immediately when trying to +;; enable one of these handlers. +(trap-set! enter-frame-handler noop) +(trap-set! apply-frame-handler noop) +(trap-set! exit-frame-handler noop) + +(define set-debug-and-trap-options + (let ((dopts (debug-options)) + (topts (evaluator-traps-interface)) + (setting (lambda (key opts) + (let ((l (memq key opts))) + (and l + (not (null? (cdr l))) + (cadr l))))) + (debug-set-boolean! (lambda (key value) + ((if value debug-enable debug-disable) key))) + (trap-set-boolean! (lambda (key value) + ((if value trap-enable trap-disable) key)))) + (let ((save-debug (memq 'debug dopts)) + (save-trace (memq 'trace dopts)) + (save-breakpoints (memq 'breakpoints dopts)) + (save-enter-frame (memq 'enter-frame topts)) + (save-apply-frame (memq 'apply-frame topts)) + (save-exit-frame (memq 'exit-frame topts)) + (save-enter-frame-handler (setting 'enter-frame-handler topts)) + (save-apply-frame-handler (setting 'apply-frame-handler topts)) + (save-exit-frame-handler (setting 'exit-frame-handler topts))) + (lambda () + (let ((need-trace (non-null? trace-traps)) + (need-breakpoints (non-null? breakpoint-traps)) + (need-enter-frame (non-null? enter-frame-traps)) + (need-apply-frame (non-null? apply-frame-traps)) + (need-exit-frame (non-null? exit-frame-traps))) + (debug-set-boolean! 'debug + (or need-trace + need-breakpoints + need-enter-frame + need-apply-frame + need-exit-frame + save-debug)) + (debug-set-boolean! 'trace + (or need-trace + save-trace)) + (debug-set-boolean! 'breakpoints + (or need-breakpoints + save-breakpoints)) + (trap-set-boolean! 'enter-frame + (or need-enter-frame + save-enter-frame)) + (trap-set-boolean! 'apply-frame + (or need-apply-frame + save-apply-frame)) + (trap-set-boolean! 'exit-frame + (or need-exit-frame + save-exit-frame)) + (trap-set! enter-frame-handler + (cond ((or need-breakpoints + need-enter-frame) + enter-frame-handler) + (else save-enter-frame-handler))) + (trap-set! apply-frame-handler + (cond ((or need-trace + need-apply-frame) + apply-frame-handler) + (else save-apply-frame-handler))) + (trap-set! exit-frame-handler + (cond ((or need-exit-frame) + exit-frame-handler) + (else save-exit-frame-handler)))) + ;;(write (evaluator-traps-interface)) + *unspecified*)))) + +(define (enter-frame-handler key cont . args) + ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an + ;; unmemoized copy of the source expression. For an application + ;; entry, ARGS is empty. + (if (trap-here? cont) + (let* ((application-entry? (null? args)) + (trap-context (make + #:type #:evaluation + #:continuation cont + #:expression (if application-entry? + #f + (cadr args))))) + (trc 'enter-frame-handler) + (if (and (not application-entry?) + (memq 'tweaking guile-trap-features)) + (slot-set! trap-context 'handler-return-syms '(instead))) + (run-traps (if application-entry? + enter-frame-traps + (append enter-frame-traps breakpoint-traps)) + trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define (apply-frame-handler key cont tail?) + (if (trap-here? cont) + (let ((trap-context (make + #:type #:application + #:continuation cont))) + (trc 'apply-frame-handler tail?) + (run-traps (append apply-frame-traps trace-traps) trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define (exit-frame-handler key cont retval) + (if (trap-here? cont) + (let ((trap-context (make + #:type #:return + #:continuation cont + #:return-value retval))) + (trc 'exit-frame-handler retval (tc:depth trap-context)) + (if (memq 'tweaking guile-trap-features) + (slot-set! trap-context 'handler-return-syms '(instead))) + (run-traps exit-frame-traps trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define-macro (trap-installer trap-list) + `(lambda (trap) + (set! ,trap-list (cons trap ,trap-list)) + (set-debug-and-trap-options))) + +(define install-enter-frame-trap (trap-installer enter-frame-traps)) +(define install-apply-frame-trap (trap-installer apply-frame-traps)) +(define install-exit-frame-trap (trap-installer exit-frame-traps)) +(define install-breakpoint-trap (trap-installer breakpoint-traps)) +(define install-trace-trap (trap-installer trace-traps)) + +(define-macro (trap-uninstaller trap-list) + `(lambda (trap) + (or (memq trap ,trap-list) + (error "Trap list does not include the specified trap")) + (set! ,trap-list (delq1! trap ,trap-list)) + (set-debug-and-trap-options))) + +(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps)) +(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps)) +(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps)) +(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps)) +(define uninstall-trace-trap (trap-uninstaller trace-traps)) + +(define trap-ordering (make-object-property)) +(define behaviour-ordering (make-object-property)) + +(define (run-traps traps trap-context) + (let ((behaviours (apply append + (map (lambda (trap) + (trap->behaviour trap trap-context)) + (sort traps + (lambda (t1 t2) + (< (or (trap-ordering t1) 0) + (or (trap-ordering t2) 0)))))))) + (for-each (lambda (proc) + (proc trap-context)) + (sort (delete-duplicates behaviours) + (lambda (b1 b2) + (< (or (behaviour-ordering b1) 0) + (or (behaviour-ordering b2) 0))))))) + +;;; {Pseudo-Traps for Non-Trap Events} + +;;; Once there is a body of code to do with responding to (debugging, +;;; tracing, etc.) traps, it makes sense to be able to leverage that +;;; same code for certain events that are trap-like, but not actually +;;; traps in the sense of the calls made by libguile's evaluator. + +;;; The main example of this is when an error is signalled. Guile +;;; doesn't yet have a 100% reliable way of hooking into errors, but +;;; in practice most errors go through a lazy-catch whose handler is +;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn +;;; calls default-lazy-handler. So we can present most errors as +;;; pseudo-traps by modifying default-lazy-handler. + +(define default-default-lazy-handler default-lazy-handler) + +(define (throw->trap-context key args . stack-args) + (let ((ctx (make + #:type #:error + #:continuation #f + #:return-value (cons key args)))) + (slot-set! ctx 'stack + (let ((caller-stack (and (= (length stack-args) 1) + (car stack-args)))) + (if (stack? caller-stack) + caller-stack + (apply make-stack #t stack-args)))) + ctx)) + +(define (on-lazy-handler-dispatch behaviour . ignored-keys) + (set! default-lazy-handler + (if behaviour + (lambda (key . args) + (or (memq key ignored-keys) + (behaviour (throw->trap-context key + args + lazy-handler-dispatch))) + (apply default-default-lazy-handler key args)) + default-default-lazy-handler))) + +;;; {Trap Classes} + +;;; Class: +;;; +;;; is the base class for traps. Any actual trap should be an +;;; instance of a class derived from , not of itself, +;;; because there is no base class method for the install-trap, +;;; trap-runnable? and uninstall-trap GFs. +(define-class () + ;; "number" slot: the number of this trap (assigned automatically). + (number) + ;; "installed" slot: whether this trap is installed. + (installed #:init-value #f) + ;; "condition" slot: if non-#f, this is a thunk which is called when + ;; the trap fires, to determine whether trap processing should + ;; proceed any further. + (condition #:init-value #f #:init-keyword #:condition) + ;; "skip-count" slot: a count of valid (after "condition" + ;; processing) firings of this trap to skip. + (skip-count #:init-value 0 #:init-keyword #:skip-count) + ;; "single-shot" slot: if non-#f, this trap is removed after it has + ;; successfully fired (after "condition" and "skip-count" + ;; processing) for the first time. + (single-shot #:init-value #f #:init-keyword #:single-shot) + ;; "behaviour" slot: procedure or list of procedures to call + ;; (passing the trap context as parameter) if we finally decide + ;; (after "condition" and "skip-count" processing) to run this + ;; trap's behaviour. + (behaviour #:init-value '() #:init-keyword #:behaviour) + ;; "repeat-identical-behaviour" slot: normally, if multiple + ;; objects are triggered by the same low level trap, and they + ;; request the same behaviour, it's only useful to do that behaviour + ;; once (per low level trap); so by default multiple requests for + ;; the same behaviour are coalesced. If this slot is non-#f, the + ;; contents of the "behaviour" slot are uniquified so that they + ;; avoid being coalesced in this way. + (repeat-identical-behaviour #:init-value #f + #:init-keyword #:repeat-identical-behaviour) + ;; "observer" slot: this is a procedure that is called with one + ;; EVENT argument when the trap status changes in certain + ;; interesting ways, currently the following. (1) When the trap is + ;; uninstalled because of the target becoming inaccessible; EVENT in + ;; this case is 'target-gone. + (observer #:init-value #f #:init-keyword #:observer)) + +(define last-assigned-trap-number 0) +(define all-traps (make-weak-value-hash-table 7)) + +(define-method (initialize (trap ) initargs) + (next-method) + ;; Assign a trap number, and store in the hash of all traps. + (set! last-assigned-trap-number (+ last-assigned-trap-number 1)) + (slot-set! trap 'number last-assigned-trap-number) + (hash-set! all-traps last-assigned-trap-number trap) + ;; Listify the behaviour slot, if not a list already. + (let ((behaviour (slot-ref trap 'behaviour))) + (if (procedure? behaviour) + (slot-set! trap 'behaviour (list behaviour))))) + +(define-generic install-trap) ; provided mostly by subclasses +(define-generic uninstall-trap) ; provided mostly by subclasses +(define-generic trap->behaviour) ; provided by +(define-generic trap-runnable?) ; provided by subclasses + +(define-method (install-trap (trap )) + (if (slot-ref trap 'installed) + (error "Trap is already installed")) + (slot-set! trap 'installed #t)) + +(define-method (uninstall-trap (trap )) + (or (slot-ref trap 'installed) + (error "Trap is not installed")) + (slot-set! trap 'installed #f)) + +;;; uniquify-behaviour +;;; +;;; Uniquify BEHAVIOUR by wrapping it in a new lambda. +(define (uniquify-behaviour behaviour) + (lambda (trap-context) + (behaviour trap-context))) + +;;; trap->behaviour +;;; +;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of +;;; behaviour procs to call with TRAP-CONTEXT as a parameter. +;;; Otherwise return the empty list. +(define-method (trap->behaviour (trap ) (trap-context )) + (if (and + ;; Check that the trap is runnable. Runnability is implemented + ;; by the subclass and allows us to check, for example, that + ;; the procedure being applied in an apply-frame trap matches + ;; this trap's procedure. + (trap-runnable? trap trap-context) + ;; Check the additional condition, if specified. + (let ((condition (slot-ref trap 'condition))) + (or (not condition) + ((condition)))) + ;; Check for a skip count. + (let ((skip-count (slot-ref trap 'skip-count))) + (if (zero? skip-count) + #t + (begin + (slot-set! trap 'skip-count (- skip-count 1)) + #f)))) + ;; All checks passed, so we will return the contents of this + ;; trap's behaviour slot. + (begin + ;; First, though, remove this trap if its single-shot slot + ;; indicates that it should fire only once. + (if (slot-ref trap 'single-shot) + (uninstall-trap trap)) + ;; Add this trap object to the context's list of traps which + ;; fired here. + (slot-set! trap-context 'fired-traps + (cons trap (tc:fired-traps trap-context))) + ;; Return trap behaviour, uniquified if necessary. + (if (slot-ref trap 'repeat-identical-behaviour) + (map uniquify-behaviour (slot-ref trap 'behaviour)) + (slot-ref trap 'behaviour))) + '())) + +;;; Class: +;;; +;;; An installed instance of triggers on invocation +;;; of a specific procedure. +(define-class () + ;; "procedure" slot: the procedure to trap on. This is implemented + ;; virtually, using the following weak vector slot, so as to avoid + ;; this trap preventing the GC of the target procedure. + (procedure #:init-keyword #:procedure + #:allocation #:virtual + #:slot-ref + (lambda (trap) + (vector-ref (slot-ref trap 'procedure-wv) 0)) + #:slot-set! + (lambda (trap proc) + (if (slot-bound? trap 'procedure-wv) + (vector-set! (slot-ref trap 'procedure-wv) 0 proc) + (slot-set! trap 'procedure-wv (weak-vector proc))))) + (procedure-wv)) + +;; Customization of the initialize method: set up to handle what +;; should happen when the procedure is GC'd. +(define-method (initialize (trap ) initargs) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (existing-traps (volatile-target-traps proc))) + ;; If this is the target's first trap, give the target procedure + ;; to the volatile-target-guardian, so we can find out if it + ;; becomes inaccessible. + (or existing-traps (volatile-target-guardian proc)) + ;; Add this trap to the target procedure's list of traps. + (set! (volatile-target-traps proc) + (cons trap (or existing-traps '()))))) + +(define procedure-trace-count (make-object-property)) + +(define-method (install-trap (trap )) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (trace-count (or (procedure-trace-count proc) 0))) + (set-procedure-property! proc 'trace #t) + (set! (procedure-trace-count proc) (+ trace-count 1))) + (install-trace-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (trace-count (or (procedure-trace-count proc) 0))) + (if (= trace-count 1) + (set-procedure-property! proc 'trace #f)) + (set! (procedure-trace-count proc) (- trace-count 1))) + (uninstall-trace-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (eq? (slot-ref trap 'procedure) + (frame-procedure (tc:frame trap-context)))) + +;;; Class: +;;; +;;; An installed instance of triggers on stack frame exit +;;; past a specified stack depth. +(define-class () + ;; "depth" slot: the reference depth for the trap. + (depth #:init-keyword #:depth)) + +(define-method (install-trap (trap )) + (next-method) + (install-exit-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-exit-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (<= (tc:exit-depth trap-context) + (slot-ref trap 'depth))) + +;;; Class: +;;; +;;; An installed instance of triggers on any frame entry. +(define-class ()) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + #t) + +;;; Class: +;;; +;;; An installed instance of triggers on any procedure +;;; application. +(define-class ()) + +(define-method (install-trap (trap )) + (next-method) + (install-apply-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-apply-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + #t) + +;;; Class: +;;; +;;; An installed instance of triggers on the next frame +;;; entry, exit or application, optionally with source location inside +;;; a specified file. +(define-class () + ;; "file-name" slot: if non-#f, indicates that this trap should + ;; trigger only for steps in source code from the specified file. + (file-name #:init-value #f #:init-keyword #:file-name) + ;; "exit-depth" slot: when non-#f, indicates that the next step may + ;; be a frame exit past this depth; otherwise, indicates that the + ;; next step must be an application or a frame entry. + (exit-depth #:init-value #f #:init-keyword #:exit-depth)) + +(define-method (initialize (trap ) initargs) + (next-method) + (slot-set! trap 'depth (slot-ref trap 'exit-depth))) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap) + (install-apply-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap) + (uninstall-apply-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (if (eq? (tc:type trap-context) #:return) + ;; We're in the context of an exit-frame trap. Trap should only + ;; be run if exit-depth is set and this exit-frame has returned + ;; past the set depth. + (and (slot-ref trap 'exit-depth) + (next-method) + ;; OK to run the trap here, but we should first reset the + ;; exit-depth slot to indicate that the step after this one + ;; must be an application or frame entry. + (begin + (slot-set! trap 'exit-depth #f) + #t)) + ;; We're in the context of an application or frame entry trap. + ;; Check whether trap is limited to a specified file. + (let ((file-name (slot-ref trap 'file-name))) + (and (or (not file-name) + (equal? (frame-file-name (tc:frame trap-context)) file-name)) + ;; Trap should run here, but we should also set exit-depth to + ;; the current stack length, so that - if we don't stop at any + ;; other steps first - the next step shows the return value of + ;; the current application or evaluation. + (begin + (slot-set! trap 'exit-depth (tc:depth trap-context)) + (slot-set! trap 'depth (tc:depth trap-context)) + #t))))) + +(define (frame->source-position frame) + (let ((source (if (frame-procedure? frame) + (or (frame-source frame) + (let ((proc (frame-procedure frame))) + (and proc + (procedure? proc) + (procedure-source proc)))) + (frame-source frame)))) + (and source + (string? (source-property source 'filename)) + (list (source-property source 'filename) + (source-property source 'line) + (source-property source 'column))))) + +(define (frame-file-name frame) + (cond ((frame->source-position frame) => car) + (else #f))) + +;;; Class: +;;; +;;; An installed instance of triggers upon evaluation of +;;; a specified source expression. +(define-class () + ;; "expression" slot: the expression to trap on. This is + ;; implemented virtually, using the following weak vector slot, so + ;; as to avoid this trap preventing the GC of the target source + ;; code. + (expression #:init-keyword #:expression + #:allocation #:virtual + #:slot-ref + (lambda (trap) + (vector-ref (slot-ref trap 'expression-wv) 0)) + #:slot-set! + (lambda (trap expr) + (if (slot-bound? trap 'expression-wv) + (vector-set! (slot-ref trap 'expression-wv) 0 expr) + (slot-set! trap 'expression-wv (weak-vector expr))))) + (expression-wv) + ;; source property slots - for internal use only + (filename) + (line) + (column)) + +;; Customization of the initialize method: get and save the +;; expression's source properties, or signal an error if it doesn't +;; have the necessary properties. +(define-method (initialize (trap ) initargs) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (filename (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column)) + (existing-traps (volatile-target-traps expr))) + (or (and filename line column) + (error "Specified source does not have the necessary properties" + filename line column)) + (slot-set! trap 'filename filename) + (slot-set! trap 'line line) + (slot-set! trap 'column column) + ;; If this is the target's first trap, give the target expression + ;; to the volatile-target-guardian, so we can find out if it + ;; becomes inaccessible. + (or existing-traps (volatile-target-guardian expr)) + ;; Add this trap to the target expression's list of traps. + (set! (volatile-target-traps expr) + (cons trap (or existing-traps '()))))) + +;; Just in case more than one trap is installed on the same source +;; expression ... so that we can still get the setting and resetting +;; of the 'breakpoint source property correct. +(define source-breakpoint-count (make-object-property)) + +(define-method (install-trap (trap )) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (breakpoint-count (or (source-breakpoint-count expr) 0))) + (set-source-property! expr 'breakpoint #t) + (set! (source-breakpoint-count expr) (+ breakpoint-count 1))) + (install-breakpoint-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (breakpoint-count (or (source-breakpoint-count expr) 0))) + (if (= breakpoint-count 1) + (set-source-property! expr 'breakpoint #f)) + (set! (source-breakpoint-count expr) (- breakpoint-count 1))) + (uninstall-breakpoint-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (or (eq? (slot-ref trap 'expression) + (tc:expression trap-context)) + (let ((trap-location (frame->source-position (tc:frame trap-context)))) + (and trap-location + (string=? (car trap-location) (slot-ref trap 'filename)) + (= (cadr trap-location) (slot-ref trap 'line)) + (= (caddr trap-location) (slot-ref trap 'column)))))) + +;; (trap-here EXPRESSION . OPTIONS) +(define trap-here + (procedure->memoizing-macro + (lambda (expr env) + (let ((trap (apply make + + #:expression expr + (local-eval `(list ,@(cddr expr)) + env)))) + (install-trap trap) + (set-car! expr 'begin) + (set-cdr! (cdr expr) '()) + expr)))) + +;;; Class: +;;; +;;; An installed instance of triggers on entry to a +;;; frame with a more-or-less precisely specified source location. +(define-class () + ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to + ;; trap in. + (file-regexp #:init-keyword #:file-regexp) + ;; "line" and "column" slots: position to trap at (0-based). + (line #:init-value #f #:init-keyword #:line) + (column #:init-value #f #:init-keyword #:column) + ;; "compiled-regexp" slot - self explanatory, internal use only + (compiled-regexp)) + +(define-method (initialize (trap ) initargs) + (next-method) + (slot-set! trap 'compiled-regexp + (make-regexp (slot-ref trap 'file-regexp)))) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (and-let* ((trap-location (frame->source-position (tc:frame trap-context))) + (tcline (cadr trap-location)) + (tccolumn (caddr trap-location))) + (and (= tcline (slot-ref trap 'line)) + (= tccolumn (slot-ref trap 'column)) + (regexp-exec (slot-ref trap 'compiled-regexp) + (car trap-location) 0)))) + +;;; {Misc Trap Utilities} + +(define (get-trap number) + (hash-ref all-traps number)) + +(define (list-traps) + (for-each describe + (map cdr (sort (hash-fold acons '() all-traps) + (lambda (x y) (< (car x) (car y))))))) + +;;; {Volatile Traps} +;;; +;;; Some traps are associated with Scheme objects that are likely to +;;; be GC'd, such as procedures and read expressions. When those +;;; objects are GC'd, we want to allow their traps to evaporate as +;;; well, or at least not to prevent them from doing so because they +;;; are (now pointlessly) included on the various installed trap +;;; lists. + +;; An object property that maps each volatile target to the list of +;; traps that are installed on it. +(define volatile-target-traps (make-object-property)) + +;; A guardian that tells us when a volatile target is no longer +;; accessible. +(define volatile-target-guardian (make-guardian)) + +;; An after GC hook that checks for newly inaccessible targets. +(add-hook! after-gc-hook + (lambda () + (trc 'after-gc-hook) + (let loop ((target (volatile-target-guardian))) + (if target + ;; We have a target which is now inaccessible. Get + ;; the list of traps installed on it. + (begin + (trc 'after-gc-hook "got target") + ;; Uninstall all the traps that are installed on + ;; this target. + (for-each (lambda (trap) + (trc 'after-gc-hook "got trap") + ;; If the trap is still installed, + ;; uninstall it. + (if (slot-ref trap 'installed) + (uninstall-trap trap)) + ;; If the trap has an observer, tell + ;; it that the target has gone. + (cond ((slot-ref trap 'observer) + => + (lambda (proc) + (trc 'after-gc-hook "call obs") + (proc 'target-gone))))) + (or (volatile-target-traps target) '())) + ;; Check for any more inaccessible targets. + (loop (volatile-target-guardian))))))) + +(define (without-traps thunk) + (with-traps (lambda () + (trap-disable 'traps) + (thunk)))) + +(define guile-trap-features + ;; Helper procedure, to test whether a specific possible Guile + ;; feature is supported. + (let ((supported? + (lambda (test-feature) + (case test-feature + ((tweaking) + ;; Tweaking is supported if the description of the cheap + ;; traps option includes the word "obsolete", or if the + ;; option isn't there any more. + (and (string>=? (version) "1.7") + (let ((cheap-opt-desc + (assq 'cheap (debug-options-interface 'help)))) + (or (not cheap-opt-desc) + (string-match "obsolete" (caddr cheap-opt-desc)))))) + (else + (error "Unexpected feature name:" test-feature)))))) + ;; Compile the list of actually supported features from all + ;; possible features. + (let loop ((possible-features '(tweaking)) + (actual-features '())) + (if (null? possible-features) + (reverse! actual-features) + (let ((test-feature (car possible-features))) + (loop (cdr possible-features) + (if (supported? test-feature) + (cons test-feature actual-features) + actual-features))))))) + +;; Make sure that traps are enabled. +(trap-enable 'traps) + +;;; (ice-9 debugging traps) ends here. diff --git a/ice-9/debugging/trc.scm b/ice-9/debugging/trc.scm new file mode 100644 index 000000000..9e95d7e5c --- /dev/null +++ b/ice-9/debugging/trc.scm @@ -0,0 +1,63 @@ +;;;; (ice-9 debugging trc) -- tracing for Guile debugger code + +;;; Copyright (C) 2002, 2004 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ice-9 debugging trc) + #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port)) + +(define *syms* #f) + +(define (trc-set! syms) + (set! *syms* syms)) + +(define (trc-syms . syms) + (trc-set! syms)) + +(define (trc-all) + (trc-set! #f)) + +(define (trc-none) + (trc-set! '())) + +(define (trc-add sym) + (trc-set! (cons sym *syms*))) + +(define (trc-remove sym) + (trc-set! (delq1! sym *syms*))) + +(define (trc sym . args) + (if (or (not *syms*) + (memq sym *syms*)) + (let ((port (trc-port))) + (write sym port) + (display ":" port) + (for-each (lambda (arg) + (display " " port) + (write arg port)) + args) + (newline port)))) + +(define trc-port + (let ((port (current-error-port))) + (make-procedure-with-setter + (lambda () port) + (lambda (p) (set! port p))))) + +;; Default to no tracing. +(trc-none) + +;;; (ice-9 debugging trc) ends here. From e741cbb2ed422a856a1ef40a64afbcd9b309a22c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 13:43:09 +0000 Subject: [PATCH 021/116] .cvsignore file --- ice-9/debugging/.cvsignore | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 ice-9/debugging/.cvsignore diff --git a/ice-9/debugging/.cvsignore b/ice-9/debugging/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/ice-9/debugging/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in From 1e2346ae9330a4c30fdce7f5da0893a3c07a6435 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 14:19:44 +0000 Subject: [PATCH 022/116] * configure.in: Generate Makefile for emacs subdir. * Makefile.am (SUBDIRS): Add emacs subdir. * configure.in: Generate Makefile for ice-9/debugging subdir. --- ChangeLog | 6 +++++- Makefile.am | 2 +- configure.in | 1 + 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9739d8e9f..4e6ed04e3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,10 @@ 2006-08-18 Neil Jerram - * configure.in: Generate Makefile for ice-9/debugging. + * configure.in: Generate Makefile for emacs subdir. + + * Makefile.am (SUBDIRS): Add emacs subdir. + + * configure.in: Generate Makefile for ice-9/debugging subdir. 2006-06-13 Ludovic Courts diff --git a/Makefile.am b/Makefile.am index a4da8500e..aba01bf7c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,7 @@ AUTOMAKE_OPTIONS = 1.5 -SUBDIRS = oop libguile ice-9 guile-config guile-readline \ +SUBDIRS = oop libguile ice-9 guile-config guile-readline emacs \ scripts srfi doc examples test-suite benchmark-suite lang am bin_SCRIPTS = guile-tools diff --git a/configure.in b/configure.in index c216c7ef1..798dbbee7 100644 --- a/configure.in +++ b/configure.in @@ -1220,6 +1220,7 @@ AC_CONFIG_FILES([ doc/r5rs/Makefile doc/ref/Makefile doc/tutorial/Makefile + emacs/Makefile examples/Makefile examples/box-dynamic-module/Makefile examples/box-dynamic/Makefile From fce4b99e9e7c1bbbb2e8afc23ab7f13971340116 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 14:21:23 +0000 Subject: [PATCH 023/116] * gds-server.el (gds-start-server): Change "ossau" to "ice-9". * gds-scheme.el (gds-start-utility-guile): Change "ossau" to "ice-9". --- emacs/ChangeLog | 7 +++++++ emacs/gds-scheme.el | 2 +- emacs/gds-server.el | 4 ++-- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 2396af25c..6786c2844 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,10 @@ +2006-08-18 Neil Jerram + + * gds-server.el (gds-start-server): Change "ossau" to "ice-9". + + * gds-scheme.el (gds-start-utility-guile): Change "ossau" to + "ice-9". + 2006-06-19 Neil Jerram * Makefile.am: New file. diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index f5d235edf..8fb4ca2af 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -194,7 +194,7 @@ Emacs to display an error or trap so that the user can debug it." (let* ((procname (format "gds-util[%d]" gds-last-utility-number)) (code (format "(begin %s - (use-modules (ossau gds-client)) + (use-modules (ice-9 gds-client)) (run-utility))" (if gds-scheme-directory (concat "(set! %load-path (cons " diff --git a/emacs/gds-server.el b/emacs/gds-server.el index cca23c836..722e613db 100644 --- a/emacs/gds-server.el +++ b/emacs/gds-server.el @@ -26,7 +26,7 @@ :group 'scheme) -;;;; Communication with the (ossau gds-server) subprocess. +;;;; Communication with the (ice-9 gds-server) subprocess. ;; Subprocess output goes into the `*GDS Process*' buffer, and ;; is then read from there one form at a time. `gds-read-cursor' is @@ -54,7 +54,7 @@ the same as the process name." (erase-buffer) (let* ((code (format "(begin %s - (use-modules (ossau gds-server)) + (use-modules (ice-9 gds-server)) (run-server %d))" (if gds-scheme-directory (concat "(set! %load-path (cons " From 01d2ee158552a0be1cc22c6a2eda33486bcfef02 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 23 Aug 2006 22:11:24 +0000 Subject: [PATCH 024/116] (Using Guile in Emacs): New text about available Emacs libraries. (GDS Introduction): New node, containing GDS-specific introductory text. --- doc/ref/ChangeLog | 7 ++ doc/ref/scheme-using.texi | 188 +++++++++++++++++++++++++++----------- 2 files changed, 143 insertions(+), 52 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index b75cdf259..a73eb3345 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2006-08-23 Neil Jerram + + * scheme-using.texi (Using Guile in Emacs): New text about + available Emacs libraries. + (GDS Introduction): New node, containing GDS-specific introductory + text. + 2006-08-18 Neil Jerram * scheme-using.texi (Using Guile in Emacs): Unignore extra GDS diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index fc6821fc0..6eac11aee 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -361,24 +361,121 @@ Exit the debugger. @node Using Guile in Emacs @section Using Guile in Emacs -The Guile distribution includes a rich environment for working on Guile -Scheme code within Emacs. The idea of this environment is to allow you -to work on Guile Scheme code in the same kind of way that Emacs allows -you to work on Emacs Lisp code: providing easy access to help, -evaluating arbitrary fragments of code, a nice debugging interface, and -so on.@footnote{You can also, of course, run a Guile session in Emacs -simply by typing ``guile'' in a @code{*shell*} buffer. The environment -described here provides a much better integration than that, though.} +There are quite a few options for working on Guile Scheme code in +Emacs. The simplest options are to use Emacs's standard +@code{scheme-mode} for editing code, and to run the interpreter when you +need it by typing ``guile'' at the prompt of a @code{*shell*} buffer, +but there are Emacs libraries available which add various bells and +whistles to this. The following diagram shows these libraries and how +they relate to each other, with the arrows indicating ``builds on'' or +``extends''. For example, the Quack library builds on cmuscheme, which +in turn builds on the standard scheme mode. -The thinking behind this environment is that you will usually be doing -one of two things. +@example + scheme + ^ + | + .-----+-----. + | | + cmuscheme xscheme + ^ + | + .-----+-----. + | | + Quack GDS +@end example + +@dfn{scheme}, written by Bill Rozas and Dave Love, is Emacs's standard +mode for Scheme code files. It provides Scheme-sensitive syntax +highlighting, parenthesis matching, indentation and so on. + +@dfn{cmuscheme}, written by Olin Shivers, provides a comint-based Scheme +interaction buffer, so that you can run an interpreter more directly +than with the @code{*shell*} buffer approach by typing @kbd{@key{M-x} +run-scheme}. It also extends @code{scheme-mode} so that there are key +presses for sending selected bits of code from a Scheme buffer to this +interpreter. This means that when you are writing some code and want to +check what an expression evaluates to, you can easily select that code +and send it to the interpreter for evaluation, then switch to the +interpreter to see what the result is. cmuscheme is included in the +standard Emacs distribution. + +@dfn{Quack}, written by Neil Van Dyke, adds a number of incremental +improvements to the scheme/cmuscheme combination: convenient menu +entries for looking up Scheme-related references (such as the SRFIs); +enhanced indentation rules that are customized for particular Scheme +interpreters, including Guile; an enhanced version of the +@code{run-scheme} command that knows the names of the common Scheme +interpreters and remembers which one you used last time; and so on. +Quack is available from @uref{http://www.neilvandyke.org/quack}. + +@dfn{GDS}, written by Neil Jerram, also builds on the scheme/cmuscheme +combination, but with a fundamental change to the way that Scheme code +fragments are sent to the interpreter for evaluation. cmuscheme and +Quack send code fragments to the interpreter's standard input, on the +assumption that the interpreter is expecting to read Scheme expressions +there, and then monitor the interpreter's standard output to infer what +the result of the evaluation is. GDS doesn't use standard input and +output like this. Instead, it sets up a socket connection between the +Scheme interpreter and Emacs, and sends and receives messages using a +simple protocol through this socket. The messages include requests to +evaluate Scheme code, and responses conveying the results of an +evaluation, thus providing similar function to cmuscheme or Quack; they +also include requests for setting breakpoints, stack exploration and +debugging, which go beyond what cmuscheme or Quack can do. The price of +this extra power, however, is that GDS is Guile-specific. GDS requires +the Scheme interpreter, or any program that GDS is debugging, to run +some GDS-specific library code; currently this code is written as a +Guile module and uses a lot of debugging-related features that are +specific to Guile. GDS is now included in the Guile distribution; for +previous Guile releases (1.8.x and earlier) it can be obtained as part +of the @code{guile-debugging} package from +@uref{http://www.ossau.uklinux.net/guile}. + +Finally, @dfn{xscheme} is similar to cmuscheme -- in that it starts up a +Scheme interaction process and sends commands to that process's standard +input -- and to GDS -- in that it has support beyond cmuscheme or Quack +for exploring the Scheme stack when an error has occurred -- but is +implemented specifically for MIT/GNU Scheme. Hence it isn't really +relevant to Guile work in Emacs, except as a reference for useful +features that could be implemented in one of the other libraries +mentioned here. + +In summary, the ``best'' current choice for working on Guile code in +Emacs is either Quack or GDS, depending on which of these libraries' +features you find most important. For more information on Quack, please +see the website referenced above. GDS is documented further in the rest +of this section. + +@menu +* GDS Introduction:: +* GDS Getting Started:: +* How To Use GDS:: +* Displaying the Scheme Stack:: +* Continuing Execution:: +* Evaluating Scheme Code:: +* Setting and Managing Breakpoints:: +* Access to Guile Help and Completion:: +* Associating Buffers with Clients:: +* An Example GDS Session:: +* GDS Architecture:: +@end menu + + +@node GDS Introduction +@subsection GDS Introduction + +GDS aims to allow you to work on Guile Scheme code in the same kind of +way that Emacs allows you to work on Emacs Lisp code: providing easy +access to help, evaluating arbitrary fragments of code, a nice debugging +interface, and so on. The thinking behind this environment is that you +will usually be doing one of two things. @enumerate @item -Writing or editing code. The code will be in a normal Emacs Scheme -mode buffer, and the Guile/Emacs environment extends Scheme mode to -add keystrokes and menu items for the things that are likely to be -useful to you when working on code: +Writing or editing code. The code will be in a normal Emacs Scheme mode +buffer, and GDS extends Scheme mode to add keystrokes and menu items for +the things that are likely to be useful to you when working on code: @itemize @item @@ -390,9 +487,9 @@ evaluating fragments of code to check what they do. @end itemize @item -Debugging a Guile Scheme program. When your program hits an error or -a breakpoint, the Guile/Emacs environment shows you the relevant code -and the Scheme stack, and makes it easy to +Debugging a Guile Scheme program. When your program hits an error or a +breakpoint, GDS can show you the relevant code and the Scheme stack, and +make it easy to @itemize @item @@ -411,11 +508,10 @@ can also run a program until it hits a breakpoint, then examine, modify and reevaluate some of the relevant code, and then tell the program to continue running. -GDS is a user interface for working on Guile Scheme programs in Emacs. -It aims to provide whatever facilities are needed to make the writing, -debugging and maintenance of Scheme code in Emacs as fluid and -productive as possible. These facilities currently include the -following. +In other words, we could say that GDS provides a set of facilities which +aim to make the writing, debugging and maintenance of Scheme code in +Emacs as fluid and productive as possible. In a bit more detail, these +facilities are currently as follows. @table @asis @item Displaying the Scheme stack @@ -441,11 +537,12 @@ up in a temporary Emacs window. @item Setting breakpoints in Scheme code GDS makes it easy to set breakpoints in Scheme code from within Emacs. -Deep down this uses the traps described in previous chapters, but GDS -makes the practicalities as simple as typing @kbd{C-x @key{SPC}}. When -a GDS breakpoint is hit, the stack at that point is popped up in Emacs. -GDS also remembers your breakpoints between editing sessions, so you -don't have to set them again when you visit the relevant files. +Deep down this uses Guile's trap and breakpoint infrastructure described +elsewhere in this manual, but GDS makes the practicalities as simple as +typing @kbd{C-x @key{SPC}}. When a GDS breakpoint is hit, the stack at +that point is popped up in Emacs. GDS also remembers your breakpoints +between editing sessions, so you don't have to set them again when you +visit the relevant files. @item Access to Guile's built in help system GDS makes it easy to query Guile's ``help'' and ``apropos'' commands, @@ -456,10 +553,6 @@ GDS provides a keystroke which tries to complete a partially entered symbol by asking Guile to match it against all the accessible bindings. @end table -(For a hands-on, tutorial introduction to using GDS, use Emacs to open -the file @file{gds-tutorial.txt}, which is included with the -guile-debugging distribution, and then follow the steps in that file.) - GDS can provide these facilities for any number of Guile Scheme programs (which we often call ``clients'') at once, and these programs can be started either completely independently of GDS, including outside Emacs, @@ -487,27 +580,13 @@ socket, which means that it is orthogonal to any other interfaces that the client program has. In particular GDS does not interfere with a program's standard input and output. -@menu -* GDS Setup:: -* How To Use GDS:: -* Displaying the Scheme Stack:: -* Continuing Execution:: -* Evaluating Scheme Code:: -* Setting and Managing Breakpoints:: -* Access to Guile Help and Completion:: -* Associating Buffers with Clients:: -* An Example GDS Session:: -* GDS Architecture:: -@end menu +@node GDS Getting Started +@subsection Getting Started with GDS -@node GDS Setup -@subsection GDS Setup - -GDS's Scheme and Emacs Lisp files will have been installed in -the correct places system-wide when the @code{guile-debugging} package -as a whole was installed. To enable the use of GDS in your own Emacs -sessions, simply add +GDS's Scheme and Emacs Lisp files will have been installed in the +correct places system-wide when Guile as a whole was installed. To +enable the use of GDS in your own Emacs sessions, simply add @lisp (require 'gds) @@ -516,6 +595,11 @@ sessions, simply add @noindent somewhere in your @file{.emacs} file. +For a hands-on, tutorial introduction to using GDS, you may then like to +use Emacs to open the file @file{gds-tutorial.txt} (which should have +been installed as part of Guile, perhaps under +@file{/usr/share/doc/guile}), and then follow the steps in that file. + @node How To Use GDS @subsection How To Use GDS @@ -1066,8 +1150,8 @@ Calling procedure: GDS's most compelling feature is its single-stepping. To get an immediate feel for what this is like, make sure your Emacs is prepared -as described in @ref{GDS Setup}, then type the following code into an -interactive Guile session. +as described in @ref{GDS Getting Started}, then type the following code +into an interactive Guile session. @lisp (fact1 4) From 2202fd6cbad98c764b033f1a0d02a048d8bc4638 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 27 Aug 2006 14:06:16 +0000 Subject: [PATCH 025/116] (Debug on Error): New text on how to catch errors and the error stack. --- doc/ref/ChangeLog | 5 +++ doc/ref/api-debug.texi | 93 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index a73eb3345..c2e01f88a 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-08-27 Neil Jerram + + * api-debug.texi (Debug on Error): New text on how to catch errors + and the error stack. + 2006-08-23 Neil Jerram * scheme-using.texi (Using Guile in Emacs): New text about diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 6868ef211..a6848c0a8 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -369,6 +369,99 @@ a convenience to the user. @node Debug on Error @subsection Debugging when an error occurs +A common requirement is to be able to show as much useful context as +possible when a Scheme program hits an error. The most immediate +information about an error is the kind of error that it is -- such as +``division by zero'' -- and any parameters that the code which signalled +the error chose explicitly to provide. This information originates with +the @code{error} or @code{throw} call (or their C code equivalents, if +the error is detected by C code) that signals the error, and is passed +automatically to the handler procedure of the innermost applicable +@code{catch}, @code{lazy-catch} or @code{with-throw-handler} expression. + +@subsubsection Intercepting basic error information + +Therefore, to catch errors that occur within a chunk of Scheme code, and +to intercept basic information about those errors, you need to execute +that code inside the dynamic context of a @code{catch}, +@code{lazy-catch} or @code{with-throw-handler} expression, or the +equivalent in C. In Scheme, this means you need something like this: + +@lisp +(catch #t + (lambda () + ;; Execute the code in which + ;; you want to catch errors here. + ...) + (lambda (key . parameters) + ;; Put the code which you want + ;; to handle an error here. + ...)) +@end lisp + +@noindent +The @code{catch} here can also be @code{lazy-catch} or +@code{with-throw-handler}; see @ref{Throw Handlers} and @ref{Lazy Catch} +for the details of how these differ from @code{catch}. The @code{#t} +means that the catch is applicable to all kinds of error; if you want to +restrict your catch to just one kind of error, you can put the symbol +for that kind of error instead of @code{#t}. The equivalent to this in +C would be something like this: + +@lisp +SCM my_body_proc (void *body_data) +@{ + /* Execute the code in which + you want to catch errors here. */ + ... +@} + +SCM my_handler_proc (void *handler_data, SCM key, SCM parameters) +@{ + /* Put the code which you want + to handle an error here. */ + ... +@} + +@{ + ... + scm_c_catch (SCM_BOOL_T, + my_body_proc, body_data, + my_handler_proc, handler_data, + NULL, NULL); + ... +@} +@end lisp + +@noindent +Again, as with the Scheme version, @code{scm_c_catch} could be replaced +by @code{scm_internal_lazy_catch} or @code{scm_c_with_throw_handler}, +and @code{SCM_BOOL_T} could instead be the symbol for a particular kind +of error. + +@subsubsection Capturing the full error stack + +The other interesting information about an error is the full Scheme +stack at the point where the error occurred; in other words what +innermost expression was being evaluated, what was the expression that +called that one, and so on. If you want to write your code so that it +captures and can display this information as well, there are two +important things to understand. + +Firstly, the stack at the point of the error needs to be explicitly +captured by a @code{make-stack} call (or the C equivalent +@code{scm_make_stack}). The Guile library does not, in general, do this +``automatically'' for you, so you will need to write code with a +@code{make-stack} or @code{scm_make_stack} call yourself. (We emphasise +this point because some people are misled by the fact that the Guile +interactive REPL code @emph{does} capture and display the stack +automatically. But the Guile interactive REPL is itself a Scheme +program@footnote{In effect, it is the default program which is run when +no commands or script file are specified on the Guile command line.} +running on top of the Guile library, and which uses @code{catch} and +@code{make-stack} in the way we are about to describe to capture the +stack when an error occurs.) + @deffn {Scheme Procedure} backtrace [highlights] @deffnx {C Function} scm_backtrace_with_highlights (highlights) @deffnx {C Function} scm_backtrace () From fc3d5c436f0c4600025681a2ea68b1f71c01a15f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 28 Aug 2006 22:16:42 +0000 Subject: [PATCH 026/116] (Examining the Stack): Minor improvements to display-backtrace doc. (Debug on Error): More new text on catching the error stack. --- doc/ref/ChangeLog | 6 ++ doc/ref/api-debug.texi | 139 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 131 insertions(+), 14 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index c2e01f88a..9d9da1f3c 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2006-08-28 Neil Jerram + + * api-debug.texi (Examining the Stack): Minor improvements to + display-backtrace doc. + (Debug on Error): More new text on catching the error stack. + 2006-08-27 Neil Jerram * api-debug.texi (Debug on Error): New text on how to catch errors diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index a6848c0a8..db759cc3a 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -156,14 +156,14 @@ Return the @var{index}'th frame from @var{stack}. @deffn {Scheme Procedure} display-backtrace stack port [first [depth [highlights]]] @deffnx {C Function} scm_display_backtrace_with_highlights (stack, port, first, depth, highlights) @deffnx {C Function} scm_display_backtrace (stack, port, first, depth) -Display a backtrace to the output port @var{port}. @var{stack} +Display a backtrace to the output port @var{port}. @var{stack} is the stack to take the backtrace from, @var{first} specifies -where in the stack to start and @var{depth} how much frames -to display. Both @var{first} and @var{depth} can be @code{#f}, +where in the stack to start and @var{depth} how many frames +to display. @var{first} and @var{depth} can be @code{#f}, which means that default values will be used. -When @var{highlights} is given, -it should be a list and all members of it are highligthed in -the backtrace. +If @var{highlights} is given it should be a list; the elements +of this list will be highlighted wherever they appear in the +backtrace. @end deffn @@ -416,7 +416,9 @@ SCM my_body_proc (void *body_data) ... @} -SCM my_handler_proc (void *handler_data, SCM key, SCM parameters) +SCM my_handler_proc (void *handler_data, + SCM key, + SCM parameters) @{ /* Put the code which you want to handle an error here. */ @@ -450,7 +452,7 @@ important things to understand. Firstly, the stack at the point of the error needs to be explicitly captured by a @code{make-stack} call (or the C equivalent -@code{scm_make_stack}). The Guile library does not, in general, do this +@code{scm_make_stack}). The Guile library does not do this ``automatically'' for you, so you will need to write code with a @code{make-stack} or @code{scm_make_stack} call yourself. (We emphasise this point because some people are misled by the fact that the Guile @@ -462,22 +464,131 @@ running on top of the Guile library, and which uses @code{catch} and @code{make-stack} in the way we are about to describe to capture the stack when an error occurs.) +Secondly, in order to capture the stack effectively at the point where +the error occurred, the @code{make-stack} call must be made before Guile +unwinds the stack back to the location of the prevailing catch +expression. This means that the @code{make-stack} call must be made +within the handler of a @code{lazy-catch} or @code{with-throw-handler} +expression, or the optional "pre-unwind" handler of a @code{catch}. +(For the full story of how these alternatives differ from each other, +see @ref{Exceptions}. The main difference is that @code{catch} +terminates the error, whereas @code{lazy-catch} and +@code{with-throw-handler} only intercept it temporarily and then allow +it to continue propagating up to the next innermost handler.) + +So, here are some examples of how to do all this in Scheme and in C. +For the purpose of these examples we assume that the captured stack +should be stored in a variable, so that it can be displayed or +arbitrarily processed later on. In Scheme: + +@lisp +(let ((captured-stack #f)) + (catch #t + (lambda () + ;; Execute the code in which + ;; you want to catch errors here. + ...) + (lambda (key . parameters) + ;; Put the code which you want + ;; to handle an error after the + ;; stack has been unwound here. + ...) + (lambda (key . parameters) + ;; Capture the stack here: + (set! captured-stack (make-stack #t)))) + ... + (if captured-stack + (begin + ;; Display or process the captured stack. + ...)) + ...) +@end lisp + +@noindent +And in C: + +@lisp +SCM my_body_proc (void *body_data) +@{ + /* Execute the code in which + you want to catch errors here. */ + ... +@} + +SCM my_handler_proc (void *handler_data, + SCM key, + SCM parameters) +@{ + /* Put the code which you want + to handle an error after the + stack has been unwound here. */ + ... +@} + +SCM my_preunwind_proc (void *handler_data, + SCM key, + SCM parameters) +@{ + /* Capture the stack here: */ + *(SCM *)handler_data = scm_make_stack (SCM_BOOL_T, SCM_EOL); +@} + +@{ + SCM captured_stack = SCM_BOOL_F; + ... + scm_c_catch (SCM_BOOL_T, + my_body_proc, body_data, + my_handler_proc, handler_data, + my_preunwind_proc, &captured_stack); + ... + if (captured_stack != SCM_BOOL_F) + @{ + /* Display or process the captured stack. */ + ... + @} + ... +@} +@end lisp + +@noindent +Note that you don't have to wait until after the @code{catch} or +@code{scm_c_catch} has returned. You can also do whatever you like with +the stack immediately after it has been captured in the pre-unwind +handler, or in the normal (post-unwind) handler. (Except that for the +latter case in C you will need to change @code{handler_data} in the +@code{scm_c_catch(@dots{})} call to @code{&captured_stack}, so that +@code{my_handler_proc} has access to the captured stack.) + +@subsubsection Displaying or interrogating the captured stack + +Once you have a captured stack, you can interrogate and display its +details in any way that you want, using the @code{stack-@dots{}} and +@code{frame-@dots{}} API described in @ref{Examining the Stack} and +@ref{Examining Stack Frames}. + +If you want to print out a backtrace in the same format that the Guile +REPL does, you can use the @code{display-backtrace} procedure to do so. +You can also use @code{display-application} to display an individual +application frame -- that is, a frame that satisfies the +@code{frame-procedure?} predicate -- in the Guile REPL format. + +@subsubsection What the Guile REPL does + +[To be completed] + @deffn {Scheme Procedure} backtrace [highlights] @deffnx {C Function} scm_backtrace_with_highlights (highlights) @deffnx {C Function} scm_backtrace () Display a backtrace of the stack saved by the last error -to the current output port. When @var{highlights} is given, -it should be a list and all members of it are highligthed in -the backtrace. +to the current output port. If @var{highlights} is given +it should be a list; the elements of this list will be +highlighted wherever they appear in the backtrace. @end deffn @deffn {Scheme Procedure} debug Invoke the Guile debugger to explore the context of the last error. @end deffn -[Should also cover how to catch and debug errors from C, including -discussion of lazy/pre-unwind handlers.] - @node Low Level Trap Calls @subsection Low Level Trap Calls From b5944f66723daaad141f440176b03c8987b6857c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 28 Aug 2006 22:17:26 +0000 Subject: [PATCH 027/116] (scm_display_backtrace_with_highlights): Minor improvements to docstring. (scm_backtrace_with_highlights): Analogous improvements. --- libguile/ChangeLog | 6 ++++++ libguile/backtrace.c | 18 +++++++++--------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 11001fb3b..4036607d9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2006-08-28 Neil Jerram + + * backtrace.c (scm_display_backtrace_with_highlights): Minor + improvements to docstring. + (scm_backtrace_with_highlights): Analogous improvements. + 2006-08-11 Neil Jerram * stacks.c (scm_last_stack_frame): Correct docstring (returns a diff --git a/libguile/backtrace.c b/libguile/backtrace.c index edeefb831..38d7a8382 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -730,14 +730,14 @@ display_backtrace_body (struct display_backtrace_args *a) SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, (SCM stack, SCM port, SCM first, SCM depth, SCM highlights), - "Display a backtrace to the output port @var{port}. @var{stack}\n" + "Display a backtrace to the output port @var{port}. @var{stack}\n" "is the stack to take the backtrace from, @var{first} specifies\n" - "where in the stack to start and @var{depth} how much frames\n" - "to display. Both @var{first} and @var{depth} can be @code{#f},\n" + "where in the stack to start and @var{depth} how many frames\n" + "to display. @var{first} and @var{depth} can be @code{#f},\n" "which means that default values will be used.\n" - "When @var{highlights} is given,\n" - "it should be a list and all members of it are highligthed in\n" - "the backtrace.") + "If @var{highlights} is given it should be a list; the elements\n" + "of this list will be highlighted wherever they appear in the\n" + "backtrace.") #define FUNC_NAME s_scm_display_backtrace_with_highlights { struct display_backtrace_args a; @@ -771,9 +771,9 @@ SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0, (SCM highlights), "Display a backtrace of the stack saved by the last error\n" - "to the current output port. When @var{highlights} is given,\n" - "it should be a list and all members of it are highligthed in\n" - "the backtrace.") + "to the current output port. If @var{highlights} is given\n" + "it should be a list; the elements of this list will be\n" + "highlighted wherever they appear in the backtrace.") #define FUNC_NAME s_scm_backtrace_with_highlights { SCM port = scm_current_output_port (); From 5b2da4cc18be3dfb97ced8fe2c64d0ae59d98793 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 29 Aug 2006 22:47:41 +0000 Subject: [PATCH 028/116] (Debug on Error): Added paragraph on need to use debugging evaluator. Added text on what the Guile REPL code does. --- doc/ref/ChangeLog | 5 +++++ doc/ref/api-debug.texi | 28 ++++++++++++++++++++++++---- 2 files changed, 29 insertions(+), 4 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 9d9da1f3c..969269e4b 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-08-29 Neil Jerram + + * api-debug.texi (Debug on Error): Added paragraph on need to use + debugging evaluator. Added text on what the Guile REPL code does. + 2006-08-28 Neil Jerram * api-debug.texi (Examining the Stack): Minor improvements to diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index db759cc3a..5f816dc46 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -447,10 +447,19 @@ The other interesting information about an error is the full Scheme stack at the point where the error occurred; in other words what innermost expression was being evaluated, what was the expression that called that one, and so on. If you want to write your code so that it -captures and can display this information as well, there are two +captures and can display this information as well, there are three important things to understand. -Firstly, the stack at the point of the error needs to be explicitly +Firstly, the code in question must be executed using the debugging +version of the evaluator, because information about the Scheme stack is +only available at all from the debugging evaluator. Using the debugging +evaluator means that the debugger option (@pxref{Debugger options}) +called @code{debug} must be enabled; this can be done by running +@code{(debug-enable 'debug)} or @code{(turn-on-debugging)} at the top +level of your program; or by running guile with the @code{--debug} +command line option, if your program begins life as a Scheme script. + +Secondly, the stack at the point of the error needs to be explicitly captured by a @code{make-stack} call (or the C equivalent @code{scm_make_stack}). The Guile library does not do this ``automatically'' for you, so you will need to write code with a @@ -464,7 +473,7 @@ running on top of the Guile library, and which uses @code{catch} and @code{make-stack} in the way we are about to describe to capture the stack when an error occurs.) -Secondly, in order to capture the stack effectively at the point where +Thirdly, in order to capture the stack effectively at the point where the error occurred, the @code{make-stack} call must be made before Guile unwinds the stack back to the location of the prevailing catch expression. This means that the @code{make-stack} call must be made @@ -574,7 +583,14 @@ application frame -- that is, a frame that satisfies the @subsubsection What the Guile REPL does -[To be completed] +The Guile REPL code (in @file{ice-9/boot-9.scm}) uses a @code{catch} +with a pre-unwind handler to capture the stack when an error occurs in +an expression that was typed into the REPL, and saves the captured stack +in a fluid (@pxref{Fluids and Dynamic States}) called +@code{the-last-stack}. You can then use the @code{(backtrace)} command, +which is basically equivalent to @code{(display-backtrace (fluid-ref +the-last-stack))}, to print out this stack at any time until it is +overwritten by the next error that occurs. @deffn {Scheme Procedure} backtrace [highlights] @deffnx {C Function} scm_backtrace_with_highlights (highlights) @@ -585,6 +601,10 @@ it should be a list; the elements of this list will be highlighted wherever they appear in the backtrace. @end deffn +You can also use the @code{(debug)} command to explore the saved stack +using an interactive command-line-driven debugger. See @ref{Interactive +Debugger} for more information about this. + @deffn {Scheme Procedure} debug Invoke the Guile debugger to explore the context of the last error. @end deffn From bd83658e66cc70b72500a61e186fc5beb2fb6deb Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 1 Sep 2006 01:37:57 +0000 Subject: [PATCH 029/116] (scm_c_port_for_each): Add a scm_remember_upto_here_1(ports) at the end of the function to fix a GC bug. --- libguile/ports.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/ports.c b/libguile/ports.c index 9ac0c1cbe..2628cfc06 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -817,6 +817,8 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data) for (i = 0; i < n; i++) proc (data, SCM_SIMPLE_VECTOR_REF (ports, i)); + + scm_remember_upto_here_1 (ports); } SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, From 418122ce6b049679edb67ea2bb6423d75c709602 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 1 Sep 2006 01:38:18 +0000 Subject: [PATCH 030/116] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4036607d9..7d4d30867 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2006-08-31 Rob Browning + + * ports.c (scm_c_port_for_each): Add a + scm_remember_upto_here_1(ports) at the end of the function to fix + a GC bug. + 2006-08-28 Neil Jerram * backtrace.c (scm_display_backtrace_with_highlights): Minor From 9f1ba6a9a45276278a0f511f1f1936e659aea8f8 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 15 Sep 2006 09:23:18 +0000 Subject: [PATCH 031/116] Doc typo fixes --- doc/ref/ChangeLog | 8 ++++++++ doc/ref/api-compound.texi | 2 +- doc/ref/api-control.texi | 7 +++++++ doc/ref/api-data.texi | 6 +++--- doc/ref/api-modules.texi | 2 +- 5 files changed, 20 insertions(+), 5 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 969269e4b..b784edad5 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,11 @@ +2006-09-04 Neil Jerram + + * api-control.texi (Dynamic Wind): Doc for scm_dynwind_free. + + * api-modules.texi (The Guile module system), api-data.texi + (Integers, Numerical Tower), api-compound.texi (Uniform Numeric + Vectors): Fix typos. (Patch sent in by Marco Maggi.) + 2006-08-29 Neil Jerram * api-debug.texi (Debug on Error): Added paragraph on need to use diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 3e1699aa0..44410d158 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1057,7 +1057,7 @@ being a @code{double} The external representation (ie.@: read syntax) for these vectors is similar to normal Scheme vectors, but with an additional tag from the -tabel above indiciating the vector's type. For example, +table above indiciating the vector's type. For example, @lisp #u16(1 2 3) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 3d1549ecf..dbb51cf6f 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1356,6 +1356,13 @@ The function @code{scm_dynwind_rewind_handler_with_scm} takes care that @var{data} is protected from garbage collection. @end deftypefn +@deftypefn {C Function} void scm_dynwind_free (void *mem) +Arrange for @var{mem} to be freed automatically whenever the current +context is exited, whether normally or non-locally. +@code{scm_dynwind_free (mem)} is an equivalent shorthand for +@code{scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY)}. +@end deftypefn + @node Handling Errors @subsection How to Handle Errors diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 885f42294..c0f5d08ef 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -227,8 +227,8 @@ rational is also real, and every real number is also a complex number In addition to the classification into integers, rationals, reals and complex numbers, Scheme also distinguishes between whether a number is represented exactly or not. For example, the result of -@m{2\sin(\pi/4),sin(pi/4)} is exactly @m{\sqrt{2},2^(1/2)} but Guile -can neither represent @m{\pi/4,pi/4} nor @m{\sqrt{2},2^(1/2)} exactly. +@m{2\sin(\pi/4),2*sin(pi/4)} is exactly @m{\sqrt{2},2^(1/2)}, but Guile +can represent neither @m{\pi/4,pi/4} nor @m{\sqrt{2},2^(1/2)} exactly. Instead, it stores an inexact approximation, using the C type @code{double}. @@ -477,7 +477,7 @@ the occupied space must be freed with @code{mpz_clear}. @xref{Initializing Integers,,, gmp, GNU MP Manual}, for details. @end deftypefn -@deftypefn {C Function} SCM scm_from_mpz_t (mpz_t val) +@deftypefn {C Function} SCM scm_from_mpz (mpz_t val) Return the @code{SCM} value that represents @var{val}. @end deftypefn diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 54e5f4b8f..c12e31dca 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -133,7 +133,7 @@ sets of bindings. In 1996 Tom Lord implemented a full-featured module system for Guile which allows loading Scheme source files into a private name space. This system has -been in available since at least Guile version 1.1. +been available since at least Guile version 1.1. For Guile version 1.5.0 and later, the system has been improved to have better integration from C code, more fine-grained user control over interfaces, and From 162426a8eee0c76d30f7329d397e8edd6e4628d8 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 20 Sep 2006 00:33:56 +0000 Subject: [PATCH 032/116] (build-link): Restore the removal of "/usr/lib" (in addition to "/usr/lib/" from any -L arguments). --- guile-config/guile-config.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guile-config/guile-config.in b/guile-config/guile-config.in index 04a4f0575..e5687da46 100644 --- a/guile-config/guile-config.in +++ b/guile-config/guile-config.in @@ -152,7 +152,8 @@ (list (get-build-info 'CFLAGS) "-lguile -lltdl" - (if (string=? libdir "/usr/lib/") + (if (or (string=? libdir "/usr/lib") + (string=? libdir "/usr/lib/")) "" (string-append "-L" (get-build-info 'libdir))) (string-join other-flags) From ace5708285569094d9b7fa75a0afdf69a17dcf63 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 20 Sep 2006 00:34:02 +0000 Subject: [PATCH 033/116] *** empty log message *** --- guile-config/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 74c2c745c..de7091980 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,8 @@ +2006-09-19 Rob Browning + + * guile-config.in (build-link): Restore the removal of "/usr/lib" + (in addition to "/usr/lib/" from any -L arguments). + 2005-02-10 Mikael Djurfeldt * guile-config.in (build-link): Replaced -lguile-ltdl with -lltdl. From a17d26545da83dbb6dc0c9571f97d0f02d8ddc34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Sep 2006 12:48:45 +0000 Subject: [PATCH 034/116] Changes from arch/CVS synchronization --- ChangeLog | 7 ++ NEWS | 1 + configure.in | 3 +- libguile/ChangeLog | 22 ++++ libguile/posix.c | 5 + libguile/srfi-14.c | 199 ++++++++++++++++++++++++---------- libguile/srfi-14.h | 2 +- test-suite/ChangeLog | 9 ++ test-suite/tests/srfi-14.test | 133 ++++++++++++++++++++++- 9 files changed, 322 insertions(+), 59 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4e6ed04e3..0df690615 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2006-09-20 Ludovic Courts + + * configure.in: Check for `isblank ()'. + + * NEWS: Mentioned the interaction between `setlocale' and SRFI-14 + standard char sets. + 2006-08-18 Neil Jerram * configure.in: Generate Makefile for emacs subdir. diff --git a/NEWS b/NEWS index 95a9b1603..3565da8b3 100644 --- a/NEWS +++ b/NEWS @@ -30,6 +30,7 @@ Changes in 1.8.1 (since 1.8.0): ** A one-dimenisonal array can now be 'equal?' to a vector. ** Structures, records, and SRFI-9 records can now be compared with `equal?'. +** SRFI-14 standard char sets are now recomputed upon successful `setlocale'. * Changes to the C interface diff --git a/configure.in b/configure.in index 798dbbee7..e06a4981a 100644 --- a/configure.in +++ b/configure.in @@ -598,9 +598,10 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # readdir_r - recent posix, not on old systems # stat64 - SuS largefile stuff, not on old systems # sysconf - not on old systems +# isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # -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]) +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 isblank _NSGetEnviron]) # Reasons for testing: # netdb.h - not in mingw diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7d4d30867..4b7b805f8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2006-09-20 Ludovic Courts + + * srfi-14.c: Include . Define `_GNU_SOURCE'. + (make_predset, define_predset, make_strset, define_strset, false, + true): Removed. + (SCM_CHARSET_UNSET, CSET_BLANK_PRED, CSET_SYMBOL_PRED, + CSET_PUNCT_PRED, CSET_LOWER_PRED, CSET_UPPER_PRED, + CSET_LETTER_PRED, CSET_DIGIT_PRED, CSET_WHITESPACE_PRED, + CSET_CONTROL_PRED, CSET_HEX_DIGIT_PRED, CSET_ASCII_PRED, + CSET_LETTER_AND_DIGIT_PRED, CSET_GRAPHIC_PRED, CSET_PRINTING_PRED, + CSET_TRUE_PRED, CSET_FALSE_PRED, UPDATE_CSET): New macros. + (define_charset, scm_srfi_14_compute_char_sets): New functions. + (scm_init_srfi_14): Use `define_charset ()' instead of + `define_predset ()' and `define_strset ()'. + + * srfi-14.h (scm_c_init_srfi_14): Removed. + (scm_srfi_14_compute_char_sets): New declaration. + + * posix.h: Include "srfi-14.h". + (scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a + successful `setlocale ()' call. + 2006-08-31 Rob Browning * ports.c (scm_c_port_for_each): Add a diff --git a/libguile/posix.c b/libguile/posix.c index a96dabcfa..136d77084 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -34,6 +34,7 @@ #include "libguile/feature.h" #include "libguile/strings.h" #include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" #include "libguile/vectors.h" #include "libguile/lang.h" @@ -1392,6 +1393,10 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, SCM_SYSERROR; } + /* Recompute the standard SRFI-14 character sets in a locale-dependent + (actually charset-dependent) way. */ + scm_srfi_14_compute_char_sets (); + scm_dynwind_end (); return scm_from_locale_string (rv); } diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 7900d26f2..f61db7dd5 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -17,6 +17,12 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#ifdef HAVE_CONFIG_H +# include +#endif + + +#define _GNU_SOURCE /* Ask for `isblank ()'. */ #include #include @@ -25,10 +31,14 @@ #include "libguile/srfi-14.h" -#define SCM_CHARSET_SET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ +#define SCM_CHARSET_SET(cs, idx) \ + (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ (1L << ((idx) % SCM_BITS_PER_LONG))) +#define SCM_CHARSET_UNSET(cs, idx) \ + (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &= \ + (~(1L << ((idx) % SCM_BITS_PER_LONG)))) + #define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) #define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) @@ -1393,6 +1403,9 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!" } #undef FUNC_NAME + +/* Standard character sets. */ + SCM scm_char_set_lower_case; SCM scm_char_set_upper_case; SCM scm_char_set_title_case; @@ -1411,48 +1424,123 @@ SCM scm_char_set_ascii; SCM scm_char_set_empty; SCM scm_char_set_full; -static SCM -make_predset (int (*pred) (int)) + +/* Create an empty character set and return it after binding it to NAME. */ +static inline SCM +define_charset (const char *name) { - int ch; SCM cs = make_char_set (NULL); + scm_c_define (name, cs); + return scm_permanent_object (cs); +} + +/* Membership predicates for the various char sets. + + XXX: The `punctuation' and `symbol' char sets have no direct equivalent in + . Thus, the predicates below yield correct results for ASCII, + but they do not provide the result described by the SRFI for Latin-1. The + correct Latin-1 result could only be obtained by hard-coding the + characters listed by the SRFI, but the problem would remain for other + 8-bit charsets. + + Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should + be part of `char-set:blank'. However, glibc's current (2006/09) Latin-1 + locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it + `blank' so it ends up in `char-set:punctuation'. */ +#ifdef HAVE_ISBLANK +# define CSET_BLANK_PRED(c) (isblank (c)) +#else +# define CSET_BLANK_PRED(c) \ + (((c) == ' ') || ((c) == '\t')) +#endif + +#define CSET_SYMBOL_PRED(c) \ + (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL)) +#define CSET_PUNCT_PRED(c) \ + ((ispunct (c)) && (!CSET_SYMBOL_PRED (c))) + +#define CSET_LOWER_PRED(c) (islower (c)) +#define CSET_UPPER_PRED(c) (isupper (c)) +#define CSET_LETTER_PRED(c) (isalpha (c)) +#define CSET_DIGIT_PRED(c) (isdigit (c)) +#define CSET_WHITESPACE_PRED(c) (isspace (c)) +#define CSET_CONTROL_PRED(c) (iscntrl (c)) +#define CSET_HEX_DIGIT_PRED(c) (isxdigit (c)) +#define CSET_ASCII_PRED(c) (isascii (c)) + +/* Some char sets are explicitly defined by the SRFI as a union of other char + sets so we try to follow this closely. */ + +#define CSET_LETTER_AND_DIGIT_PRED(c) \ + (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c)) + +#define CSET_GRAPHIC_PRED(c) \ + (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c) \ + || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c)) + +#define CSET_PRINTING_PRED(c) \ + (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c)) + +/* False and true predicates. */ +#define CSET_TRUE_PRED(c) (1) +#define CSET_FALSE_PRED(c) (0) + + +/* Compute the contents of all the standard character sets. Computation may + need to be re-done at `setlocale'-time because some char sets (e.g., + `char-set:letter') need to reflect the character set supported by Guile. + + For instance, at startup time, the "C" locale is used, thus Guile supports + only ASCII; therefore, `char-set:letter' only contains English letters. + The user can change this by invoking `setlocale' and specifying a locale + with an 8-bit charset, thereby augmenting some of the SRFI-14 standard + character sets. + + This works because some of the predicates used below to construct + character sets (e.g., `isalpha(3)') are locale-dependent (so + charset-dependent, though generally not language-dependent). For details, + please see the `guile-devel' mailing list archive of September 2006. */ +void +scm_srfi_14_compute_char_sets (void) +{ +#define UPDATE_CSET(c, cset, pred) \ + do \ + { \ + if (pred (c)) \ + SCM_CHARSET_SET ((cset), (c)); \ + else \ + SCM_CHARSET_UNSET ((cset), (c)); \ + } \ + while (0) + + register int ch; + for (ch = 0; ch < 256; ch++) - if (pred (ch)) - SCM_CHARSET_SET (cs, ch); - return cs; -} - -static SCM -define_predset (const char *name, int (*pred) (int)) -{ - SCM cs = make_predset (pred); - scm_c_define (name, cs); - return scm_permanent_object (cs); -} - -static SCM -make_strset (const char *str) -{ - SCM cs = make_char_set (NULL); - while (*str) { - SCM_CHARSET_SET (cs, *str); - str++; + UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED); + UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED); + UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED); + UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED); + UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED); + UPDATE_CSET (ch, scm_char_set_letter_and_digit, + CSET_LETTER_AND_DIGIT_PRED); + UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED); + UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED); + UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED); + UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED); + UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED); + UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED); + UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED); + UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED); + UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED); + UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED); + UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED); } - return cs; + +#undef UPDATE_CSET } -static SCM -define_strset (const char *name, const char *str) -{ - SCM cs = make_strset (str); - scm_c_define (name, cs); - return scm_permanent_object (cs); -} - -static int false (int ch) { return 0; } -static int true (int ch) { return 1; } - + void scm_init_srfi_14 (void) { @@ -1461,24 +1549,25 @@ scm_init_srfi_14 (void) scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); - scm_char_set_upper_case = define_predset ("char-set:upper-case", isupper); - scm_char_set_lower_case = define_predset ("char-set:lower-case", islower); - scm_char_set_title_case = define_predset ("char-set:title-case", false); - scm_char_set_letter = define_predset ("char-set:letter", isalpha); - scm_char_set_digit = define_predset ("char-set:digit", isdigit); - scm_char_set_letter_and_digit = define_predset ("char-set:letter+digit", - isalnum); - scm_char_set_graphic = define_predset ("char-set:graphic", isgraph); - scm_char_set_printing = define_predset ("char-set:printing", isprint); - scm_char_set_whitespace = define_predset ("char-set:whitespace", isspace); - scm_char_set_iso_control = define_predset ("char-set:iso-control", iscntrl); - scm_char_set_punctuation = define_predset ("char-set:punctuation", ispunct); - scm_char_set_symbol = define_strset ("char-set:symbol", "$+<=>^`|~"); - scm_char_set_hex_digit = define_predset ("char-set:hex-digit", isxdigit); - scm_char_set_blank = define_strset ("char-set:blank", " \t"); - scm_char_set_ascii = define_predset ("char-set:ascii", isascii); - scm_char_set_empty = define_predset ("char-set:empty", false); - scm_char_set_full = define_predset ("char-set:full", true); + scm_char_set_upper_case = define_charset ("char-set:upper-case"); + scm_char_set_lower_case = define_charset ("char-set:lower-case"); + scm_char_set_title_case = define_charset ("char-set:title-case"); + scm_char_set_letter = define_charset ("char-set:letter"); + scm_char_set_digit = define_charset ("char-set:digit"); + scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit"); + scm_char_set_graphic = define_charset ("char-set:graphic"); + scm_char_set_printing = define_charset ("char-set:printing"); + scm_char_set_whitespace = define_charset ("char-set:whitespace"); + scm_char_set_iso_control = define_charset ("char-set:iso-control"); + scm_char_set_punctuation = define_charset ("char-set:punctuation"); + scm_char_set_symbol = define_charset ("char-set:symbol"); + scm_char_set_hex_digit = define_charset ("char-set:hex-digit"); + scm_char_set_blank = define_charset ("char-set:blank"); + scm_char_set_ascii = define_charset ("char-set:ascii"); + scm_char_set_empty = define_charset ("char-set:empty"); + scm_char_set_full = define_charset ("char-set:full"); + + scm_srfi_14_compute_char_sets (); #include "libguile/srfi-14.x" } diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h index 3278b928e..516c51044 100644 --- a/libguile/srfi-14.h +++ b/libguile/srfi-14.h @@ -106,7 +106,7 @@ SCM_API SCM scm_char_set_ascii; SCM_API SCM scm_char_set_empty; SCM_API SCM scm_char_set_full; -SCM_API void scm_c_init_srfi_14 (void); +SCM_API void scm_srfi_14_compute_char_sets (void); SCM_API void scm_init_srfi_14 (void); #endif /* SCM_SRFI_14_H */ diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index ed36d30c7..1a5c26a56 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2006-09-20 Ludovic Courts + + * tests/srfi-14.test: Use `define-module'. Use modules `(srfi + srfi-1)' and `(test-suite lib)'. + (string->char-set, standard char sets (ASCII), Latin-1 (8-bit + charset)): New test prefixes. + (every?, find-latin1-locale): New procedures. + (%latin1): New variable. + 2006-06-13 Ludovic Courts * Makefile.am (SCM_TESTS): Added `tests/structs.test'. diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index fabb7842d..5c3a3f509 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -1,4 +1,4 @@ -;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. -*- scheme -*- +;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. ;;;; Martin Grabmueller, 2001-07-16 ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. @@ -18,7 +18,11 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-14)) +(define-module (test-suite test-srfi-14) + :use-module (srfi srfi-14) + :use-module (srfi srfi-1) ;; `every' + :use-module (test-suite lib)) + (define exception:invalid-char-set-cursor (cons 'misc-error "^invalid character set cursor")) @@ -186,3 +190,128 @@ (pass-if "upper case char set" (char-set= (char-set-map char-upcase char-set:lower-case) char-set:upper-case))) + +(with-test-prefix "string->char-set" + + (pass-if "some char set" + (let ((chars '(#\g #\u #\i #\l #\e))) + (char-set= (list->char-set chars) + (string->char-set (apply string chars)))))) + +;; Make sure we get an ASCII charset and character classification. +(if (defined? 'setlocale) (setlocale LC_CTYPE "C")) + +(with-test-prefix "standard char sets (ASCII)" + + (pass-if "char-set:letter" + (char-set= (string->char-set + (string-append "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + char-set:letter)) + + (pass-if "char-set:punctuation" + (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}") + char-set:punctuation)) + + (pass-if "char-set:symbol" + (char-set= (string->char-set "$+<=>^`|~") + char-set:symbol)) + + (pass-if "char-set:letter+digit" + (char-set= char-set:letter+digit + (char-set-union char-set:letter char-set:digit))) + + (pass-if "char-set:graphic" + (char-set= char-set:graphic + (char-set-union char-set:letter char-set:digit + char-set:punctuation char-set:symbol))) + + (pass-if "char-set:printing" + (char-set= char-set:printing + (char-set-union char-set:whitespace char-set:graphic)))) + + + +;;; +;;; 8-bit charsets. +;;; +;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of +;;; SRFI-14 for implementations supporting this charset is well-defined. +;;; + +(define (every? pred lst) + (not (not (every pred lst)))) + +(define (find-latin1-locale) + ;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure. + (if (defined? 'setlocale) + (let loop ((locales (map (lambda (lang) + (string-append lang ".iso88591")) + '("de_DE" "en_GB" "en_US" "es_ES" + "fr_FR" "it_IT")))) + (if (null? locales) + #f + (if (false-if-exception (setlocale LC_CTYPE (car locales))) + (car locales) + (loop (cdr locales))))) + #f)) + + +(define %latin1 (find-latin1-locale)) + +(with-test-prefix "Latin-1 (8-bit charset)" + + ;; Note: the membership tests below are not exhaustive. + + (pass-if "char-set:letter (membership)" + (if (not %latin1) + (throw 'unresolved) + (let ((letters (char-set->list char-set:letter))) + (every? (lambda (8-bit-char) + (memq 8-bit-char letters)) + (append '(#\a #\b #\c) ;; ASCII + (string->list "") ;; French + (string->list "")))))) + + (pass-if "char-set:letter (size)" + (if (not %latin1) + (throw 'unresolved) + (= (char-set-size char-set:letter) 117))) + + (pass-if "char-set:lower-case (size)" + (if (not %latin1) + (throw 'unresolved) + (= (char-set-size char-set:lower-case) (+ 26 33)))) + + (pass-if "char-set:upper-case (size)" + (if (not %latin1) + (throw 'unresolved) + (= (char-set-size char-set:upper-case) (+ 26 30)))) + + (pass-if "char-set:punctuation (membership)" + (if (not %latin1) + (thrown 'unresolved) + (let ((punctuation (char-set->list char-set:punctuation))) + (every? (lambda (8-bit-char) + (memq 8-bit-char punctuation)) + (append '(#\! #\. #\?) ;; ASCII + (string->list "") ;; Castellano + (string->list "")))))) ;; French + + (pass-if "char-set:letter+digit" + (char-set= char-set:letter+digit + (char-set-union char-set:letter char-set:digit))) + + (pass-if "char-set:graphic" + (char-set= char-set:graphic + (char-set-union char-set:letter char-set:digit + char-set:punctuation char-set:symbol))) + + (pass-if "char-set:printing" + (char-set= char-set:printing + (char-set-union char-set:whitespace char-set:graphic)))) + +;; Local Variables: +;; mode: scheme +;; coding: latin-1 +;; End: From 49dec04b6a73aa878b98ea89bd132b6dc6cf8126 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Sep 2006 13:13:34 +0000 Subject: [PATCH 035/116] Changes from arch/CVS synchronization --- doc/ref/ChangeLog | 5 +++++ doc/ref/api-data.texi | 11 +++++++++++ 2 files changed, 16 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index b784edad5..7838e31ca 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-09-20 Ludovic Courts + + * api-data.texi (Standard Character Sets): Documented the + charset recomputation upon successful `setlocale'. + 2006-09-04 Neil Jerram * api-control.texi (Dynamic Wind): Doc for scm_dynwind_free. diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index c0f5d08ef..15eac2e4b 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -2299,6 +2299,17 @@ character sets. In order to make the use of the character set data type and procedures useful, several predefined character set variables exist. +@cindex codeset +@cindex charset +@cindex locale + +Currently, the contents of these character sets are recomputed upon a +successful @code{setlocale} call (@pxref{Locales}) in order to reflect +the characters available in the current locale's codeset. For +instance, @code{char-set:letter} contains 52 characters under an ASCII +locale (e.g., the default @code{C} locale) and 117 characters under an +ISO-8859-1 (``Latin-1'') locale. + @defvr {Scheme Variable} char-set:lower-case @defvrx {C Variable} scm_char_set_lower_case All lower-case characters. From 534cd148682af22fbf6a820126fe7c1806f2d3db Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 25 Sep 2006 20:37:23 +0000 Subject: [PATCH 036/116] Fix typo. --- NEWS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 3565da8b3..0cfba4ac8 100644 --- a/NEWS +++ b/NEWS @@ -28,7 +28,7 @@ Changes in 1.8.1 (since 1.8.0): * Changes to Scheme functions and syntax -** A one-dimenisonal array can now be 'equal?' to a vector. +** A one-dimensional array can now be 'equal?' to a vector. ** Structures, records, and SRFI-9 records can now be compared with `equal?'. ** SRFI-14 standard char sets are now recomputed upon successful `setlocale'. From ee6be719ce2e34d23b6dcd0cf1095ed40261ad88 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 25 Sep 2006 21:05:46 +0000 Subject: [PATCH 037/116] * scheme-using.texi (Error Handling, Interactive Debugger): Minor editorial improvements. (Leave Debugger): Removed. (Display Backtrace): Minor updates. (Frame Selection, Frame Information, Frame Evaluation) : Minor editorial improvements. (Stepping and Continuing): Merged from three previous nodes; plus minor improvements. Removed doc for `trace-finish', which no longer exists. * debugging/ice-9-debugger-extensions.scm (debugger:step): Docstring improvements. (debugger:next): Docstring improvements. (debugger:continue): Docstring improvements. * debugger/commands.scm (up, down): Docstring corrections. (info-args, info-frame, position, evaluate): Docstring improvements. --- doc/ref/ChangeLog | 12 ++ doc/ref/scheme-using.texi | 118 +++++++++--------- ice-9/ChangeLog | 11 ++ ice-9/debugger/commands.scm | 24 ++-- ice-9/debugging/ice-9-debugger-extensions.scm | 16 ++- 5 files changed, 110 insertions(+), 71 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 7838e31ca..493da2849 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,15 @@ +2006-09-25 Neil Jerram + + * scheme-using.texi (Error Handling, Interactive Debugger): Minor + editorial improvements. + (Leave Debugger): Removed. + (Display Backtrace): Minor updates. + (Frame Selection, Frame Information, Frame Evaluation) : Minor + editorial improvements. + (Stepping and Continuing): Merged from three previous nodes; plus + minor improvements. Removed doc for `trace-finish', which no + longer exists. + 2006-09-20 Ludovic Courts * api-data.texi (Standard Character Sets): Documented the diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 6eac11aee..6ff3c0df0 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -94,7 +94,7 @@ the execution context where the error occurred and can give you three levels of information about what the error was and exactly where it occurred. -By default, Guile then displays only the first level, which is the most +By default, Guile displays only the first level, which is the most immediate information about where and why the error occurred, for example: @@ -105,7 +105,8 @@ standard input:2:19: In procedure + in expression (+ 3 #\s): standard input:2:19: Wrong type argument: #\s ABORT: (wrong-type-arg) -Type "(backtrace)" to get more information or "(debug)" to enter the debugger. +Type "(backtrace)" to get more information +or "(debug)" to enter the debugger. @end lisp @noindent @@ -156,7 +157,7 @@ frame (the @code{evaluate} command --- see @ref{Frame Evaluation}). @end itemize @noindent -This is documented further in the following section. +The interactive debugger is documented further in the following section. @node Interactive Debugger @@ -181,18 +182,21 @@ debug> @noindent ``debug>'' is the debugger's prompt, and a reminder that you are not in -the normal Guile REPL. The available commands are described in the -following subsections. +the normal Guile REPL. In case you find yourself in the debugger by +mistake, the @code{quit} command will return you to the REPL. + +@deffn {Debugger Command} quit +Exit the debugger. +@end deffn + +The other available commands are described in the following subsections. @menu * Display Backtrace:: backtrace. * Frame Selection:: up, down, frame. * Frame Information:: info args, info frame, position. * Frame Evaluation:: evaluate. -* Single Stepping:: step, next. -* Run To Frame Exit:: finish, trace-finish. -* Continue Execution:: continue. -* Leave Debugger:: quit. +* Stepping and Continuing:: step, next, (trace-)finish, continue. @end menu @@ -221,7 +225,7 @@ option @code{depth} determines the maximum number of frames printed. @end deffn The format of the displayed backtrace is the same as for the -@code{backtrace} procedure. +@code{display-backtrace} procedure (@pxref{Examining the Stack}). @node Frame Selection @@ -256,13 +260,13 @@ Frame 1 at standard input:36:14 @deffn {Debugger Command} up [n] Move @var{n} frames up the stack. For positive @var{n}, this -advances toward the outermost frame, to higher frame numbers, to +advances toward the outermost frame, to lower frame numbers, to frames that have existed longer. @var{n} defaults to one. @end deffn @deffn {Debugger Command} down [n] Move @var{n} frames down the stack. For positive @var{n}, this -advances toward the innermost frame, to lower frame numbers, to frames +advances toward the innermost frame, to higher frame numbers, to frames that were created more recently. @var{n} defaults to one. @end deffn @@ -276,85 +280,79 @@ frame to select; it must be a stack-frame number. @node Frame Information @subsubsection Frame Information -[to be completed] +The following commands return detailed information about the currently +selected frame. @deffn {Debugger Command} {info frame} -All about selected stack frame. +Display a verbose description of the selected frame. The information +that this command provides is equivalent to what can be deduced from the +one line summary for the frame that appears in a backtrace, but is +presented and explained more clearly. @end deffn @deffn {Debugger Command} {info args} -Argument variables of current stack frame. +Display the argument variables of the current stack frame. Arguments +can also be seen in the backtrace, but are presented more clearly by +this command. @end deffn @deffn {Debugger Command} position -Display the position of the current expression. +Display the name of the source file that the current expression comes +from, and the line and column number of the expression's opening +parenthesis within that file. This information is only available when +the @code{positions} read option is enabled (@pxref{Reader options}). @end deffn @node Frame Evaluation @subsubsection Frame Evaluation -[to be completed] +The @code{evaluate} command is most useful for querying the value of a +variable, either global or local, in the environment of the selected +stack frame, but it can be used more generally to evaluate any +expression. @deffn {Debugger Command} evaluate expression -Evaluate an expression. -The expression must appear on the same line as the command, -however it may be continued over multiple lines. +Evaluate an expression in the environment of the selected stack frame. +The expression must appear on the same line as the command, however it +may be continued over multiple lines. @end deffn -@node Single Stepping -@subsubsection Single Stepping +@node Stepping and Continuing +@subsubsection Single Stepping and Continuing Execution -[to be completed] +The commands in this subsection all apply only when the stack is +@dfn{continuable} --- in other words when it makes sense for the program +that the stack comes from to continue running. Usually this means that +the program stopped because of a trap or a breakpoint. @deffn {Debugger Command} step [n] -Tell the debugged program to do @var{n} single-steps to the next frame -entry or exit of any kind. @var{n} defaults to 1. +Tell the debugged program to do @var{n} more steps from its current +position. One @dfn{step} means executing until the next frame entry or +exit of any kind. @var{n} defaults to 1. @end deffn @deffn {Debugger Command} next [n] -Tell the debugged program to do @var{n} single-steps to the entry or -exit of a frame whose code comes from the same source file as the -selected stack frame. (See @ref{Step Traps} for the details of how -this works.) If the selected stack frame has no source, the effect of -this command is the same as of @code{step}. @var{n} defaults to 1. +Tell the debugged program to do @var{n} more steps from its current +position, but only counting frame entries and exits where the +corresponding source code comes from the same file as the current stack +frame. (See @ref{Step Traps} for the details of how this works.) If +the current stack frame has no source code, the effect of this command +is the same as of @code{step}. @var{n} defaults to 1. @end deffn - -@node Run To Frame Exit -@subsubsection Run To Frame Exit - -[to be completed] - @deffn {Debugger Command} finish -Tell the program being debugged to continue running until the -completion of the selected stack frame, and at that time to print the -result and reenter the command line debugger. +Tell the program being debugged to continue running until the completion +of the current stack frame, and at that time to print the result and +reenter the command line debugger. @end deffn -@deffn {Debugger Command} trace-finish -Trace until evaluation of the current frame is complete. -@end deffn - - -@node Continue Execution -@subsubsection Continue Execution - -[to be completed] - @deffn {Debugger Command} continue -Tell the program being debugged to continue running. -@end deffn - - -@node Leave Debugger -@subsubsection Leave Debugger - -[to be completed] - -@deffn {Debugger Command} quit -Exit the debugger. +Tell the program being debugged to continue running. (In fact this is +the same as the @code{quit} command, because it exits the debugger +command loop and so allows whatever code it was that invoked the +debugger to continue.) @end deffn diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c2ff7715a..9786388b5 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,14 @@ +2006-09-25 Neil Jerram + + * debugging/ice-9-debugger-extensions.scm (debugger:step): + Docstring improvements. + (debugger:next): Docstring improvements. + (debugger:continue): Docstring improvements. + + * debugger/commands.scm (up, down): Docstring corrections. + (info-args, info-frame, position, evaluate): Docstring + improvements. + 2006-08-18 Neil Jerram * debugging/trc.scm: New file. diff --git a/ice-9/debugger/commands.scm b/ice-9/debugger/commands.scm index 1d716e2bb..ef6f79026 100644 --- a/ice-9/debugger/commands.scm +++ b/ice-9/debugger/commands.scm @@ -67,9 +67,9 @@ If the number of frames isn't explicitly given, the debug option (throw 'continue)) (define (evaluate state expression) - "Evaluate an expression. -The expression must appear on the same line as the command, -however it may be continued over multiple lines." + "Evaluate an expression in the environment of the selected stack frame. +The expression must appear on the same line as the command, however it +may be continued over multiple lines." (let ((source (frame-source (stack-ref (state-stack state) (state-index state))))) (if (not source) @@ -100,18 +100,26 @@ however it may be continued over multiple lines." (lambda args args))))) (define (info-args state) - "Argument variables of current stack frame." + "Display the argument variables of the current stack frame. +Arguments can also be seen in the backtrace, but are presented more +clearly by this command." (let ((index (state-index state))) (let ((frame (stack-ref (state-stack state) index))) (write-frame-index-long frame) (write-frame-args-long frame)))) (define (info-frame state) - "All about selected stack frame." + "Display a verbose description of the selected frame. The +information that this command provides is equivalent to what can be +deduced from the one line summary for the frame that appears in a +backtrace, but is presented and explained more clearly." (write-state-long state)) (define (position state) - "Display the position of the current expression." + "Display the name of the source file that the current expression +comes from, and the line and column number of the expression's opening +parenthesis within that file. This information is only available when +the 'positions read option is enabled." (let* ((frame (stack-ref (state-stack state) (state-index state))) (source (frame-source frame))) (if (not source) @@ -124,14 +132,14 @@ however it may be continued over multiple lines." (define (up state n) "Move @var{n} frames up the stack. For positive @var{n}, this -advances toward the outermost frame, to higher frame numbers, to +advances toward the outermost frame, to lower frame numbers, to frames that have existed longer. @var{n} defaults to one." (set-stack-index! state (+ (state-index state) (or n 1))) (write-state-short state)) (define (down state n) "Move @var{n} frames down the stack. For positive @var{n}, this -advances toward the innermost frame, to lower frame numbers, to frames +advances toward the innermost frame, to higher frame numbers, to frames that were created more recently. @var{n} defaults to one." (set-stack-index! state (- (state-index state) (or n 1))) (write-state-short state)) diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm index dc1eb8fc8..217d935b9 100644 --- a/ice-9/debugging/ice-9-debugger-extensions.scm +++ b/ice-9/debugging/ice-9-debugger-extensions.scm @@ -45,7 +45,10 @@ (user-error "This debug session is not continuable."))) (define (debugger:continue state) - "Continue program execution." + "Tell the program being debugged to continue running. (In fact this is +the same as the @code{quit} command, because it exits the debugger +command loop and so allows whatever code it was that invoked the +debugger to continue.)" (assert-continuable state) (throw 'exit-debugger)) @@ -59,13 +62,20 @@ print the result obtained." (debugger:continue state)) (define (debugger:step state n) - "Continue until entry to @var{n}th next frame." + "Tell the debugged program to do @var{n} more steps from its current +position. One @dfn{step} means executing until the next frame entry +or exit of any kind. @var{n} defaults to 1." (assert-continuable state) (at-step debug-trap (or n 1)) (debugger:continue state)) (define (debugger:next state n) - "Continue until entry to @var{n}th next frame in same file." + "Tell the debugged program to do @var{n} more steps from its current +position, but only counting frame entries and exits where the +corresponding source code comes from the same file as the current +stack frame. (See @ref{Step Traps} for the details of how this +works.) If the current stack frame has no source code, the effect of +this command is the same as of @code{step}. @var{n} defaults to 1." (assert-continuable state) (at-step debug-trap (or n 1) From 94a2c24a6406c788ca295f7e738f55ffa44c8e45 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 26 Sep 2006 21:43:52 +0000 Subject: [PATCH 038/116] (Using Guile in Emacs, GDS Introduction): Editorial updates. (GDS Architecture): Moved earlier in containing section; editorial updates. (GDS Getting Started, How to Use GDS): Merged; editorial updates; subsections reordered. --- doc/ref/ChangeLog | 9 + doc/ref/scheme-using.texi | 434 ++++++++++++++++---------------------- 2 files changed, 188 insertions(+), 255 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 493da2849..0768f1d8d 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,12 @@ +2006-09-26 Neil Jerram + + * scheme-using.texi (Using Guile in Emacs, GDS Introduction): + Editorial updates. + (GDS Architecture): Moved earlier in containing section; editorial + updates. + (GDS Getting Started, How to Use GDS): Merged; editorial updates; + subsections reordered. + 2006-09-25 Neil Jerram * scheme-using.texi (Error Handling, Interactive Debugger): Minor diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 6ff3c0df0..c19823683 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -389,7 +389,7 @@ highlighting, parenthesis matching, indentation and so on. @dfn{cmuscheme}, written by Olin Shivers, provides a comint-based Scheme interaction buffer, so that you can run an interpreter more directly -than with the @code{*shell*} buffer approach by typing @kbd{@key{M-x} +than with the @code{*shell*} buffer approach by typing @kbd{M-x run-scheme}. It also extends @code{scheme-mode} so that there are key presses for sending selected bits of code from a Scheme buffer to this interpreter. This means that when you are writing some code and want to @@ -418,7 +418,7 @@ output like this. Instead, it sets up a socket connection between the Scheme interpreter and Emacs, and sends and receives messages using a simple protocol through this socket. The messages include requests to evaluate Scheme code, and responses conveying the results of an -evaluation, thus providing similar function to cmuscheme or Quack; they +evaluation, thus providing similar function to cmuscheme or Quack. They also include requests for setting breakpoints, stack exploration and debugging, which go beyond what cmuscheme or Quack can do. The price of this extra power, however, is that GDS is Guile-specific. GDS requires @@ -430,25 +430,25 @@ previous Guile releases (1.8.x and earlier) it can be obtained as part of the @code{guile-debugging} package from @uref{http://www.ossau.uklinux.net/guile}. -Finally, @dfn{xscheme} is similar to cmuscheme -- in that it starts up a -Scheme interaction process and sends commands to that process's standard -input -- and to GDS -- in that it has support beyond cmuscheme or Quack -for exploring the Scheme stack when an error has occurred -- but is -implemented specifically for MIT/GNU Scheme. Hence it isn't really -relevant to Guile work in Emacs, except as a reference for useful -features that could be implemented in one of the other libraries -mentioned here. +Finally, @dfn{xscheme} is similar to cmuscheme --- in that it starts up +a Scheme interaction process and sends commands to that process's +standard input --- and to GDS --- in that it has support beyond +cmuscheme or Quack for exploring the Scheme stack when an error has +occurred --- but is implemented specifically for MIT/GNU Scheme. Hence +it isn't really relevant to Guile work in Emacs, except as a reference +for useful features that could be implemented in one of the other +libraries mentioned here. -In summary, the ``best'' current choice for working on Guile code in -Emacs is either Quack or GDS, depending on which of these libraries' -features you find most important. For more information on Quack, please -see the website referenced above. GDS is documented further in the rest -of this section. +In summary, the best current choice for working on Guile code in Emacs +is either Quack or GDS, depending on which of these libraries' features +you find most important. For more information on Quack, please see the +website referenced above. GDS is documented further in the rest of this +section. @menu * GDS Introduction:: +* GDS Architecture:: * GDS Getting Started:: -* How To Use GDS:: * Displaying the Scheme Stack:: * Continuing Execution:: * Evaluating Scheme Code:: @@ -456,7 +456,6 @@ of this section. * Access to Guile Help and Completion:: * Associating Buffers with Clients:: * An Example GDS Session:: -* GDS Architecture:: @end menu @@ -466,7 +465,7 @@ of this section. GDS aims to allow you to work on Guile Scheme code in the same kind of way that Emacs allows you to work on Emacs Lisp code: providing easy access to help, evaluating arbitrary fragments of code, a nice debugging -interface, and so on. The thinking behind this environment is that you +interface, and so on. The thinking behind the GDS library is that you will usually be doing one of two things. @enumerate @@ -477,17 +476,19 @@ the things that are likely to be useful to you when working on code: @itemize @item -completing the identifier at point +completing the identifier at point, with respect to the set of variable +names that are known to the associated Guile process @item -accessing Guile's built in help +accessing Guile's built in ``help'' and ``apropos'' commands @item -evaluating fragments of code to check what they do. +evaluating fragments of code to check what they do, with the results +popping up in a temporary Emacs window. @end itemize @item Debugging a Guile Scheme program. When your program hits an error or a -breakpoint, GDS can show you the relevant code and the Scheme stack, and -make it easy to +breakpoint, GDS shows you the relevant code and the Scheme stack, and +makes it easy to @itemize @item @@ -495,156 +496,192 @@ look at the values of local variables @item see what is happening at all levels of the Scheme stack @item +set new breakpoints (by simply typing @kbd{C-x @key{SPC}}) or modify +existing ones +@item continue execution, either normally or step by step. @end itemize @end enumerate -Combinations of these work well too. You can evaluate a fragment of +The presentation makes it very easy to move up and down the stack, +showing whenever possible the source code for each frame in another +Emacs buffer. It also provides convenient keystrokes for telling Guile +what to do next; for example, you can select a stack frame and tell +Guile to run until that frame completes, at which point GDS will display +the frame's return value. + +Combinations of the above work well too. You can evaluate a fragment of code (in a Scheme buffer) that contains a breakpoint, then use the -debugging interface to step through the code at the breakpoint. You -can also run a program until it hits a breakpoint, then examine, -modify and reevaluate some of the relevant code, and then tell the -program to continue running. - -In other words, we could say that GDS provides a set of facilities which -aim to make the writing, debugging and maintenance of Scheme code in -Emacs as fluid and productive as possible. In a bit more detail, these -facilities are currently as follows. - -@table @asis -@item Displaying the Scheme stack -When running Scheme code hits a trap or throws an exception, GDS can -display the stack at the point of the trap or exception. The -presentation makes it very easy to move up and down the stack, showing -whenever possible the source code for each frame in another Emacs -buffer, and allowing you to evaluate test expressions in the context of -the selected frame. - -@item Continuing execution from a trap -When GDS is showing the stack for code that has hit a trap, it also -allows you to control how execution continues from that point. For -example you can select a stack frame and tell Guile to run until that -frame completes, at which point GDS will display the frame's return -value. - -@item Evaluating Scheme code -GDS allows you to select a region of a Scheme buffer and send it to -Guile for evaluation, or to enter a Scheme expression to be evaluated in -the Emacs minibuffer. In both cases the evaluation results are popped -up in a temporary Emacs window. - -@item Setting breakpoints in Scheme code -GDS makes it easy to set breakpoints in Scheme code from within Emacs. -Deep down this uses Guile's trap and breakpoint infrastructure described -elsewhere in this manual, but GDS makes the practicalities as simple as -typing @kbd{C-x @key{SPC}}. When a GDS breakpoint is hit, the stack at -that point is popped up in Emacs. GDS also remembers your breakpoints -between editing sessions, so you don't have to set them again when you -visit the relevant files. - -@item Access to Guile's built in help system -GDS makes it easy to query Guile's ``help'' and ``apropos'' commands, -and pops up the results in a temporary Emacs window. - -@item Symbol completion -GDS provides a keystroke which tries to complete a partially entered -symbol by asking Guile to match it against all the accessible bindings. -@end table +debugging interface to step through the code at the breakpoint. You can +also run a program until it hits a breakpoint, then examine, modify and +reevaluate some of the relevant code, and then tell the program to +continue running. GDS can provide these facilities for any number of Guile Scheme programs -(which we often call ``clients'') at once, and these programs can be -started either completely independently of GDS, including outside Emacs, -or specifically @emph{by} GDS. The two common cases are: +(which we often refer to as ``clients'') at once, and these programs can +be started either independently of GDS, including outside Emacs, or +specifically @emph{by} GDS. -@itemize -@item -a Guile application, such as @uref{http://www.gnucash.org, GnuCash}, -which is started from your desktop, and which connects to GDS as a -result of some incantation added to its startup code - -@item -a ``utility'' Guile process which is run by GDS to provide help, -completion and evaluation for Scheme code that you are working on in -Emacs. -@end itemize - -@noindent -The user experience --- in other words the ways that the GDS front end -allows you to interact with the client --- is much the same in all -cases. - -Communication between the Guile client program and GDS uses a TCP +Communication between each Guile client program and GDS uses a TCP socket, which means that it is orthogonal to any other interfaces that the client program has. In particular GDS does not interfere with a program's standard input and output. +@node GDS Architecture +@subsection GDS Architecture + +In order to understand the following documentation fully it will help to +have a picture in mind of how GDS works, so we briefly describe that +here. GDS consists of three components. + +@itemize +@item +The GDS @dfn{interface} code is written in Emacs Lisp and runs inside +Emacs. This code, consisting of the installed files @file{gds.el} and +@file{gds-server.el}, is responsible for displaying information from +Guile in Emacs windows, and for responding to Emacs commands and +keystrokes by sending instructions back to the Guile program being +debugged. + +@item +The GDS @dfn{server} code is written in Scheme and runs as an Emacs +inferior process. It acts as a multiplexer between the (possibly +multiple) Guile programs being debugged and the interface code running +in Emacs. The server code is the installed file +@file{gds-server.scm}. + +@item +The GDS @dfn{client} code is written in Scheme (installed file +@file{gds-client.scm}), and must be loaded as a module by each Guile +program that wants to use GDS in any way. +@end itemize + +@noindent +The following diagram shows how these components are connected to each +other. + +@example ++----------------+ +| Program #1 | +| | +| +------------+ | +| | GDS Client |-_ +| +------------+ |-_ +-------------------+ ++----------------+ -_TCP | Emacs | + -_ | | + -_+------------+ | +---------------+ | + _| GDS Server |-----| GDS Interface | | ++----------------+ _- +------------+ | +---------------+ | +| Program #2 | _- +-------------------+ +| | _- TCP +| +------------+ _- +| | GDS Client |-| +| +------------+ | ++----------------+ +@end example + +@cindex TCP, use of +The data exchanged between client and server components, and between +server and interface, is a sequence of sexps (parenthesised expressions) +that are designed so as to be directly readable by both Scheme and Emacs +Lisp. The use of a TCP connection means that the server and Emacs +interface can theoretically be on a different computer from the programs +being debugged, but in practice there are currently two problems with +this. Firstly the GDS API doesn't provide any way of specifying a +non-local server to connect to, and secondly there is no security or +authentication mechanism in the GDS protocol. These are issues that +should be addressed in the near future. + + @node GDS Getting Started @subsection Getting Started with GDS -GDS's Scheme and Emacs Lisp files will have been installed in the -correct places system-wide when Guile as a whole was installed. To -enable the use of GDS in your own Emacs sessions, simply add +To enable the use of GDS in your own Emacs sessions, simply add @lisp (require 'gds) @end lisp @noindent -somewhere in your @file{.emacs} file. +somewhere in your @file{.emacs} file. This will cause Emacs to load the +GDS Emacs Lisp code when starting up, and to start the inferior GDS +server process so that it is ready and waiting for any Guile programs +that want to use GDS. -For a hands-on, tutorial introduction to using GDS, you may then like to -use Emacs to open the file @file{gds-tutorial.txt} (which should have -been installed as part of Guile, perhaps under -@file{/usr/share/doc/guile}), and then follow the steps in that file. +(If GDS's Scheme code is not installed in one of the locations in +Guile's load path, you may find that the server process fails to start. +When this happens you will see an error message from Emacs: +@lisp +error in process filter: Wrong type argument: listp, Backtrace: +@end lisp -@node How To Use GDS -@subsection How To Use GDS +@noindent +and the @code{gds-debug} buffer will contain a Scheme backtrace ending +with the message: -There are lots of ways to use GDS, but they boil down to two overall -approaches. +@lisp +no code for module (ossau gds-server) +@end lisp -@enumerate -@item -When you are writing Scheme code in Emacs, you can use GDS while you are -writing to help with things like name completion, looking up help, and -evaluating fragments of code to check that they do what you expect. +@noindent +The solution for this is to customize the Emacs variable +@code{gds-scheme-directory} so that it specifies where the GDS Scheme +code is installed. Then either restart Emacs or type @kbd{M-x +gds-run-debug-server} to try starting the GDS server process again.) -The first time you do something that needs a running Guile process, GDS -will automatically create one as an Emacs subprocess. This Guile -program does nothing but wait for and act on instructions from GDS, and -we refer to it as a @dfn{utility} Guile client. +For evaluations, help and completion from Scheme code buffers that you +are working on, this is all you need. The first time you do any of +these things, GDS will automatically start a new Guile client program as +an Emacs subprocess. This Guile program does nothing but wait for and +act on instructions from GDS, and we refer to it as a @dfn{utility} +Guile client. Over time this utility client will accumulate the code +that you ask it to evaluate, and you can also tell it to load complete +files or modules by sending it @code{load} or @code{use-modules} +expressions. You can set breakpoints and evaluate code which hits those +breakpoints, and GDS will pop up the stack at the breakpoint so you can +explore your code by single-stepping and evaluating test expressions. -Over time this utility Guile will accumulate the code that you ask it to -evaluate, and you can also tell it to load complete files or modules by -sending it @code{load} or @code{use-modules} expressions. You can set -breakpoints and evaluate code which hits those breakpoints, and GDS will -pop up the stack at the breakpoint so you can explore your code by -single-stepping and evaluating test expressions. +For a hands-on, tutorial introduction to using GDS in this way, use +Emacs to open the file @file{gds-tutorial.txt} (which should have been +installed as part of Guile, perhaps under @file{/usr/share/doc/guile}), +and then follow the steps in that file. -@item -Alternatively, you can use GDS to explore and debug a Guile program or -script which is started independently of GDS. This could be a script -that you invoke from the command line, or a graphical Guile-using -application which is launched from your desktop's start menu. +When you want to use GDS to explore or debug an independent Guile +application, you need to add something to that application's Scheme code +to cause it to connect to and interact with GDS at the right times. The +following subsections describe the various ways of doing this. -In this case the program has to put something in its startup code to -cause it to connect to GDS at some point: either immediately during the -startup processing, or later when an error occurs or a trap is hit. -Several possibilities for this are described below. +@subsubsection Setting Specific Breakpoints -Under certain conditions, then, the program will stop, pass its current -Scheme stack to GDS, and then wait for instruction before continuing -execution. At such points you can use GDS to explore the stack, -obviously, but also to set or delete other breakpoints, modify the -program's code (by editing and then reevaluating it from Emacs), and use -the help and completion facilities, before eventually telling the -program to single-step or to continue running normally. -@end enumerate +@lisp +(use-modules (ice-9 debugging breakpoints) + (ice-9 gds-client)) -Here are some of the ways that a Guile program or script can arrange in -its startup code to use GDS. +(break-in 'fact2 "ice-9/debugging/example-fns" + #:behaviour gds-debug-trap) +@end lisp + +In this example, the program chooses to define its breakpoint explicitly +in its code, rather than downloading definitions from GDS, but it still +uses GDS to control what happens when the breakpoint is hit, by +specifying @code{gds-debug-trap} as the breakpoint behaviour. + +@subsubsection Setting GDS-managed Breakpoints + +@lisp +(use-modules (ice-9 gds-client)) +(set-gds-breakpoints) +@end lisp + +These lines tell the program to connect to GDS immediately and download +a set of breakpoint definitions. The program sets those breakpoints in +its code, then continues running. + +When the program later hits one of the breakpoints, it will use GDS to +display the stack and wait for instruction on what to do next, as +described above. @subsubsection Invoking GDS when an Exception Occurs @@ -668,36 +705,6 @@ so you can add the above lines to your @file{.guile} file if you want to use GDS whenever something that you type into the REPL throws an exception. -@subsubsection Setting GDS-managed Breakpoints - -@lisp -(use-modules (ice-9 gds-client)) -(set-gds-breakpoints) -@end lisp - -These lines tell the program to connect to GDS immediately and download -a set of breakpoint definitions. The program sets those breakpoints in -its code, then continues running. - -When the program later hits one of the breakpoints, it will use GDS to -display the stack and wait for instruction on what to do next, as -described above. - -@subsubsection Setting Specific Breakpoints - -@lisp -(use-modules (ice-9 debugging breakpoints) - (ice-9 gds-client)) - -(break-in 'fact2 "ice-9/debugging/example-fns" - #:behaviour gds-debug-trap) -@end lisp - -In this example, the program chooses to define its breakpoint explicitly -in its code, rather than downloading definitions from GDS, but it still -uses GDS to control what happens when the breakpoint is hit, by -specifying @code{gds-debug-trap} as the breakpoint behaviour. - @subsubsection Accepting GDS Instructions at Any Time In addition to setting breakpoints and/or an exception handler as @@ -1075,8 +1082,8 @@ Now select all of this code and type @kbd{C-c C-r} to send the selected region to Guile for evaluation. GDS will ask you which Guile process to use; unless you know that you already have another Guile application running and connected to GDS, choose the ``Start a new Guile'' option, -which starts one of the ``utility'' processes described in @ref{How To -Use GDS}. +which starts one of the ``utility'' processes described in @ref{GDS +Getting Started}. The results of the evaluation pop up in a window like this: @@ -1176,89 +1183,6 @@ pressing of @kbd{@key{SPC}} successfully single-steps through this file.) -@node GDS Architecture -@subsection GDS Architecture - -Ths following information may be of interest to readers who would like -to know how GDS works. Please note that understanding the details of -this subsection is completely optional so far as just using GDS is -concerned! - -GDS consists of three components. - -@itemize -@item -The GDS @dfn{interface} code is written in Emacs Lisp and runs inside -Emacs. This code, consisting of the installed files @file{gds.el} and -@file{gds-server.el}, is responsible for displaying information from -Guile in Emacs windows, and for responding to Emacs commands and -keystrokes by sending instructions back to the Guile program being -debugged. - -@item -The GDS @dfn{server} code is written in Scheme and runs as an Emacs -inferior process. It acts as a multiplexer between the (possibly -multiple) Guile programs being debugged and the interface code running -in Emacs. The server code is the installed file -@file{gds-server.scm}. - -@item -The GDS @dfn{client} code is written in Scheme (installed file -@file{gds-client.scm}), and is loaded as a module by each Guile -program that wants to use GDS for debugging. When a trap occurs whose -behaviour is @code{gds-debug-trap}, it feeds information about the -trap context through the server to Emacs, then waits for instruction -back from the Emacs interface on what to do next. -@end itemize - -@noindent -Summarized in glorious ASCII art, this looks as follows. - -@example -+------------+ -| Program #1 | -| | -| +--------+ | -| | Client |-_ -| +--------+ |-_ +---------------+ -+------------+ -_TCP | Emacs | - -_ | | - -_+--------+ | +-----------+ | - _| Server |-----| Interface | | -+------------+ _- +--------+ | +-----------+ | -| Program #2 | _- +---------------+ -| | _- TCP -| +--------+ _- -| | Client |-| -| +--------+ | -+------------+ -@end example - -@noindent -@cindex TCP, use of -The communication between the client and server components is over a -TCP connection, which has two implications. Firstly, that GDS is -independent of whatever other interfaces the programs being debugged -have, whether graphical or through standard input and output. -Secondly, that the server and Emacs interface can be on a different -computer from the programs being debugged (only theoretically, though, -because GDS doesn't yet provide an interface to connect to any server -other than the default, on localhost at TCP port 8333). The data -exchanged between client and server components, and between server and -interface components, is in the form of sexps that are organized so as -to be directly readable by both Scheme and Emacs Lisp. - - -@subsubsection Security Note - -@cindex Security -GDS currently has no authentication between its client and server -components, so in an untrusted environment the use of TCP probably -raises important security issues. If you are thinking of using GDS in -such an environment, please consider any such issues carefully before -proceeding! - - @c Local Variables: @c TeX-master: "guile.texi" @c End: From 5695ccd43b051caf99f1ca94f00f7231c1466439 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 27 Sep 2006 17:49:38 +0000 Subject: [PATCH 039/116] =?UTF-8?q?(Slot=20Options):=20Added=20example=20f?= =?UTF-8?q?rom=20Ludovic=20Court=C3=A8s=20about=20difference=20between=20i?= =?UTF-8?q?nit-value,=20-form=20and=20-thunk.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- doc/goops/ChangeLog | 5 +++++ doc/goops/goops.texi | 36 ++++++++++++++++++++++++++++++++++-- 2 files changed, 39 insertions(+), 2 deletions(-) diff --git a/doc/goops/ChangeLog b/doc/goops/ChangeLog index f9c43e60b..22a5c82c2 100644 --- a/doc/goops/ChangeLog +++ b/doc/goops/ChangeLog @@ -1,3 +1,8 @@ +2006-09-27 Neil Jerram + + * goops.texi (Slot Options): Added example from Ludovic Courts + about difference between init-value, -form and -thunk. + 2006-04-21 Kevin Ryde * hierarchy.pdf: New file, converted from hierarchy.eps using diff --git a/doc/goops/goops.texi b/doc/goops/goops.texi index 171ac2bfa..d6d8e595d 100644 --- a/doc/goops/goops.texi +++ b/doc/goops/goops.texi @@ -838,8 +838,40 @@ value (shared across all new instances of the class). when a new instance is created and should return the desired initial slot value. @var{init-form} is an unevaluated expression that gets evaluated when a new instance is created and should return the desired -initial slot value. @var{init-keyword} is a keyword that can be used to -pass an initial slot value to @code{make} when creating a new instance. +initial slot value. @var{init-keyword} is a keyword that can be used +to pass an initial slot value to @code{make} when creating a new +instance. + +Note that, since an @code{init-value} value is shared across all +instances of a class, you should only use it when the initial value is +an immutable value, like a constant. If you want to initialize a slot +with a fresh, independently mutable value, you should use +@code{init-thunk} or @code{init-form} instead. Consider the following +example. + +@example +(define-class () + (hashtab #:init-value (make-hash-table))) +@end example + +@noindent +Here only one hash table is created and all instances of +@code{} have their @code{hashtab} slot refer to it. In order +to have each instance of @code{} refer to a new hash table, you +should instead write: + +@example +(define-class () + (hashtab #:init-thunk make-hash-table)) +@end example + +@noindent +or: + +@example +(define-class () + (hashtab #:init-form (make-hash-table))) +@end example If more than one of these options is specified for the same slot, the order of precedence, highest first is From 4695789c02aea86ed6159ffb72d8dc4c2ec83c0f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 28 Sep 2006 07:32:40 +0000 Subject: [PATCH 040/116] (Symbol Props): Remove unnecessarily specific parenthesis about Guile 1.6's use of extra symbol slots. --- doc/ref/ChangeLog | 5 +++++ doc/ref/api-data.texi | 6 ++---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0768f1d8d..f646fa876 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-09-28 Neil Jerram + + * api-data.texi (Symbol Props): Remove unnecessarily specific + parenthesis about Guile 1.6's use of extra symbol slots. + 2006-09-26 Neil Jerram * scheme-using.texi (Using Guile in Emacs, GDS Introduction): diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 15eac2e4b..4534f8a6e 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -4674,10 +4674,8 @@ see @code{symbol-property}. @end deffn Support for these extra slots may be removed in a future release, and it -is probably better to avoid using them. (In release 1.6, Guile itself -uses the property list slot sparingly, and the function slot not at -all.) For a more modern and Schemely approach to properties, see -@ref{Object Properties}. +is probably better to avoid using them. For a more modern and Schemely +approach to properties, see @ref{Object Properties}. @node Symbol Read Syntax From 4f6e3015832482b95daf5b4d0b3b62e7d6bd15e7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 28 Sep 2006 07:41:49 +0000 Subject: [PATCH 041/116] (GDS Introduction, GDS Getting Started): Minor edits. --- doc/ref/ChangeLog | 3 +++ doc/ref/scheme-using.texi | 11 +++++------ 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index f646fa876..5bcf1cb0d 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,5 +1,8 @@ 2006-09-28 Neil Jerram + * scheme-using.texi (GDS Introduction, GDS Getting Started): Minor + edits. + * api-data.texi (Symbol Props): Remove unnecessarily specific parenthesis about Guile 1.6's use of extra symbol slots. diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index c19823683..27e82da2c 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -501,7 +501,6 @@ existing ones @item continue execution, either normally or step by step. @end itemize -@end enumerate The presentation makes it very easy to move up and down the stack, showing whenever possible the source code for each frame in another @@ -509,11 +508,12 @@ Emacs buffer. It also provides convenient keystrokes for telling Guile what to do next; for example, you can select a stack frame and tell Guile to run until that frame completes, at which point GDS will display the frame's return value. +@end enumerate -Combinations of the above work well too. You can evaluate a fragment of -code (in a Scheme buffer) that contains a breakpoint, then use the -debugging interface to step through the code at the breakpoint. You can -also run a program until it hits a breakpoint, then examine, modify and +Combinations of these well too. You can evaluate a fragment of code (in +a Scheme buffer) that contains a breakpoint, then use the debugging +interface to step through the code at the breakpoint. You can also run +a program until it hits a breakpoint, then examine, modify and reevaluate some of the relevant code, and then tell the program to continue running. @@ -642,7 +642,6 @@ files or modules by sending it @code{load} or @code{use-modules} expressions. You can set breakpoints and evaluate code which hits those breakpoints, and GDS will pop up the stack at the breakpoint so you can explore your code by single-stepping and evaluating test expressions. - For a hands-on, tutorial introduction to using GDS in this way, use Emacs to open the file @file{gds-tutorial.txt} (which should have been installed as part of Guile, perhaps under @file{/usr/share/doc/guile}), From 63258dc9a16dec8987c623faf507b51cf560294b Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 30 Sep 2006 17:21:52 +0000 Subject: [PATCH 042/116] (debug-trap): Use `debugger-command-loop' instead of `read-and-dispatch-commands', which isn't actually available. Thanks to Carlos Pita for reporting this. (debugger-command-loop): Define here for 1.6.x. --- THANKS | 1 + ice-9/ChangeLog | 8 ++++++++ ice-9/debugging/ice-9-debugger-extensions.scm | 7 ++++++- 3 files changed, 15 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 769bef739..59eaf13f9 100644 --- a/THANKS +++ b/THANKS @@ -59,6 +59,7 @@ For fixes or providing information which led to a fix: Arno Peters Ron Peterson David Pirotte + Carlos Pita Ken Raeburn Andreas Rottmann Kevin Ryde diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 9786388b5..2385a45f8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2006-09-30 Neil Jerram + + * debugging/ice-9-debugger-extensions.scm (debug-trap): Use + `debugger-command-loop' instead of `read-and-dispatch-commands', + which isn't actually available. Thanks to Carlos Pita for + reporting this. + (debugger-command-loop): Define here for 1.6.x. + 2006-09-25 Neil Jerram * debugging/ice-9-debugger-extensions.scm (debugger:step): diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm index 217d935b9..2770c1f73 100644 --- a/ice-9/debugging/ice-9-debugger-extensions.scm +++ b/ice-9/debugging/ice-9-debugger-extensions.scm @@ -121,6 +121,11 @@ print the result obtained." (define *not-yet-introduced* #t) +(cond ((string>=? (version) "1.7")) + (else + (define (debugger-command-loop state) + (read-and-dispatch-commands state (current-input-port))))) + (define-public (debug-trap trap-context) "Invoke the Guile debugger to explore the stack at the specified @var{trap}." (start-stack 'debugger @@ -144,7 +149,7 @@ print the result obtained." (display "There is 1 frame on the stack.\n\n") (format #t "There are ~A frames on the stack.\n\n" ssize)))) (write-state-short-with-source-location state) - (read-and-dispatch-commands state (current-input-port))))) + (debugger-command-loop state)))) (define write-state-short-with-source-location (cond ((string>=? (version) "1.7") From 1e1387ca1e47044ae29c79fd121dcdad6b2d83e5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 3 Oct 2006 19:20:50 +0000 Subject: [PATCH 043/116] (GDS Getting Started): Editorial updates. --- doc/ref/ChangeLog | 4 ++ doc/ref/scheme-using.texi | 102 ++++++++++++++++++++++++++------------ 2 files changed, 75 insertions(+), 31 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 5bcf1cb0d..f95ec8915 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2006-10-03 Neil Jerram + + * scheme-using.texi (GDS Getting Started): Editorial updates. + 2006-09-28 Neil Jerram * scheme-using.texi (GDS Introduction, GDS Getting Started): Minor diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 27e82da2c..ac7f71005 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -654,21 +654,33 @@ following subsections describe the various ways of doing this. @subsubsection Setting Specific Breakpoints +The first option is to use @code{break-in} or @code{break-at} to set +specific breakpoints in the application's code. This requires code like +the following. + @lisp (use-modules (ice-9 debugging breakpoints) (ice-9 gds-client)) (break-in 'fact2 "ice-9/debugging/example-fns" #:behaviour gds-debug-trap) +(break-in 'facti "ice-9/debugging/example-fns" + #:behaviour gds-debug-trap) @end lisp -In this example, the program chooses to define its breakpoint explicitly -in its code, rather than downloading definitions from GDS, but it still -uses GDS to control what happens when the breakpoint is hit, by -specifying @code{gds-debug-trap} as the breakpoint behaviour. +@noindent +The @code{#:behaviour gds-debug-trap} clauses mean to use GDS to display +the stack when one of these breakpoints is hit. For more on +breakpoints, @code{break-in} and @code{break-at}, see @ref{Intro to +Breakpoints}. @subsubsection Setting GDS-managed Breakpoints +Instead of listing specific breakpoints in application code, you can use +GDS to manage the set of breakpoints that you want from Emacs, and tell +the application to download the breakpoints that it should set from +GDS. The code for this is: + @lisp (use-modules (ice-9 gds-client)) (set-gds-breakpoints) @@ -679,11 +691,51 @@ a set of breakpoint definitions. The program sets those breakpoints in its code, then continues running. When the program later hits one of the breakpoints, it will use GDS to -display the stack and wait for instruction on what to do next, as -described above. +display the stack and wait for instruction on what to do next. @subsubsection Invoking GDS when an Exception Occurs +Another option is to use GDS to catch and display any exceptions that +are thrown by the application's code. If you already have a +@code{lazy-catch} or @code{with-throw-handler} around the area of code +that you want to monitor, you just need to add the following to the +handler code: + +@lisp +(gds-debug-trap (throw->trap-context key args)) +@end lisp + +@noindent +where @code{key} and @code{args} are the first and rest arguments that +Guile passes to the handler. (In other words, they assume the handler +signature @code{(lambda (key . args) @dots{})}.) With Guile 1.8 or +later, you can also do this with a @code{catch}, by adding this same +code to the catch's optional pre-unwind handler. + +If you don't already have any of these, insert a whole +@code{with-throw-handler} expression around the code of interest like +this: + +@lisp +(with-throw-handler #t + (lambda () + ;; Protected code here. + ) + (lambda (key . args) + (gds-debug-trap (throw->trap-context key args)))) +@end lisp + +In all cases you will need to use the @code{(ice-9 gds-client)} and +@code{(ice-9 debugging traps)} modules. + +Two special cases of this are the lazy-catch that the Guile REPL code +uses to catch exceptions in user code, and the lazy-catch inside the +@code{stack-catch} utility procedure that is provided by the +@code{(ice-9 stack-catch)} module. Both of these use a handler called +@code{lazy-handler-dispatch}, which you can modify automatically so that +it calls GDS to display the stack when an exception occurs. To do this, +use the @code{on-lazy-handler-dispatch} procedure as follows. + @lisp (use-modules (ice-9 gds-client) (ice-9 debugging traps)) @@ -691,18 +743,10 @@ described above. (on-lazy-handler-dispatch gds-debug-trap) @end lisp -This means that the program will use GDS to display the stack whenever -it hits an exception that is protected by a @code{lazy-catch} using -Guile's standard @code{lazy-catch-handler} (defined in -@file{boot-9.scm}). - -@code{lazy-catch-handler} is used by the @code{stack-catch} procedure, -provided by the @code{(ice-9 stack-catch)} module, so this will include -exceptions within a @code{stack-catch}. @code{lazy-catch-handler} is -also used by the standard Guile REPL, when you run Guile interactively, -so you can add the above lines to your @file{.guile} file if you want to -use GDS whenever something that you type into the REPL throws an -exception. +@noindent +After this the program will use GDS to display the stack whenever it +hits an exception that is protected by a @code{lazy-catch} using +@code{lazy-catch-handler} (defined in @file{boot-9.scm}). @subsubsection Accepting GDS Instructions at Any Time @@ -744,14 +788,11 @@ This approach is not yet implemented, though. @subsubsection Utility Guile Implementation -We bring this subsection full circle by noting that the ``utility'' Guile -client, which GDS starts automatically when you use GDS as described -under approach 1 above, is really just a special case of ``a Guile -program or script which is started independently'' (approach 2), and -provides the services that the GDS front end needs by a simple -combination of some of the code fragments just described. +We conclude this subsection with an aside, by noting that the +``utility'' Guile client described above is nothing more than a +combination of the previous options. -To be precise, the code for the utility Guile client is essentially +To be precise, the code for the utility Guile client is essentially just this: @lisp @@ -764,12 +805,11 @@ this: @code{set-gds-breakpoints} works as already described. The @code{named-module-use!} line ensures that the client can process -@code{help} and @code{apropos} expressions, which is what the front end -sends to implement lookups in Guile's online help. The @code{#f} -parameter to @code{gds-accept-input} means that the @code{continue} -instruction will not cause the instruction loop to exit, which makes -sense here because the utility client has nothing to do except to -process GDS instructions. +@code{help} and @code{apropos} expressions, to implement lookups in +Guile's online help. The @code{#f} parameter to @code{gds-accept-input} +means that the @code{continue} instruction will not cause the +instruction loop to exit, which makes sense here because the utility +client has nothing to do except to process GDS instructions. (The utility client does not use @code{on-lazy-handler-dispatch}, because it has its own mechanism for catching and reporting exceptions From 83a5b41b47dde7dd97077f06607fe0967af9be56 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 3 Oct 2006 19:21:48 +0000 Subject: [PATCH 044/116] (run-utility): Remove unnecessary `connect-to-gds' call. --- ice-9/ChangeLog | 5 +++++ ice-9/gds-client.scm | 1 - 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2385a45f8..237604515 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2006-10-03 Neil Jerram + + * gds-client.scm (run-utility): Remove unnecessary + `connect-to-gds' call. + 2006-09-30 Neil Jerram * debugging/ice-9-debugger-extensions.scm (debug-trap): Use diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index e101c4e4d..26e76855e 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -562,7 +562,6 @@ Thanks!\n\n" (apply throw key args)) (define (run-utility) - (connect-to-gds) (set-gds-breakpoints) (write (getpid)) (newline) From 3bff1789df617ddcb9513e365c9fa9069841fc31 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 5 Oct 2006 23:28:44 +0000 Subject: [PATCH 045/116] (new-input-prompt): Renamed from "prompt". (continuation-prompt): Renamed from "prompt2". (make-readline-port, readline, set-readline-prompt!): Reflect above renamings. (activate-readline): Rename locals "read-hook" and "prompt" to "repl-read-hook" and "repl-prompt", to disambiguate them from globals. Save and restore the new-input- and continuation- prompts around the REPL read call. --- guile-readline/ChangeLog | 11 +++++++++ guile-readline/ice-9/readline.scm | 39 +++++++++++++++++-------------- 2 files changed, 32 insertions(+), 18 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 383541575..2a102e9e9 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,14 @@ +2006-10-06 Neil Jerram + + * ice-9/readline.scm (new-input-prompt): Renamed from "prompt". + (continuation-prompt): Renamed from "prompt2". + (make-readline-port, readline, set-readline-prompt!): Reflect + above renamings. + (activate-readline): Rename locals "read-hook" and "prompt" to + "repl-read-hook" and "repl-prompt", to disambiguate them from + globals. Save and restore the new-input- and continuation- + prompts around the REPL read call. + 2006-04-17 Kevin Ryde * ice-9/readline.scm: Bump lib file version to libguilereadline-v-18, diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 59224524b..067bd3842 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -68,8 +68,8 @@ ;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed, ;;; guile will enter an endless loop or crash. -(define prompt "") -(define prompt2 "") +(define new-input-prompt "") +(define continuation-prompt "") (define input-port (current-input-port)) (define output-port (current-output-port)) (define read-hook #f) @@ -77,8 +77,8 @@ (define (make-readline-port) (make-line-buffered-input-port (lambda (continuation?) (let* ((prompt (if continuation? - prompt2 - prompt)) + continuation-prompt + new-input-prompt)) (str (%readline (if (string? prompt) prompt (prompt)) @@ -125,7 +125,7 @@ ;;; %readline is the low-level readline procedure. (define-public (readline . args) - (let ((prompt prompt) + (let ((prompt new-input-prompt) (inp input-port)) (cond ((not (null? args)) (set! prompt (car args)) @@ -141,9 +141,9 @@ args))) (define-public (set-readline-prompt! p . rest) - (set! prompt p) + (set! new-input-prompt p) (if (not (null? rest)) - (set! prompt2 (car rest)))) + (set! continuation-prompt (car rest)))) (define-public (set-readline-input-port! p) (cond ((or (not (file-port? p)) (not (input-port? p))) @@ -202,19 +202,22 @@ (not (let ((guile-user-module (resolve-module '(guile-user)))) (and (module-defined? guile-user-module 'use-emacs-interface) (module-ref guile-user-module 'use-emacs-interface))))) - (let ((read-hook (lambda () (run-hook before-read-hook)))) + (let ((repl-read-hook (lambda () (run-hook before-read-hook)))) (set-current-input-port (readline-port)) (set! repl-reader - (lambda (prompt) - (dynamic-wind - (lambda () - (set-buffered-input-continuation?! (readline-port) #f) - (set-readline-prompt! prompt "... ") - (set-readline-read-hook! read-hook)) - (lambda () (read)) - (lambda () - (set-readline-prompt! "" "") - (set-readline-read-hook! #f))))) + (lambda (repl-prompt) + (let ((outer-new-input-prompt new-input-prompt) + (outer-continuation-prompt continuation-prompt) + (outer-read-hook read-hook)) + (dynamic-wind + (lambda () + (set-buffered-input-continuation?! (readline-port) #f) + (set-readline-prompt! repl-prompt "... ") + (set-readline-read-hook! repl-read-hook)) + (lambda () (read)) + (lambda () + (set-readline-prompt! outer-new-input-prompt outer-continuation-prompt) + (set-readline-read-hook! outer-read-hook)))))) (set! (using-readline?) #t)))) (define-public (make-completion-function strings) From 7e5a256c842997b6dd13555219b4c11c308c8512 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 5 Oct 2006 23:55:22 +0000 Subject: [PATCH 046/116] (Using Guile in Emacs): Subnodes reordered, from (Displaying the Scheme Stack, Continuing Execution, Evaluating Scheme Code, Setting and Managing Breakpoints, Access to Guile Help and Completion) to (Access to Guile Help and Completion, Setting and Managing Breakpoints, Evaluating Scheme Code, Displaying the Scheme Stack, Continuing Execution). --- doc/ref/ChangeLog | 9 ++ doc/ref/scheme-using.texi | 228 +++++++++++++++++++------------------- 2 files changed, 123 insertions(+), 114 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index f95ec8915..c17be5def 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,12 @@ +2006-10-06 Neil Jerram + + * scheme-using.texi (Using Guile in Emacs): Subnodes reordered, + from (Displaying the Scheme Stack, Continuing Execution, + Evaluating Scheme Code, Setting and Managing Breakpoints, Access + to Guile Help and Completion) to (Access to Guile Help and + Completion, Setting and Managing Breakpoints, Evaluating Scheme + Code, Displaying the Scheme Stack, Continuing Execution). + 2006-10-03 Neil Jerram * scheme-using.texi (GDS Getting Started): Editorial updates. diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index ac7f71005..6eca40126 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -449,11 +449,11 @@ section. * GDS Introduction:: * GDS Architecture:: * GDS Getting Started:: +* Access to Guile Help and Completion:: +* Setting and Managing Breakpoints:: +* Evaluating Scheme Code:: * Displaying the Scheme Stack:: * Continuing Execution:: -* Evaluating Scheme Code:: -* Setting and Managing Breakpoints:: -* Access to Guile Help and Completion:: * Associating Buffers with Clients:: * An Example GDS Session:: @end menu @@ -819,6 +819,117 @@ stack, so the end result is very similar to what @code{on-lazy-handler-dispatch} provides.) +@node Access to Guile Help and Completion +@subsection Access to Guile Help and Completion + +The following keystrokes provide fast and convenient access to Guile's +built in help, and to completion with respect to the set of defined and +accessible symbols. + +@table @kbd +@item C-h g +@findex gds-help-symbol +Get Guile help for a particular symbol, with the same results as if +you had typed @code{(help SYMBOL)} into the Guile REPL +(@code{gds-help-symbol}). The symbol to query defaults to the word at +or before the cursor but can also be entered or edited in the +minibuffer. The available help is popped up in a temporary Emacs +window. + +@item C-h C-g +@findex gds-apropos +List all accessible Guile symbols matching a given regular expression, +with the same results as if you had typed @code{(apropos REGEXP)} into +the Guile REPL (@code{gds-apropos}). The regexp to query defaults to +the word at or before the cursor but can also be entered or edited in +the minibuffer. The list of matching symbols is popped up in a +temporary Emacs window. + +@item M-@key{TAB} +@findex gds-complete-symbol +Try to complete the symbol at the cursor by matching it against the +set of all defined and accessible bindings in the associated Guile +process (@code{gds-complete-symbol}). If there are any extra +characters that can be definitively added to the symbol at point, they +are inserted. Otherwise, if there are any completions available, they +are popped up in a temporary Emacs window, where one of them can be +selected using either @kbd{@key{RET}} or the mouse. +@end table + + +@node Setting and Managing Breakpoints +@subsection Setting and Managing Breakpoints + +You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a +Scheme mode buffer. To create a breakpoint on calls to a procedure +--- i.e. the equivalent of calling @code{break-in} --- place the +cursor on the procedure's name and type @kbd{C-x @key{SPC}}. To +create breakpoints on a particular expression, or on the series of +expressions in a particular region --- i.e. as with @code{break-at} +--- select the expression or region in the usual way and type @kbd{C-x +@key{SPC}}. In general, GDS assumes that you want a @code{break-at} +breakpoint if there is an active region, and a @code{break-in} +breakpoint otherwise. + +When you create a breakpoint like this, two things happen. Firstly, +if the current buffer is associated with a Guile client program, the +new breakpoint definition is immediately sent to that client (or, if +the client cannot accept input immediately, it is held in readiness to +pass to the client at the next possible opportunity). This allows the +new breakpoint to take effect as soon as possible in the relevant +client program. + +Secondly, it is added to GDS's @emph{global} list of all breakpoints. +This list holds the breakpoint information that will be given to any +client program that asks for it by calling @code{set-gds-breakpoints}. +The fact that this list is global, rather than client-specific, means +that the breakpoints you have set will automatically be recreated if +the program you are debugging has to be stopped and restarted --- +which in my experience happens often.@footnote{An important point here +is that there is nothing that unambiguously relates two subsequent +runs of the same client program, which might allow GDS to pass on +breakpoint settings more precisely.} + +(The only possible downside of this last point is that if you are +debugging two programs in parallel, which have some code in common, +you might not want a common code breakpoint in one program to be set +in the other program as well. But this feels like a small concern in +comparison to the benefit of breakpoints persisting as just described.) + + +@node Evaluating Scheme Code +@subsection Evaluating Scheme Code + +The following keystrokes and commands provide various ways of sending +code to a Guile client process for evaluation. + +@table @kbd +@item M-C-x +@findex gds-eval-defun +Evaluate the ``top level defun'' that the cursor is in, in other words +the smallest balanced expression which includes the cursor and whose +opening parenthesis is in column 0 (@code{gds-eval-defun}). + +@item C-x C-e +@findex gds-eval-last-sexp +Evaluate the expression that ends just before the cursor +(@code{gds-eval-last-sexp}). This is designed so that it is easy to +evaluate an expression that you have just finished typing. + +@item C-c C-e +@findex gds-eval-expression +Read a Scheme expression using the minibuffer, and evaluate that +expression (@code{gds-eval-expression}). + +@item C-c C-r +@findex gds-eval-region +Evaluate the Scheme code in the marked region of the current buffer +(@code{gds-eval-region}). Note that GDS does not check whether the +region contains a balanced expression, or try to expand the region so +that it does; it uses the region exactly as it is. +@end table + + @node Displaying the Scheme Stack @subsection Displaying the Scheme Stack @@ -941,117 +1052,6 @@ remains in place and so will still fire at the appropriate point. @end table -@node Evaluating Scheme Code -@subsection Evaluating Scheme Code - -The following keystrokes and commands provide various ways of sending -code to a Guile client process for evaluation. - -@table @kbd -@item M-C-x -@findex gds-eval-defun -Evaluate the ``top level defun'' that the cursor is in, in other words -the smallest balanced expression which includes the cursor and whose -opening parenthesis is in column 0 (@code{gds-eval-defun}). - -@item C-x C-e -@findex gds-eval-last-sexp -Evaluate the expression that ends just before the cursor -(@code{gds-eval-last-sexp}). This is designed so that it is easy to -evaluate an expression that you have just finished typing. - -@item C-c C-e -@findex gds-eval-expression -Read a Scheme expression using the minibuffer, and evaluate that -expression (@code{gds-eval-expression}). - -@item C-c C-r -@findex gds-eval-region -Evaluate the Scheme code in the marked region of the current buffer -(@code{gds-eval-region}). Note that GDS does not check whether the -region contains a balanced expression, or try to expand the region so -that it does; it uses the region exactly as it is. -@end table - - -@node Setting and Managing Breakpoints -@subsection Setting and Managing Breakpoints - -You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a -Scheme mode buffer. To create a breakpoint on calls to a procedure ---- i.e. the equivalent of calling @code{break-in} --- place the -cursor on the procedure's name and type @kbd{C-x @key{SPC}}. To -create breakpoints on a particular expression, or on the series of -expressions in a particular region --- i.e. as with @code{break-at} ---- select the expression or region in the usual way and type @kbd{C-x -@key{SPC}}. In general, GDS assumes that you want a @code{break-at} -breakpoint if there is an active region, and a @code{break-in} -breakpoint otherwise. - -When you create a breakpoint like this, two things happen. Firstly, -if the current buffer is associated with a Guile client program, the -new breakpoint definition is immediately sent to that client (or, if -the client cannot accept input immediately, it is held in readiness to -pass to the client at the next possible opportunity). This allows the -new breakpoint to take effect as soon as possible in the relevant -client program. - -Secondly, it is added to GDS's @emph{global} list of all breakpoints. -This list holds the breakpoint information that will be given to any -client program that asks for it by calling @code{set-gds-breakpoints}. -The fact that this list is global, rather than client-specific, means -that the breakpoints you have set will automatically be recreated if -the program you are debugging has to be stopped and restarted --- -which in my experience happens often.@footnote{An important point here -is that there is nothing that unambiguously relates two subsequent -runs of the same client program, which might allow GDS to pass on -breakpoint settings more precisely.} - -(The only possible downside of this last point is that if you are -debugging two programs in parallel, which have some code in common, -you might not want a common code breakpoint in one program to be set -in the other program as well. But this feels like a small concern in -comparison to the benefit of breakpoints persisting as just described.) - - -@node Access to Guile Help and Completion -@subsection Access to Guile Help and Completion - -The following keystrokes provide fast and convenient access to Guile's -built in help, and to completion with respect to the set of defined and -accessible symbols. - -@table @kbd -@item C-h g -@findex gds-help-symbol -Get Guile help for a particular symbol, with the same results as if -you had typed @code{(help SYMBOL)} into the Guile REPL -(@code{gds-help-symbol}). The symbol to query defaults to the word at -or before the cursor but can also be entered or edited in the -minibuffer. The available help is popped up in a temporary Emacs -window. - -@item C-h C-g -@findex gds-apropos -List all accessible Guile symbols matching a given regular expression, -with the same results as if you had typed @code{(apropos REGEXP)} into -the Guile REPL (@code{gds-apropos}). The regexp to query defaults to -the word at or before the cursor but can also be entered or edited in -the minibuffer. The list of matching symbols is popped up in a -temporary Emacs window. - -@item M-@key{TAB} -@findex gds-complete-symbol -Try to complete the symbol at the cursor by matching it against the -set of all defined and accessible bindings in the associated Guile -process (@code{gds-complete-symbol}). If there are any extra -characters that can be definitively added to the symbol at point, they -are inserted. Otherwise, if there are any completions available, they -are popped up in a temporary Emacs window, where one of them can be -selected using either @kbd{@key{RET}} or the mouse. -@end table - - @node Associating Buffers with Clients @subsection Associating Buffers with Clients From 72ea645a88b56da0b5c585e10c22a2598da1cef1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 6 Oct 2006 00:10:36 +0000 Subject: [PATCH 047/116] (Access to Guile Help and Completion): Mention where keys are defined. (Setting and Managing Breakpoints): Update text on how to set breakpoints. --- doc/ref/ChangeLog | 4 ++++ doc/ref/scheme-using.texi | 50 ++++++++++++++++++++++++++------------- 2 files changed, 38 insertions(+), 16 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index c17be5def..89432d6bc 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -6,6 +6,10 @@ to Guile Help and Completion) to (Access to Guile Help and Completion, Setting and Managing Breakpoints, Evaluating Scheme Code, Displaying the Scheme Stack, Continuing Execution). + (Access to Guile Help and Completion): Mention where keys are + defined. + (Setting and Managing Breakpoints): Update text on how to set + breakpoints. 2006-10-03 Neil Jerram diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 6eca40126..496c90165 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -824,7 +824,7 @@ stack, so the end result is very similar to what The following keystrokes provide fast and convenient access to Guile's built in help, and to completion with respect to the set of defined and -accessible symbols. +accessible symbols. They are defined in all @code{scheme-mode} buffers. @table @kbd @item C-h g @@ -861,15 +861,34 @@ selected using either @kbd{@key{RET}} or the mouse. @subsection Setting and Managing Breakpoints You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a -Scheme mode buffer. To create a breakpoint on calls to a procedure ---- i.e. the equivalent of calling @code{break-in} --- place the -cursor on the procedure's name and type @kbd{C-x @key{SPC}}. To -create breakpoints on a particular expression, or on the series of -expressions in a particular region --- i.e. as with @code{break-at} ---- select the expression or region in the usual way and type @kbd{C-x -@key{SPC}}. In general, GDS assumes that you want a @code{break-at} -breakpoint if there is an active region, and a @code{break-in} -breakpoint otherwise. +Scheme mode buffer. To create a breakpoint on calls to a procedure --- +i.e. the equivalent of calling @code{break-in} --- place the cursor +anywhere within the procedure's definition, make sure that the region is +unset, and type @kbd{C-x @key{SPC}}. To create breakpoints on a +particular expression, or on the series of expressions in a particular +region --- i.e. as with @code{break-at} --- select a region containing +the open parentheses of the expressions where you want breakpoints, and +type @kbd{C-x @key{SPC}}. In other words, GDS assumes that you want a +@code{break-at} breakpoint if there is an active region, and a +@code{break-in} breakpoint otherwise. + +There are three supported breakpoint behaviours, known as @code{debug}, +@code{trace} and @code{trace-subtree}. @code{debug} means that GDS will +display the stack and wait for instruction when the breakpoint is hit. +@code{trace} means that a line will be written to the trace output +buffer (@code{*GDS Trace*}) when the breakpoint is hit, and when the +relevant expression or procedure call returns. @code{trace-subtree} +means that a line is written to the trace output buffer for every +evaluation step between when the breakpoint is hit and when the +expression or procedure returns. + +@kbd{C-x @key{SPC}} creates a breakpoint with behaviour according to the +@code{gds-default-breakpoint-type} variable, which by default is +@code{debug}; you can customize this if you prefer a different default. +You can also create a breakpoint with behaviour other than the current +default by using the alternative key sequences @kbd{C-c C-b d} (for +@code{debug}), @kbd{C-c C-b t} (@code{trace}) and @kbd{C-c C-b T} +(@code{trace-subtree}). When you create a breakpoint like this, two things happen. Firstly, if the current buffer is associated with a Guile client program, the @@ -883,12 +902,11 @@ Secondly, it is added to GDS's @emph{global} list of all breakpoints. This list holds the breakpoint information that will be given to any client program that asks for it by calling @code{set-gds-breakpoints}. The fact that this list is global, rather than client-specific, means -that the breakpoints you have set will automatically be recreated if -the program you are debugging has to be stopped and restarted --- -which in my experience happens often.@footnote{An important point here -is that there is nothing that unambiguously relates two subsequent -runs of the same client program, which might allow GDS to pass on -breakpoint settings more precisely.} +that the breakpoints you have set will automatically be recreated if the +program you are debugging has to be stopped and restarted.@footnote{An +important point here is that there is nothing that unambiguously relates +two subsequent runs of the same client program, which might allow GDS to +pass on breakpoint settings more precisely.} (The only possible downside of this last point is that if you are debugging two programs in parallel, which have some code in common, From 72bcfa04ecbe168d1bdaf8f4fdc5920724cbe657 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 8 Oct 2006 08:19:13 +0000 Subject: [PATCH 048/116] (Working with GDS in Scheme Buffers): New subsection, to group (Access to Guile Help and Completion, Setting and Managing Breakpoints, Evaluating Scheme Code) together. --- doc/ref/ChangeLog | 6 ++++++ doc/ref/scheme-using.texi | 29 ++++++++++++++++++++--------- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 89432d6bc..46aa66e84 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2006-10-08 Neil Jerram + + * scheme-using.texi (Working with GDS in Scheme Buffers): New + subsection, to group (Access to Guile Help and Completion, Setting + and Managing Breakpoints, Evaluating Scheme Code) together. + 2006-10-06 Neil Jerram * scheme-using.texi (Using Guile in Emacs): Subnodes reordered, diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 496c90165..c0ebeb1ac 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -449,9 +449,7 @@ section. * GDS Introduction:: * GDS Architecture:: * GDS Getting Started:: -* Access to Guile Help and Completion:: -* Setting and Managing Breakpoints:: -* Evaluating Scheme Code:: +* Working with GDS in Scheme Buffers:: * Displaying the Scheme Stack:: * Continuing Execution:: * Associating Buffers with Clients:: @@ -819,12 +817,25 @@ stack, so the end result is very similar to what @code{on-lazy-handler-dispatch} provides.) +@node Working with GDS in Scheme Buffers +@subsection Working with GDS in Scheme Buffers + +The following subsections describe the facilities and key sequences that +GDS provides for working on code in @code{scheme-mode} buffers. + +@menu +* Access to Guile Help and Completion:: +* Setting and Managing Breakpoints:: +* Evaluating Scheme Code:: +@end menu + + @node Access to Guile Help and Completion -@subsection Access to Guile Help and Completion +@subsubsection Access to Guile Help and Completion The following keystrokes provide fast and convenient access to Guile's built in help, and to completion with respect to the set of defined and -accessible symbols. They are defined in all @code{scheme-mode} buffers. +accessible symbols. @table @kbd @item C-h g @@ -858,7 +869,7 @@ selected using either @kbd{@key{RET}} or the mouse. @node Setting and Managing Breakpoints -@subsection Setting and Managing Breakpoints +@subsubsection Setting and Managing Breakpoints You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a Scheme mode buffer. To create a breakpoint on calls to a procedure --- @@ -887,8 +898,8 @@ expression or procedure returns. @code{debug}; you can customize this if you prefer a different default. You can also create a breakpoint with behaviour other than the current default by using the alternative key sequences @kbd{C-c C-b d} (for -@code{debug}), @kbd{C-c C-b t} (@code{trace}) and @kbd{C-c C-b T} -(@code{trace-subtree}). +@code{debug}), @kbd{C-c C-b t} (for @code{trace}) and @kbd{C-c C-b T} +(for @code{trace-subtree}). When you create a breakpoint like this, two things happen. Firstly, if the current buffer is associated with a Guile client program, the @@ -916,7 +927,7 @@ comparison to the benefit of breakpoints persisting as just described.) @node Evaluating Scheme Code -@subsection Evaluating Scheme Code +@subsubsection Evaluating Scheme Code The following keystrokes and commands provide various ways of sending code to a Guile client process for evaluation. From aeb9d8e054a250c1f56d90f281590e8f8688c35f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 8 Oct 2006 08:24:00 +0000 Subject: [PATCH 049/116] (GDS Getting Started): Editorial updates. --- doc/ref/ChangeLog | 1 + doc/ref/scheme-using.texi | 15 ++++++++------- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 46aa66e84..7a1883095 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -3,6 +3,7 @@ * scheme-using.texi (Working with GDS in Scheme Buffers): New subsection, to group (Access to Guile Help and Completion, Setting and Managing Breakpoints, Evaluating Scheme Code) together. + (GDS Getting Started): Editorial updates. 2006-10-06 Neil Jerram diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index c0ebeb1ac..445c8f32d 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -708,11 +708,11 @@ where @code{key} and @code{args} are the first and rest arguments that Guile passes to the handler. (In other words, they assume the handler signature @code{(lambda (key . args) @dots{})}.) With Guile 1.8 or later, you can also do this with a @code{catch}, by adding this same -code to the catch's optional pre-unwind handler. +code to the catch's pre-unwind handler. If you don't already have any of these, insert a whole -@code{with-throw-handler} expression around the code of interest like -this: +@code{with-throw-handler} expression (or @code{lazy-catch} if your Guile +is pre-1.8) around the code of interest like this: @lisp (with-throw-handler #t @@ -730,9 +730,10 @@ Two special cases of this are the lazy-catch that the Guile REPL code uses to catch exceptions in user code, and the lazy-catch inside the @code{stack-catch} utility procedure that is provided by the @code{(ice-9 stack-catch)} module. Both of these use a handler called -@code{lazy-handler-dispatch}, which you can modify automatically so that -it calls GDS to display the stack when an exception occurs. To do this, -use the @code{on-lazy-handler-dispatch} procedure as follows. +@code{lazy-handler-dispatch} (defined in @file{boot-9.scm}), which you +can hook into such that it calls GDS to display the stack when an +exception occurs. To do this, use the @code{on-lazy-handler-dispatch} +procedure as follows. @lisp (use-modules (ice-9 gds-client) @@ -744,7 +745,7 @@ use the @code{on-lazy-handler-dispatch} procedure as follows. @noindent After this the program will use GDS to display the stack whenever it hits an exception that is protected by a @code{lazy-catch} using -@code{lazy-catch-handler} (defined in @file{boot-9.scm}). +@code{lazy-handler-dispatch}. @subsubsection Accepting GDS Instructions at Any Time From 40296bab814a677dd0e9a09bdf93be2e9ccd3fd0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Oct 2006 22:47:06 +0000 Subject: [PATCH 050/116] merge from 1.8 branch --- doc/goops/ChangeLog | 2 +- doc/ref/ChangeLog | 60 +++++++++++++++ doc/ref/api-control.texi | 35 ++++----- doc/ref/api-data.texi | 13 +++- doc/ref/api-evaluation.texi | 12 ++- doc/ref/api-i18n.texi | 3 +- doc/ref/api-io.texi | 24 ++++-- doc/ref/guile.texi | 3 +- doc/ref/misc-modules.texi | 146 ++++++++++++++++++++++++++---------- doc/ref/posix.texi | 56 ++++++++------ doc/ref/repl-modules.texi | 139 +++++++++++++++++++++++++++++++++- 11 files changed, 398 insertions(+), 95 deletions(-) diff --git a/doc/goops/ChangeLog b/doc/goops/ChangeLog index 22a5c82c2..b0e742b71 100644 --- a/doc/goops/ChangeLog +++ b/doc/goops/ChangeLog @@ -1,4 +1,4 @@ -2006-09-27 Neil Jerram +2006-09-28 Neil Jerram * goops.texi (Slot Options): Added example from Ludovic Courts about difference between init-value, -form and -thunk. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 7a1883095..91a776004 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -18,6 +18,19 @@ (Setting and Managing Breakpoints): Update text on how to set breakpoints. +2006-10-05 Kevin Ryde + + * misc-modules.texi (File Tree Walk): Corrections to BASE parameter + and symlink vs stale-symlink types in nftw. + * misc-modules.texi, guile.texi (Buffered Input): New section, + describing (ice-9 buffered-input). + + * posix.texi (User Information): Clarify getpwent returns #f at end of + file. + + * repl-modules.texi (Readline Functions): New section on how to call + readline from scheme code. + 2006-10-03 Neil Jerram * scheme-using.texi (GDS Getting Started): Editorial updates. @@ -39,6 +52,12 @@ (GDS Getting Started, How to Use GDS): Merged; editorial updates; subsections reordered. +2006-09-26 Kevin Ryde + + * api-io.texi (Random Access): In truncate-file, tweak wording for + clarity, note cannot always extend file this way. + (Ports): File access uses LFS. + 2006-09-25 Neil Jerram * scheme-using.texi (Error Handling, Interactive Debugger): Minor @@ -51,11 +70,31 @@ minor improvements. Removed doc for `trace-finish', which no longer exists. +2006-09-22 Kevin Ryde + + * api-data.texi (Scientific): In sqrt, note it's the positive root + which is returned (as per R5RS). + 2006-09-20 Ludovic Courts * api-data.texi (Standard Character Sets): Documented the charset recomputation upon successful `setlocale'. +2006-09-08 Kevin Ryde + + * misc-modules.texi (Formatted Output): Show ":@" rather than "@:", + because ":@" is traditional common lisp, though either way works. + Break a couple of example lines to avoid overflowing DVI page width. + + * scheme-debugging.texi (Debug Last Error): Line break in "Type + (backtrace) to get ..." which overflowed the line in both info and + DVI. Reported by Percy Tiglao. + +2006-09-05 Kevin Ryde + + * posix.texi (Network Sockets and Communication): Tweak description, + note not multi-threading. + 2006-09-04 Neil Jerram * api-control.texi (Dynamic Wind): Doc for scm_dynwind_free. @@ -69,6 +108,11 @@ * api-debug.texi (Debug on Error): Added paragraph on need to use debugging evaluator. Added text on what the Guile REPL code does. +2006-08-29 Kevin Ryde + + * api-control.texi (Dynamic Wind): Reformat example a bit to avoid + going off the right edge of the paper. Reported by Percy Tiglao. + 2006-08-28 Neil Jerram * api-debug.texi (Examining the Stack): Minor improvements to @@ -87,6 +131,11 @@ (GDS Introduction): New node, containing GDS-specific introductory text. +2006-08-22 Kevin Ryde + + * api-i18n.texi (Internationalization): Cross reference gettext manual + on plural forms. + 2006-08-18 Neil Jerram * scheme-using.texi (Using Guile in Emacs): Unignore extra GDS @@ -142,6 +191,17 @@ * Makefile.am (guile_TEXINFOS): Include new scheme-using.texi file. +2006-07-24 Kevin Ryde + + * api-evaluation.texi (Fly Evaluation): Add scm_c_eval_string. + (Loading): Add scm_c_primitive_load. + Reported by Jon Wilson. + +2006-06-25 Kevin Ryde + + * posix.texi (Time): In tm:gmtoff, give example values, note not the + same as C tm_gmtoff. + 2006-06-16 Ludovic Courts * api-utility.texi (Equality): Mentioned the behavior of `equal?' diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index dbb51cf6f..11a276a13 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1234,28 +1234,29 @@ non-locally, @var{out_guard} is called. If the dynamic extent of the dynamic-wind is re-entered, @var{in_guard} is called. Thus @var{in_guard} and @var{out_guard} may be called any number of times. + @lisp (define x 'normal-binding) @result{} x -(define a-cont (call-with-current-continuation - (lambda (escape) - (let ((old-x x)) - (dynamic-wind - ;; in-guard: - ;; - (lambda () (set! x 'special-binding)) +(define a-cont + (call-with-current-continuation + (lambda (escape) + (let ((old-x x)) + (dynamic-wind + ;; in-guard: + ;; + (lambda () (set! x 'special-binding)) - ;; thunk - ;; - (lambda () (display x) (newline) - (call-with-current-continuation escape) - (display x) (newline) - x) - - ;; out-guard: - ;; - (lambda () (set! x old-x))))))) + ;; thunk + ;; + (lambda () (display x) (newline) + (call-with-current-continuation escape) + (display x) (newline) + x) + ;; out-guard: + ;; + (lambda () (set! x old-x))))))) ;; Prints: special-binding ;; Evaluates to: diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4534f8a6e..ccd34e38f 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1214,7 +1214,16 @@ including complex numbers. @rnindex sqrt @c begin (texi-doc-string "guile" "sqrt") @deffn {Scheme Procedure} sqrt z -Return the square root of @var{z}. +Return the square root of @var{z}. Of the two possible roots +(positive and negative), the one with the a positive real part is +returned, or if that's zero then a positive imaginary part. Thus, + +@example +(sqrt 9.0) @result{} 3.0 +(sqrt -9.0) @result{} 0.0+3.0i +(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i +(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i +@end example @end deffn @rnindex expt diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 6f29f1d7c..1da13de43 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -357,6 +357,11 @@ While the code is evaluated, the given module is made the current one. The current module is restored when this procedure returns. @end deffn +@deftypefn {C Function} SCM scm_c_eval_string (const char *string) +@code{scm_eval_string}, but taking a C string instead of an +@code{SCM}. +@end deftypefn + @deffn {Scheme Procedure} apply proc arg1 @dots{} argN arglst @deffnx {C Function} scm_apply_0 (proc, arglst) @deffnx {C Function} scm_apply_1 (proc, arg1, arglst) @@ -446,6 +451,11 @@ that will be called before any code is loaded. See the documentation for @code{%load-hook} later in this section. @end deffn +@deftypefn {C Function} SCM scm_c_primitive_load (const char *filename) +@code{scm_primitive_load}, but taking a C string instead of an +@code{SCM}. +@end deftypefn + @deffn {Scheme Procedure} primitive-load-path filename @deffnx {C Function} scm_primitive_load_path (filename) Search @code{%load-path} for the file named @var{filename} and diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index 995e27e90..63884254a 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.texi @@ -85,7 +85,8 @@ example, It's important to use @code{ngettext} rather than plain @code{gettext} for plurals, since the rules for singular and plural forms in English are not the same in other languages. Only @code{ngettext} will allow -translators to give correct forms. +translators to give correct forms (@pxref{Plural forms,, Additional +functions for plural forms, gettext, GNU @code{gettext} utilities}). @end deffn @deffn {Scheme Procedure} textdomain [domain] diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 6eb95db3d..0d30c4d2a 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -64,6 +64,10 @@ rely on that to keep it away from system limits. An explicit call to If program flow makes it hard to be certain when to close then this may be an acceptable way to control resource usage. +All file access uses the ``LFS'' large file support functions when +available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be +read and written on a 32-bit system. + @rnindex input-port? @deffn {Scheme Procedure} input-port? x @deffnx {C Function} scm_input_port_p (x) @@ -390,14 +394,18 @@ Return an integer representing the current position of @findex truncate @findex ftruncate -@deffn {Scheme Procedure} truncate-file object [length] -@deffnx {C Function} scm_truncate_file (object, length) -Truncates the object referred to by @var{object} to at most -@var{length} bytes. @var{object} can be a string containing a -file name or an integer file descriptor or a port. -@var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port -position. The return value is unspecified. +@deffn {Scheme Procedure} truncate-file file [length] +@deffnx {C Function} scm_truncate_file (file, length) +Truncate @var{file} to @var{length} bytes. @var{file} can be a +filename string, a port object, or an integer file descriptor. The +return value is unspecified. + +For a port or file descriptor @var{length} can be omitted, in which +case the file is truncated at the current position (per @code{ftell} +above). + +On most systems a file can be extended by giving a length greater than +the current size, but this is not mandatory in the POSIX standard. @end deffn @node Line/Delimited diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 627c8cbb2..992ca28c4 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -137,7 +137,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.46 2006-08-01 21:51:12 ossau Exp $ +@c @subtitle $Id: guile.texi,v 1.47 2006-10-09 22:45:02 kryde Exp $ @c See preface.texi for the list of authors @author The Guile Developers @@ -347,6 +347,7 @@ available through both Scheme and C interfaces. * File Tree Walk:: Traversing the file system. * Queues:: First-in first-out queuing. * Streams:: Sequences of values. +* Buffered Input:: Ports made from a reader function. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: Using scsh interfaces in Guile. @end menu diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index f3a3c4093..db90c419a 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -270,13 +270,13 @@ With no parameters output is in words as a cardinal like ``ten'', or @end example And also with no parameters, @nicode{~@@r} gives roman numerals and -@nicode{~@@:r} gives old roman numerals. In old roman numerals +@nicode{~:@@r} gives old roman numerals. In old roman numerals there's no ``subtraction'', so 9 is @nicode{VIIII} instead of @nicode{IX}. In both cases only positive numbers can be output. @example (format #t "~@@r" 89) @print{} LXXXIX ;; roman -(format #t "~@@:r" 89) @print{} LXXXVIIII ;; old roman +(format #t "~:@@r" 89) @print{} LXXXVIIII ;; old roman @end example When a parameter is given it means numeric output in the specified @@ -507,7 +507,7 @@ puts the padding after the sign. @example (format #f "~,,8$" -1.5) @result{} " -1.50" (format #f "~,,8:$" -1.5) @result{} "- 1.50" -(format #f "~,,8,'.@@:$" 3) @result{} "+...3.00" +(format #f "~,,8,'.:@@$" 3) @result{} "+...3.00" @end example Note that floating point for dollar amounts is generally not a good @@ -567,7 +567,7 @@ one, which can be convenient when printing some sort of count. @example (format #t "~d cat~:p" 9) @print{} 9 cats -(format #t "~d pupp~@@:p" 5) @print{} 5 puppies +(format #t "~d pupp~:@@p" 5) @print{} 5 puppies @end example @nicode{~p} is designed for English plurals and there's no attempt to @@ -777,14 +777,14 @@ The modifiers on @nicode{~(} control the conversion. @c rest lower case. @c @item -@nicode{~@@:(} --- upper case. +@nicode{~:@@(} --- upper case. @end itemize For example, @example (format #t "~(Hello~)") @print{} hello -(format #t "~@@:(Hello~)") @print{} HELLO +(format #t "~:@@(Hello~)") @print{} HELLO @end example In the future it's intended the modifiers @nicode{:} and @nicode{@@} @@ -813,8 +813,10 @@ elements from it. This is a convenient way to output a whole list. @nicode{~:@{} takes a single argument which is a list of lists, each of those contained lists gives the arguments for the iterated format. +@c @print{} on a new line here to avoid overflowing page width in DVI @example -(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6))) @print{} 1x2 3x4 5x6 +(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6))) +@print{} 1x2 3x4 5x6 @end example @nicode{~@@@{} takes arguments directly, with each iteration @@ -825,11 +827,13 @@ successively consuming arguments. (format #t "~@@@{~s=~d ~@}" "x" 1 "y" 2) @print{} "x"=1 "y"=2 @end example -@nicode{~@@:@{} takes list arguments, one argument for each iteration, +@nicode{~:@@@{} takes list arguments, one argument for each iteration, using that list for the format. +@c @print{} on a new line here to avoid overflowing page width in DVI @example -(format #t "~@@:@{~dx~d ~@}" '(1 2) '(3 4) '(5 6)) @print{} 1x2 3x4 5x6 +(format #t "~:@@@{~dx~d ~@}" '(1 2) '(3 4) '(5 6)) +@print{} 1x2 3x4 5x6 @end example Iterating stops when there are no more arguments or when the @@ -1094,27 +1098,28 @@ Walk the filesystem tree starting at @var{startname}, calling @var{proc} for each file and directory. @code{nftw} has extra features over the basic @code{ftw} described above. -Hard links and symbolic links are followed, but a file or directory is -reported to @var{proc} only once, and skipped if seen again in another -place. One consequence of this is that @code{nftw} is safe against -circular linked directory structures. +Like @code{ftw}, hard links and symbolic links are followed. A file +or directory is reported to @var{proc} only once, and skipped if seen +again in another place. One consequence of this is that @code{nftw} +is safe against circular linked directory structures. Each @var{proc} call is @code{(@var{proc} filename statinfo flag -basename level)} and it should return @code{#t} to continue, or any +base level)} and it should return @code{#t} to continue, or any other value to stop. @var{filename} is the item visited, being @var{startname} plus a further path and the name of the item. @var{statinfo} is the return -from @code{stat} on @var{filename} (@pxref{File System}). -@var{basename} it the item name without any path. @var{level} is an -integer giving the directory nesting level, starting from 0 for the -contents of @var{startname} (or that item itself if it's a file). -@var{flag} is one of the following symbols, +from @code{stat} on @var{filename} (@pxref{File System}). @var{base} +is an integer offset into @var{filename} which is where the basename +for this item begins. @var{level} is an integer giving the directory +nesting level, starting from 0 for the contents of @var{startname} (or +that item itself if it's a file). @var{flag} is one of the following +symbols, @table @code @item regular -@var{filename} is a file, this includes special files like devices, -named pipes, etc. +@var{filename} is a file, including special files like devices, named +pipes, etc. @item directory @var{filename} is a directory. @@ -1132,19 +1137,15 @@ nothing is known about it. @var{statinfo} is @code{#f} in this case. @var{filename} is a directory, but one which cannot be read and hence won't be recursed into. -@item symlink -@var{filename} is a dangling symbolic link. Symbolic links are -normally followed and their target reported, the link itself is -reported if the target does not exist. - -Under the @code{physical} option described below, @code{symlink} is -instead given for symbolic links whose target does exist. - @item stale-symlink -Under the @code{physical} option described below, this indicates -@var{filename} is a dangling symbolic link, meaning its target does -not exist. Without the @code{physical} option plain @code{symlink} -indicates this. +@var{filename} is a dangling symbolic link. Links are normally +followed and their target reported, the link itself is reported if its +target does not exist. + +@item symlink +When the @code{physical} option described below is used, this +indicates @var{filename} is a symbolic link whose target exists (and +is not being followed). @end table The following optional arguments can be given to modify the way @@ -1156,10 +1157,11 @@ takes a following integer value). Change to the directory containing the item before calling @var{proc}. When @code{nftw} returns the original current directory is restored. -Under this option, generally the @var{basename} parameter should be -used to access the item in each @var{proc} call. The @var{filename} -parameter still has a path as normal and this will only be valid if -the @var{startname} directory was absolute. +Under this option, generally the @var{base} parameter to each +@var{proc} call should be used to pick out the base part of the +@var{filename}. The @var{filename} is still a path but with a changed +directory it won't be valid (unless the @var{startname} directory was +absolute). @item @code{depth} Visit files ``depth first'', meaning @var{proc} is called for the @@ -1175,11 +1177,12 @@ Set the size of the hash table used to track items already visited. @item @code{mount} Don't cross a mount point, meaning only visit items on the same -filesystem as @var{startname}. (Ie.@: the same @code{stat:dev}.) +filesystem as @var{startname} (ie.@: the same @code{stat:dev}). @item @code{physical} Don't follow symbolic links, instead report them to @var{proc} as -@code{symlink}, and report dangling links as @code{stale-symlink}. +@code{symlink}. Dangling links (those whose target doesn't exist) are +still reported as @code{stale-symlink}. @end table The return value from @code{nftw} is @code{#t} if it ran to @@ -1461,6 +1464,69 @@ ends when the end of the shortest given @var{stream} is reached. @end defun +@node Buffered Input +@section Buffered Input +@cindex Buffered input +@cindex Line continuation + +The following functions are provided by + +@example +(use-modules (ice-9 buffered-input)) +@end example + +A buffered input port allows a reader function to return chunks of +characters which are to be handed out on reading the port. A notion +of further input for an application level logical expression is +maintained too, and passed through to the reader. + +@defun make-buffered-input-port reader +Create an input port which returns characters obtained from the given +@var{reader} function. @var{reader} is called (@var{reader} cont), +and should return a string or an EOF object. + +The new port gives precisely the characters returned by @var{reader}, +nothing is added, so if any newline characters or other separators are +desired they must come from the reader function. + +The @var{cont} parameter to @var{reader} is @code{#f} for initial +input, or @code{#t} when continuing an expression. This is an +application level notion, set with +@code{set-buffered-input-continuation?!} below. If the user has +entered a partial expression then it allows @var{reader} for instance +to give a different prompt to show more is required. +@end defun + +@defun make-line-buffered-input-port reader +@cindex Line buffered input +Create an input port which returns characters obtained from the +specified @var{reader} function, similar to +@code{make-buffered-input-port} above, but where @var{reader} is +expected to be a line-oriented. + +@var{reader} is called (@var{reader} cont), and should return a string +or an EOF object as above. Each string is a line of input without a +newline character, the port code inserts a newline after each string. +@end defun + +@defun set-buffered-input-continuation?! port cont +Set the input continuation flag for a given buffered input +@var{port}. + +An application uses this by calling with a @var{cont} flag of +@code{#f} when beginning to read a new logical expression. For +example with the Scheme @code{read} function (@pxref{Scheme Read}), + +@example +(define my-port (make-buffered-input-port my-reader)) + +(set-buffered-input-continuation?! my-port #f) +(let ((obj (read my-port))) + ... +@end example +@end defun + + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 6a1d0f1b2..0711b9a1e 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1008,8 +1008,8 @@ return value is unspecified. @end deffn @deffn {Scheme Procedure} getpwent -Return the next entry in the user database, using the stream set by -@code{setpwent}. +Read the next entry in the user database stream. The return is a +passwd user object as above, or @code{#f} when no more entries. @end deffn @deffn {Scheme Procedure} endpwent @@ -1170,6 +1170,13 @@ Daylight saving indicator (0 for ``no'', greater than 0 for ``yes'', less than @deffn {Scheme Procedure} tm:gmtoff tm @deffnx {Scheme Procedure} set-tm:gmtoff tm val Time zone offset in seconds west of @acronym{UTC} (-46800 to 43200). +For example on East coast USA (zone @samp{EST+5}) this would be 18000 +(ie.@: @m{5\times60\times60,5*60*60}) in winter, or 14400 +(ie.@: @m{4\times60\times60,4*60*60}) during daylight savings. + +Note @code{tm:gmtoff} is not the same as @code{tm_gmtoff} in the C +@code{tm} structure. @code{tm_gmtoff} is seconds east and hence the +negative of the value here. @end deffn @deffn {Scheme Procedure} tm:zone tm @deffnx {Scheme Procedure} set-tm:zone tm val @@ -2909,32 +2916,37 @@ any unflushed buffered port data is ignored. @deffn {Scheme Procedure} recvfrom! sock str [flags [start [end]]] @deffnx {C Function} scm_recvfrom (sock, str, flags, start, end) -Return data from the socket port @var{sock} and also -information about where the data was received from. -@var{sock} must already be bound to the address from which -data is to be received. @code{str}, is a string into which the -data will be written. The size of @var{str} limits the amount -of data which can be received: in the case of packet protocols, -if a packet larger than this limit is encountered then some -data will be irrevocably lost. +Receive data from socket port @var{sock}, returning the originating +address as well as the data. This function is usually for datagram +sockets, but can be used on stream-oriented sockets too. + +The data received is stored in the given @var{str}, the whole string +or just the region between the optional @var{start} and @var{end} +positions. The size of @var{str} limits the amount of data which can +be received. For datagram protocols if a packet larger than this is +received then excess bytes are irrevocably lost. + +The return value is a pair. The @code{car} is the number of bytes +read. The @code{cdr} is a socket address object (@pxref{Network +Socket Address}) which is where the data came from, or @code{#f} if +the origin is unknown. @vindex MSG_OOB @vindex MSG_PEEK @vindex MSG_DONTROUTE -The optional @var{flags} argument is a value or bitwise OR of -@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. +The optional @var{flags} argument is a or bitwise-OR (@code{logior}) +of @code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. -The value returned is a pair: the @acronym{CAR} is the number of -bytes read from the socket and the @acronym{CDR} an address object -in the same form as returned by @code{accept}. The address -will given as @code{#f} if not available, as is usually the -case for stream sockets. +Data is read directly from the socket file descriptor, any buffered +port data is ignored. -The @var{start} and @var{end} arguments specify a substring of -@var{str} to which the data should be written. - -Note that the data is read directly from the socket file -descriptor: any unread buffered port data is ignored. +@c This was linux kernel 2.6.15 and glibc 2.3.6, not sure what any +@c specs are supposed to say about recvfrom threading. +@c +On a GNU/Linux system @code{recvfrom!} is not multi-threading, all +threads stop while a @code{recvfrom!} call is in progress. An +application may need to use @code{select}, @code{O_NONBLOCK} or +@code{MSG_DONTWAIT} to avoid this. @end deffn @deffn {Scheme Procedure} sendto sock message sockaddr [flags] diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi index 45f410c3a..5f274e253 100644 --- a/doc/ref/repl-modules.texi +++ b/doc/ref/repl-modules.texi @@ -23,6 +23,7 @@ history entries. @menu * Loading Readline Support:: How to load readline support into Guile. * Readline Options:: How to modify readline's behaviour. +* Readline Functions:: Programming with readline. @end menu @@ -32,7 +33,6 @@ history entries. The module is not loaded by default and so has to be loaded and activated explicitly. This is done with two simple lines of code: -@findex activate-readline @lisp (use-modules (ice-9 readline)) (activate-readline) @@ -91,7 +91,7 @@ $endif The readline interface module can be configured in several ways to better suit the user's needs. Configuration is done via the readline module's options interface, in a similar way to the evaluator and -debugging options (@pxref{User level options interfaces}.) +debugging options (@pxref{Runtime Options}). @findex readline-options @findex readline-enable @@ -119,6 +119,141 @@ usage of the history file using the following call. The readline options interface can only be used @emph{after} loading the readline module, because it is defined in that module. +@node Readline Functions +@subsection Readline Functions + +The following functions are provided by + +@example +(use-modules (ice-9 readline)) +@end example + +There are two ways to use readline from Scheme code, either make calls +to @code{readline} directly to get line by line input, or use the +readline port below with all the usual reading functions. + +@defun readline [prompt] +Read a line of input from the user and return it as a string (without +a newline at the end). @var{prompt} is the prompt to show, or the +default is the string set in @code{set-readline-prompt!} below. + +@example +(readline "Type something: ") @result{} "hello" +@end example +@end defun + +@defun set-readline-input-port! port +@defunx set-readline-output-port! port +Set the input and output port the readline function should read from +and write to. @var{port} must be a file port (@pxref{File Ports}), +and should usually be a terminal. + +The default is the @code{current-input-port} and +@code{current-output-port} (@pxref{Default Ports}) when @code{(ice-9 +readline)} loads, which in an interactive user session means the Unix +``standard input'' and ``standard output''. +@end defun + +@subsubsection Readline Port + +@defun readline-port +Return a buffered input port (@pxref{Buffered Input}) which calls the +@code{readline} function above to get input. This port can be used +with all the usual reading functions (@code{read}, @code{read-char}, +etc), and the user gets the interactive editing features of readline. + +There's only a single readline port created. @code{readline-port} +creates it when first called, and on subsequent calls just returns +what it previously made. +@end defun + +@defun activate-readline +If the @code{current-input-port} is a terminal (@pxref{Terminals and +Ptys,, @code{isatty?}}) then enable readline for all reading from +@code{current-input-port} (@pxref{Default Ports}) and enable readline +features in the interactive REPL (@pxref{The REPL}). + +@example +(activate-readline) +(read-char) +@end example + +@code{activate-readline} enables readline on @code{current-input-port} +simply by a @code{set-current-input-port} to the @code{readline-port} +above. An application can do that directly if the extra REPL features +that @code{activate-readline} adds are not wanted. +@end defun + +@defun set-readline-prompt! prompt1 [prompt2] +Set the prompt string to print when reading input. This is used when +reading through @code{readline-port}, and is also the default prompt +for the @code{readline} function above. + +@var{prompt1} is the initial prompt shown. If a user might enter an +expression across multiple lines, then @var{prompt2} is a different +prompt to show further input required. In the Guile REPL for instance +this is an ellipsis (@samp{...}). + +See @code{set-buffered-input-continuation?!} (@pxref{Buffered Input}) +for an application to indicate the boundaries of logical expressions +(assuming of course an application has such a notion). +@end defun + +@subsubsection Completion + +@defun with-readline-completion-function completer thunk +Call @code{(@var{thunk})} with @var{completer} as the readline tab +completion function to be used in any readline calls within that +@var{thunk}. @var{completer} can be @code{#f} for no completion. + +@var{completer} will be called as @code{(@var{completer} text state)}, +as described in (@pxref{How Completing Works,,, readline, GNU Readline +Library}). @var{text} is a partial word to be completed, and each +@var{completer} call should return a possible completion string or +@code{#f} when no more. @var{state} is @code{#f} for the first call +asking about a new @var{text} then @code{#t} while getting further +completions of that @var{text}. + +Here's an example @var{completer} for user login names from the +password file (@pxref{User Information}), much like readline's own +@code{rl_username_completion_function}, + +@example +(define (username-completer-function text state) + (if (not state) + (setpwent)) ;; new, go to start of database + (let more ((pw (getpwent))) + (if pw + (if (string-prefix? text (passwd:name pw)) + (passwd:name pw) ;; this name matches, return it + (more (getpwent))) ;; doesn't match, look at next + (begin + ;; end of database, close it and return #f + (endpwent) + #f)))) +@end example +@end defun + +@defun apropos-completion-function text state +A completion function offering completions for Guile functions and +variables (all @code{define}s). This is the default completion +function. +@c +@c FIXME: Cross reference the ``apropos'' stuff when it's documented. +@c +@end defun + +@defun filename-completion-function text state +A completion function offering filename completions. This is +readline's @code{rl_filename_completion_function} (@pxref{Completion +Functions,,, readline, GNU Readline Library}). +@end defun + +@defun make-completion-function string-list +Return a completion function which offers completions from the +possibilities in @var{string-list}. Matching is case-sensitive. +@end defun + @page @node Value History From afc4ccd4ddcf0f78932a5e0597731beb6efc8c7c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Oct 2006 22:59:10 +0000 Subject: [PATCH 051/116] merge from 1.8 branch --- doc/ref/scheme-debugging.texi | 7 ++++++- guile-readline/ChangeLog | 4 ++++ guile-readline/ice-9/readline.scm | 3 ++- ice-9/ChangeLog | 27 +++++++++++++++++++++++++ ice-9/boot-9.scm | 33 +++++++++++-------------------- ice-9/format.scm | 5 ++--- ice-9/ftw.scm | 31 +++++++++++++++++++++++------ 7 files changed, 77 insertions(+), 33 deletions(-) diff --git a/doc/ref/scheme-debugging.texi b/doc/ref/scheme-debugging.texi index a9d1691d1..32a6a46bd 100644 --- a/doc/ref/scheme-debugging.texi +++ b/doc/ref/scheme-debugging.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -511,3 +511,8 @@ behaviour as well as the more traditional @code{trace-here}. The older mechanism will probably become obsolete eventually, but it's worth keeping it around for a while until we are sure that the new mechanism is correct and does what programmers need. + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 2a102e9e9..b7bddd59f 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -9,6 +9,10 @@ globals. Save and restore the new-input- and continuation- prompts around the REPL read call. +2006-10-05 Kevin Ryde + + * ice-9/readline.scm (filename-completion-function): Export this. + 2006-04-17 Kevin Ryde * ice-9/readline.scm: Bump lib file version to libguilereadline-v-18, diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 067bd3842..e74bc0243 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -27,7 +27,8 @@ :use-module (ice-9 session) :use-module (ice-9 regex) :use-module (ice-9 buffered-input) - :no-backtrace) + :no-backtrace + :export (filename-completion-function)) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 237604515..1b903da23 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2006-10-05 Kevin Ryde + + * ftw.scm (visited?-proc): Use hashv since we know we're getting + numbers. Incorporate stat:dev, since stat:ino is only unique within a + single device. This fixes a bug where if two files with the same + inode on different devices where seen only the first would be returned + by ftw (and nftw). + 2006-10-03 Neil Jerram * gds-client.scm (run-utility): Remove unnecessary @@ -22,6 +30,18 @@ (info-args, info-frame, position, evaluate): Docstring improvements. +2006-09-23 Kevin Ryde + + * boot-9.scm (log, log10, exp, sqrt): Remove, now in + libguile/numbers.c. + +2006-09-07 Kevin Ryde + + * format.scm: Module "(ice-9 threads)" no longer used, now no mutex. + (format:parse-float): Fix normalization of leading zeros like "02.5" + to "2.5". left-zeros was zeroed before adjusting format:fn-dot, + resulting in the latter being unchanged. + 2006-08-18 Neil Jerram * debugging/trc.scm: New file. @@ -44,6 +64,13 @@ * Makefile.am (SUBDIRS): Add debugging. +2006-08-02 Kevin Ryde + + * boot-9.scm (%record-type-check): New function. + (record-accessor, record-modifier): Use it for a strict type check of + the given record. Previously an accessor returned #f on a wrong + record type, and modifier silently did nothing. + 2006-06-19 Neil Jerram * Makefile.am (ice9_sources): Add new files. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 0f56f9855..3ecd7b596 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -429,13 +429,20 @@ (define (record-predicate rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) +(define (%record-type-check rtd obj) ;; private helper + (or (eq? rtd (record-type-descriptor obj)) + (scm-error 'wrong-type-arg "%record-type-check" + "Wrong type record (want `~S'): ~S" + (list (record-type-name rtd) obj) + #f))) + (define (record-accessor rtd field-name) (let* ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) (local-eval `(lambda (obj) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-ref obj ,pos))) + (%record-type-check ',rtd obj) + (struct-ref obj ,pos)) the-root-environment))) (define (record-modifier rtd field-name) @@ -443,8 +450,8 @@ (if (not pos) (error 'no-such-field field-name)) (local-eval `(lambda (obj val) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-set! obj ,pos val))) + (%record-type-check ',rtd obj) + (struct-set! obj ,pos val)) the-root-environment))) @@ -779,21 +786,6 @@ ;;; See the file `COPYING' for terms applying to this program. ;;; -(define (exp z) - (if (real? z) ($exp z) - (make-polar ($exp (real-part z)) (imag-part z)))) - -(define (log z) - (if (and (real? z) (>= z 0)) - ($log z) - (make-rectangular ($log (magnitude z)) (angle z)))) - -(define (sqrt z) - (if (real? z) - (if (negative? z) (make-rectangular 0 ($sqrt (- z))) - ($sqrt z)) - (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) - (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) @@ -868,9 +860,6 @@ (/ (log (/ (- +i z) (+ +i z))) +2i)) ($atan2 z (car y)))) -(define (log10 arg) - (/ (log arg) (log 10))) - ;;; {Reader Extensions} diff --git a/ice-9/format.scm b/ice-9/format.scm index 3d17d44df..4bf623757 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -13,7 +13,6 @@ (define-module (ice-9 format) :use-module (ice-9 and-let-star) - :use-module (ice-9 threads) :autoload (ice-9 pretty-print) (pretty-print) :replace (format) :export (format:symbol-case-conv @@ -1461,8 +1460,8 @@ (if (> format:fn-dot left-zeros) (begin ; norm 0{0}nn.mm to nn.mm (format:fn-shiftleft left-zeros) - (set! left-zeros 0) - (set! format:fn-dot (- format:fn-dot left-zeros))) + (set! format:fn-dot (- format:fn-dot left-zeros)) + (set! left-zeros 0)) (begin ; normalize 0{0}.nnn to .nnn (format:fn-shiftleft format:fn-dot) (set! left-zeros (- left-zeros format:fn-dot)) diff --git a/ice-9/ftw.scm b/ice-9/ftw.scm index 09b580c05..23f341521 100644 --- a/ice-9/ftw.scm +++ b/ice-9/ftw.scm @@ -217,14 +217,33 @@ (define (abs? filename) (char=? #\/ (string-ref filename 0))) +;; `visited?-proc' returns a test procedure VISITED? which when called as +;; (VISITED? stat-obj) returns #f the first time a distinct file is seen, +;; then #t on any subsequent sighting of it. +;; +;; stat:dev and stat:ino together uniquely identify a file (see "Attribute +;; Meanings" in the glibc manual). Often there'll be just one dev, and +;; usually there's just a handful mounted, so the strategy here is a small +;; hash table indexed by dev, containing hash tables indexed by ino. +;; +;; It'd be possible to make a pair (dev . ino) and use that as the key to a +;; single hash table. It'd use an extra pair for every file visited, but +;; might be a little faster if it meant less scheme code. +;; (define (visited?-proc size) - (let ((visited (make-hash-table size))) + (let ((dev-hash (make-hash-table 7))) (lambda (s) - (and s (let ((ino (stat:ino s))) - (or (hash-ref visited ino) - (begin - (hash-set! visited ino #t) - #f))))))) + (and s + (let ((ino-hash (hashv-ref dev-hash (stat:dev s))) + (ino (stat:ino s))) + (or ino-hash + (begin + (set! ino-hash (make-hash-table size)) + (hashv-set! dev-hash (stat:dev s) ino-hash))) + (or (hashv-ref ino-hash ino) + (begin + (hashv-set! ino-hash ino #t) + #f))))))) (define (stat-dir-readable?-proc uid gid) (let ((uid (getuid)) From 121a80826c8279dafa5969df6ef66c1a248068d3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Oct 2006 23:27:59 +0000 Subject: [PATCH 052/116] merge from 1.8 branch (removing this file) --- test-suite/tests/slib.test | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 test-suite/tests/slib.test diff --git a/test-suite/tests/slib.test b/test-suite/tests/slib.test deleted file mode 100644 index e69de29bb..000000000 From 8ab3d8a0681777eb329ac533be51d557267ccf32 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Oct 2006 23:40:48 +0000 Subject: [PATCH 053/116] merge from 1.8 branch --- .cvsignore | 1 + ChangeLog | 44 ++++ Makefile.am | 2 +- NEWS | 73 ++++-- configure.in | 99 +++++++- libguile/ChangeLog | 107 +++++++++ libguile/Makefile.am | 2 +- libguile/_scm.h | 2 + libguile/environments.c | 7 +- libguile/eval.c | 43 ++-- libguile/filesys.c | 44 ++-- libguile/fports.c | 89 ++++++- libguile/fports.h | 3 + libguile/gen-scmconfig.c | 4 + libguile/gen-scmconfig.h.in | 1 + libguile/numbers.c | 165 ++++++++++++- libguile/numbers.h | 4 + libguile/ports.c | 74 ++++-- libguile/posix.c | 32 ++- libguile/pthread-threads.h | 6 +- libguile/socket.c | 58 +++-- libguile/stime.c | 18 +- libguile/threads.c | 10 +- test-suite/ChangeLog | 62 +++++ test-suite/Makefile.am | 1 + test-suite/standalone/test-conversion.c | 11 +- test-suite/standalone/test-gh.c | 11 +- test-suite/standalone/test-list.c | 11 +- test-suite/standalone/test-num2integral.c | 11 +- test-suite/standalone/test-require-extension | 12 +- test-suite/standalone/test-round.c | 9 +- test-suite/tests/eval.test | 28 ++- test-suite/tests/format.test | 20 +- test-suite/tests/ftw.test | 73 ++++++ test-suite/tests/numbers.test | 145 +++++++++++ test-suite/tests/popen.test | 16 +- test-suite/tests/ports.test | 74 +++++- test-suite/tests/socket.test | 40 ++++ test-suite/tests/srfi-1.test | 6 +- test-suite/tests/srfi-9.test | 60 ++++- test-suite/tests/time.test | 238 ++++++++++++++++--- 41 files changed, 1513 insertions(+), 203 deletions(-) create mode 100644 test-suite/tests/ftw.test diff --git a/.cvsignore b/.cvsignore index 14d3b2fa4..109038aaa 100644 --- a/.cvsignore +++ b/.cvsignore @@ -27,6 +27,7 @@ install-sh libtool ltconfig ltmain.sh +mdate-sh missing mkinstalldirs pre-inst-guile diff --git a/ChangeLog b/ChangeLog index 0df690615..0aef5db3f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,28 @@ +2006-10-06 Rob Browning + + Guile 1.8.1 released. + + * GUILE-VERSION (GUILE_MICRO_VERSION): Increment for release. + (LIBGUILE_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION): Increment for release. + + * Makefile.am (EXTRA_DIST): Add LICENSE. + +2006-09-28 Kevin Ryde + + * configure.in (chsize, ftruncate, truncate): New tests, for mingw. + +2006-09-27 Kevin Ryde + + * configure.in (clog10): New test, not in mingw. + +2006-09-23 Kevin Ryde + + * configure.in (complex.h, complex double, csqrt): New tests. + 2006-09-20 Ludovic Courts * configure.in: Check for `isblank ()'. @@ -5,6 +30,11 @@ * NEWS: Mentioned the interaction between `setlocale' and SRFI-14 standard char sets. +2006-08-22 Kevin Ryde + + * configure.in: Test if need braces around PTHREAD_ONCE_INIT, set + AC_OUTPUT of SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT. + 2006-08-18 Neil Jerram * configure.in: Generate Makefile for emacs subdir. @@ -13,6 +43,20 @@ * configure.in: Generate Makefile for ice-9/debugging subdir. +2006-07-25 Kevin Ryde + + * configure.in (AC_CHECK_FUNCS): Add pthread_getattr_np. + +2006-07-24 Kevin Ryde + + * configure.in (AC_CHECK_DECLS): Add sethostname for Solaris 10. + (AC_CHECK_FUNCS): Remove dirfd, it's a macro. + Reported by Claes Wallin. + +2006-06-25 Kevin Ryde + + * configure.in (AC_CHECK_MEMBERS): Test struct tm.tm_gmtoff. + 2006-06-13 Ludovic Courts * NEWS: Mentioned the new behavior of `equal?' for structures. diff --git a/Makefile.am b/Makefile.am index aba01bf7c..ab72bed9f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,7 +30,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. -EXTRA_DIST = HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS +EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS TESTS = check-guile diff --git a/NEWS b/NEWS index 0cfba4ac8..d5e136af6 100644 --- a/NEWS +++ b/NEWS @@ -22,34 +22,73 @@ Changes in 1.9.XXXXXXXX: Changes in 1.8.1 (since 1.8.0): -* Changes to the distribution +* LFS functions are now used to access 64-bit files on 32-bit systems. -** New primitive-_exit giving the _exit() system call. +* New procedures (see the manual for details) -* Changes to Scheme functions and syntax +** primitive-_exit - [Scheme] the-root-module +** scm_primitive__exit - [C] +** make-completion-function - [Scheme] (ice-9 readline) +** scm_c_locale_stringn_to_number - [C] +** scm_srfi1_append_reverse [C] +** scm_srfi1_append_reverse_x [C] +** scm_log - [C] +** scm_log10 - [C] +** scm_exp - [C] +** scm_sqrt - [C] + +* Bugs fixed + +** Build problems have been fixed on MacOS, SunOS, and QNX. ** A one-dimensional array can now be 'equal?' to a vector. + ** Structures, records, and SRFI-9 records can now be compared with `equal?'. -** SRFI-14 standard char sets are now recomputed upon successful `setlocale'. -* Changes to the C interface +** SRFI-14 standard char sets are recomputed upon a successful `setlocale'. -** New function scm_c_locale_stringn_to_number. +** `record-accessor' and `record-modifier' now have strict type checks. -* Bug fixes. +Record accessor and modifier procedures now throw an error if the +record type of the record they're given is not the type expected. +(Previously accessors returned #f and modifiers silently did nothing). -** array-set! with bit vector. -** make-shared-array fixes, including examples in the manual which failed. -** stringinexact overflows on fractions with big num/den but small result. -** srfi-1 assoc "=" procedure argument order. -** Build problems on MacOS, SunOS, QNX. +** It is now OK to use both autoload and use-modules on a given module. + +** `apply' checks the number of arguments more carefully on "0 or 1" funcs. + +Previously there was no checking on primatives like make-vector that +accept "one or two" arguments. Now there is. + +** The srfi-1 assoc function now calls its equality predicate properly. + +Previously srfi-1 assoc would call the equality predicate with the key +last. According to the SRFI, the key should be first. + +** A bug in n-par-for-each and n-for-each-par-map has been fixed. + +** The array-set! procedure no longer segfaults when given a bit vector. + +** Bugs in make-shared-array have been fixed. + +** stringinexact should no longer overflow when given certain large fractions. + +** srfi-9 accessor and modifier procedures now have strict record type checks. + +This matches the srfi-9 specification. + +** (ice-9 ftw) procedures won't ignore different files with same inode number. + +Previously the (ice-9 ftw) procedures would ignore any file that had +the same inode number as a file they had already seen, even if that +file was on a different device. -Changes since the 1.6.x series: +Changes in 1.8.0 (changes since the 1.6.x series): * Changes to the distribution diff --git a/configure.in b/configure.in index e06a4981a..9578cdfc8 100644 --- a/configure.in +++ b/configure.in @@ -523,14 +523,22 @@ AC_HEADER_TIME AC_HEADER_SYS_WAIT # Reasons for testing: +# complex.h - new in C99 # fenv.h - available in C99, but not older systems # -AC_CHECK_HEADERS([fenv.h io.h libc.h limits.h malloc.h memory.h string.h \ +AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.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 \ direct.h]) +# "complex double" is new in C99, and "complex" is only a keyword if +# is included +AC_CHECK_TYPES(complex double,,, +[#if HAVE_COMPLEX_H +#include +#endif]) + # On MacOS X contains socklen_t, so must include that # when testing. AC_CHECK_TYPE(socklen_t, , @@ -592,23 +600,31 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # DINFINITY - OSF specific # DQNAN - OSF specific # (DINFINITY and DQNAN are actually global variables, not functions) +# chsize - an MS-DOS-ism, found in mingw +# clog10 - not in mingw (though others like clog and csqrt are) # fesetround - available in C99, but not older systems +# ftruncate - posix, but probably not older systems (current mingw +# has it as an inline for chsize) # 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 +# truncate - not in mingw # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # -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 isblank _NSGetEnviron]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate 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 truncate unsetenv isblank _NSGetEnviron]) # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw +# sethostname - the function itself check because it's not in mingw, +# the DECL is checked because Solaris 10 doens't have in any header # AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) +AC_CHECK_DECLS([sethostname]) # crypt() may or may not be available, for instance in some countries there # are restrictions on cryptography. @@ -627,6 +643,38 @@ AC_SEARCH_LIBS(crypt, crypt, [AC_DEFINE(HAVE_CRYPT,1, [Define to 1 if you have the `crypt' function.])]) +# glibc 2.3.6 (circa 2006) and various prior versions had a bug where +# csqrt(-i) returned a negative real part, when it should be positive +# for the principal root. +# +if test "$ac_cv_type_complex_double" = yes; then + AC_CACHE_CHECK([whether csqrt is usable], + guile_cv_use_csqrt, + [AC_TRY_RUN([ +#include +/* "volatile" is meant to prevent gcc from calculating the sqrt as a + constant, we want to test libc. */ +volatile complex double z = - _Complex_I; +int +main (void) +{ + z = csqrt (z); + if (creal (z) > 0.0) + return 0; /* good */ + else + return 1; /* bad */ +}], + [guile_cv_use_csqrt=yes], + [guile_cv_use_csqrt="no, glibc 2.3 bug"], + [guile_cv_use_csqrt="yes, hopefully (cross-compiling)"])]) + case $guile_cv_use_csqrt in + yes*) + AC_DEFINE(HAVE_USABLE_CSQRT, 1, [Define to 1 if csqrt is bug-free]) + ;; + esac +fi + + dnl GMP tests AC_CHECK_LIB([gmp], [__gmpz_init], , [AC_MSG_ERROR([GNU MP not found, see README])]) @@ -878,10 +926,9 @@ AC_CHECK_HEADERS(floatingpoint.h ieeefp.h nan.h) # Reasons for testing: # asinh, acosh, atanh, trunc - C99 standard, generally not available on # older systems -# dirfd - mainly BSD derived, not in older systems # sincos - GLIBC extension # -AC_CHECK_FUNCS(asinh acosh atanh copysign dirfd finite sincos trunc) +AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc) # C99 specifies isinf and isnan as macros. # HP-UX provides only macros, no functions. @@ -924,6 +971,7 @@ fi # st_rdev # st_blksize # st_blocks not in mingw +# tm_gmtoff BSD+GNU, not in C99 # # Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the # AC_LIBOBJ(fileblocks) replacement which that macro gives. @@ -931,8 +979,22 @@ fi AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks]) AC_STRUCT_TIMEZONE +AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,, +[#include +#ifdef TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +]) GUILE_STRUCT_UTIMBUF + #-------------------------------------------------------------------- # # Which way does the stack grow? @@ -997,6 +1059,8 @@ AC_SUBST([SCM_I_GSC_USE_NULL_THREADS]) AC_ARG_WITH(threads, [ --with-threads thread interface], , with_threads=yes) +AC_SUBST(SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT, 0) + case "$with_threads" in "yes" | "pthread" | "pthreads" | "pthread-threads" | "") ACX_PTHREAD(CC="$PTHREAD_CC" @@ -1007,7 +1071,32 @@ case "$with_threads" in old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" - AC_CHECK_FUNCS(pthread_attr_getstack) + + # Reasons for testing: + # pthread_getattr_np - "np" meaning "non portable" says it + # all; not present on MacOS X or Solaris 10 + # + AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np) + + # On past versions of Solaris, believe 8 through 10 at least, you + # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };". + # This is contrary to posix: + # http://www.opengroup.org/onlinepubs/000095399/functions/pthread_once.html + # Check here if this style is required. + # + # glibc (2.3.6 at least) works both with or without braces, so the + # test checks whether it works without. + # + AC_CACHE_CHECK([whether PTHREAD_ONCE_INIT needs braces], + guile_cv_need_braces_on_pthread_once_init, + [AC_TRY_COMPILE([#include ], + [pthread_once_t foo = PTHREAD_ONCE_INIT;], + [guile_cv_need_braces_on_pthread_once_init=no], + [guile_cv_need_braces_on_pthread_once_init=yes])]) + if test "$guile_cv_need_braces_on_pthread_once_init" = yes; then + SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT=1 + fi + CFLAGS="$old_CFLAGS" # On Solaris, sched_yield lives in -lrt. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4b7b805f8..01a17aa77 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,50 @@ +2006-10-03 Kevin Ryde + + * eval.c (SCM_APPLY): For scm_tc7_subr_2o, throw wrong-num-args on 0 + arguments or 3 or more arguments. Previously 0 called proc with + SCM_UNDEFINED, and 3 or more silently used just the first 2. + +2006-09-28 Kevin Ryde + + * fports.c, ports.c (ftruncate): Use "HAVE_CHSIZE && ! HAVE_FTRUNCATE" + for chsize fallback, instead of hard-coding mingw. Mingw in fact + supplies ftruncate itself these days. + + * ports.c (fcntl.h): Can include this unconditionally, no need for + __MINGW32__. + + * ports.c (truncate): Conditionalize on "HAVE_FTRUNCATE && ! + HAVE_TRUNCATE" so as not to hard-code mingw. Use "const char *" and + "off_t" for parameters, per usual definition of this function, rather + than "char *" and "int". Use ftruncate instead of chsize. Check for + error on final close. + +2006-09-27 Kevin Ryde + + * numbers.c (scm_log10): Check HAVE_CLOG10, clog10() is not available + in mingw. + + * posix.c (scm_execl, scm_execlp, scm_execle): Cast "const char * + const *" for mingw to suppress warnings from gcc (which are errors + under the configure default -Werror). Reported by Nils Durner. + +2006-09-26 Kevin Ryde + + * _scm.h (scm_to_off64_t, scm_from_off64_t): New macros. + * fports.c (scm_open_file): Use open_or_open64. + (fport_seek_or_seek64): New function, adapting fport_seek. + * fports.c, fports.h (scm_i_fport_seek, scm_i_fport_truncate): New + functions. + * ports.c (scm_seek, scm_truncate_file): Use scm_i_fport_seek and + scm_i_fport_truncate to allow 64-bit seeks and truncates on fports. + + * ports.c (scm_truncate_file): Update docstring per manual. + +2006-09-23 Kevin Ryde + + * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New + functions. + 2006-09-20 Ludovic Courts * srfi-14.c: Include . Define `_GNU_SOURCE'. @@ -20,6 +67,11 @@ (scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a successful `setlocale ()' call. +2006-09-08 Kevin Ryde + + * socket.c (scm_init_socket): Add MSG_DONTWAIT. + (scm_recvfrom): Update docstring from manual. + 2006-08-31 Rob Browning * ports.c (scm_c_port_for_each): Add a @@ -32,11 +84,47 @@ improvements to docstring. (scm_backtrace_with_highlights): Analogous improvements. +2006-08-12 Kevin Ryde + + * gen-scmconfig.h.in (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT): + New, set from configure. + * gen-scmconfig.c (SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT): New output + to scmconfig.h. + * pthread-threads.h (SCM_I_PTHREAD_ONCE_INIT): Use + SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT to cope with Solaris. + Reported by Claes Wallin. + 2006-08-11 Neil Jerram * stacks.c (scm_last_stack_frame): Correct docstring (returns a frame, not a stack). +2006-07-25 Kevin Ryde + + * threads.c (get_thread_stack_base): Restrict HAVE_PTHREAD_GETATTR_NP + on pthreads version, since pthread_getattr_np not available on solaris + and macos. Reported by Claes Wallin. + +2006-07-24 Kevin Ryde + + * filesys.c (dirfd): Test with #ifndef rather than HAVE_DIRFD, since + it's a macro on MacOS X. Reported by Claes Wallin. + + * posix.c (sethostname): Give prototype if not HAVE_DECL_SETHOSTNAME, + for the benefit of Solaris 10. Reported by Claes Wallin. + + * socket.c (scm_htonl, scm_ntohl): Use scm_to_uint32 rather than + NUM2ULONG, to enforce 32-bit range check on systems with 64-bit long. + +2006-07-21 Kevin Ryde + + * eval.c, filesys.c (alloca): Update etc blob, per current + autoconf recommendation. Should fix Solaris 10 reported by Claes + Wallin. + + * threads.c: Include , needed for memset() which is used by + FD_ZERO() on Solaris 10. Reported by Claes Wallin. + 2006-07-18 Rob Browning * continuations.c: Add __attribute__ ((returns_twice)) to the @@ -49,6 +137,25 @@ * numbers.c (guile_ieee_init): Use regular ANSI C casts rather than C++-style `X_CAST ()'. Patch posted by by Mike Gran. +2006-07-08 Kevin Ryde + + * environments.c (core_environments_unobserve): Use if/else rather + than ?: for "SET" bits, avoiding complaints from AIX xlc compiler + about them not being rvalues. Reported by Mike Gran. + + * Makefile.am (version.h): Don't use $< in an explicit rule, it's not + portable and in particular fails on OpenBSD and AIX (see autoconf + manual too). Reported by Mike Gran. + +2006-06-25 Kevin Ryde + + * stime.c (bdtime2c): tm_gmtoff is seconds East, so take negative of + tm:gmtoff which is seconds West. Reported by Aaron VanDevender. + (bdtime2c): Test HAVE_STRUCT_TM_TM_GMTOFF for tm_gmtoff, rather than + HAVE_TM_ZONE. + (scm_strptime): Use tm_gmtoff from the strptime result when that field + exists, it's set by glibc strptime "%s". + 2006-06-13 Ludovic Courts * eq.c: Include "struct.h", "goops.h" and "objects.h". diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 68b5dfdc7..bf121161f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -220,7 +220,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ ## usual @...@, so autoconf doesn't go and substitute the values ## directly into the left-hand sides of the sed substitutions. *sigh* version.h: version.h.in - sed < $< > $@.tmp \ + sed < $(srcdir)/version.h.in > $@.tmp \ -e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \ -e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \ -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}: diff --git a/libguile/_scm.h b/libguile/_scm.h index ea654ad39..906de3780 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -167,6 +167,8 @@ #else # error sizeof(off_t) is not 4 or 8. #endif +#define scm_to_off64_t scm_to_int64 +#define scm_from_off64_t scm_from_int64 #endif /* SCM__SCM_H */ diff --git a/libguile/environments.c b/libguile/environments.c index a94f119cd..5d15f36bc 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -687,9 +687,10 @@ core_environments_unobserve (SCM env, SCM observer) if (scm_is_eq (first, observer)) { /* Remove the first observer */ - handling_weaks - ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest) - : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); + if (handling_weaks) + SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest); + else + SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); return; } diff --git a/libguile/eval.c b/libguile/eval.c index 9fe419137..db5c00529 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -37,24 +37,22 @@ #ifndef DEVAL -/* AIX requires this to be the first thing in the file. The #pragma - directive is indented so pre-ANSI compilers will ignore it, rather - than choke on it. */ -#ifndef __GNUC__ -# if HAVE_ALLOCA_H -# include -# else -# ifdef _AIX -# pragma alloca -# else -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif +/* This blob per the Autoconf manual (under "Particular Functions"). */ +#if HAVE_ALLOCA_H +# include +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include /* alloca on mingw */ +void *alloca (size_t); #endif #include @@ -4851,7 +4849,16 @@ tail: switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2o: - args = scm_is_null (args) ? SCM_UNDEFINED : SCM_CAR (args); + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + if (scm_is_null (args)) + args = SCM_UNDEFINED; + else + { + if (! scm_is_null (SCM_CDR (args))) + scm_wrong_num_args (proc); + args = SCM_CAR (args); + } RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) diff --git a/libguile/filesys.c b/libguile/filesys.c index 8ac6bd246..72b45e92a 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -29,24 +29,22 @@ # include #endif -/* AIX requires this to be the first thing in the file. The #pragma - directive is indented so pre-ANSI compilers will ignore it, rather - than choke on it. */ -#ifndef __GNUC__ -# if HAVE_ALLOCA_H -# include -# else -# ifdef _AIX -# pragma alloca -# else -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif +/* This blob per the Autoconf manual (under "Particular Functions"). */ +#if HAVE_ALLOCA_H +# include +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include /* alloca on mingw, though its not used on that system */ +void *alloca (size_t); #endif #include @@ -202,10 +200,14 @@ char *alloca (); # define fchmod(fd, mode) (-1) #endif /* __MINGW32__ */ -/* This definition is for Solaris 10, it's probably not right elsewhere, but - that's ok, it shouldn't be used elsewhere. */ -#if ! HAVE_DIRFD -#define dirfd(dirstream) (dirstream->dd_fd) +/* dirfd() returns the file descriptor underlying a "DIR*" directory stream. + Found on MacOS X for instance. The following definition is for Solaris + 10, it's probably not right elsewhere, but that's ok, it shouldn't be + used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4 + figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field, + or d_fd field). */ +#ifndef dirfd +#define dirfd(dirstream) ((dirstream)->dd_fd) #endif diff --git a/libguile/fports.c b/libguile/fports.c index 563557e82..010e5dda6 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -17,6 +17,8 @@ +#define _LARGEFILE64_SOURCE /* ask for stat64 etc */ + #if HAVE_CONFIG_H # include #endif @@ -46,6 +48,7 @@ #endif #include +#include #include "libguile/iselect.h" @@ -53,9 +56,33 @@ #ifdef __MINGW32__ # include # include -# define ftruncate(fd, size) chsize (fd, size) #endif /* __MINGW32__ */ +/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize + already, but have this code here in case that wasn't so in past versions, + or perhaps to help other minimal DOS environments. + + gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which + might be possibilities if we've got other systems without ftruncate. */ + +#if HAVE_CHSIZE && ! HAVE_FTRUNCATE +# define ftruncate(fd, size) chsize (fd, size) +#undef HAVE_FTRUNCATE +#define HAVE_FTRUNCATE 1 +#endif + +#if SIZEOF_OFF_T == SIZEOF_INT +#define OFF_T_MAX INT_MAX +#define OFF_T_MIN INT_MIN +#elif SIZEOF_OFF_T == SIZEOF_LONG +#define OFF_T_MAX LONG_MAX +#define OFF_T_MIN LONG_MIN +#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG +#define OFF_T_MAX LONG_LONG_MAX +#define OFF_T_MIN LONG_LONG_MIN +#else +#error Oops, unknown OFF_T size +#endif scm_t_bits scm_tc16_fport; @@ -334,7 +361,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, } ptr++; } - SCM_SYSCALL (fdes = open (file, flags, 0666)); + SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666)); if (fdes == -1) { int en = errno; @@ -583,25 +610,25 @@ fport_fill_input (SCM port) } } -static off_t -fport_seek (SCM port, off_t offset, int whence) +static off_t_or_off64_t +fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence) { scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); - off_t rv; - off_t result; + off_t_or_off64_t rv; + off_t_or_off64_t result; if (pt->rw_active == SCM_PORT_WRITE) { if (offset != 0 || whence != SEEK_CUR) { fport_flush (port); - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } else { /* read current position without disturbing the buffer. */ - rv = lseek (fp->fdes, offset, whence); + rv = lseek_or_lseek64 (fp->fdes, offset, whence); result = rv + (pt->write_pos - pt->write_buf); } } @@ -611,13 +638,13 @@ fport_seek (SCM port, off_t offset, int whence) { /* could expand to avoid a second seek. */ scm_end_input (port); - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } else { /* read current position without disturbing the buffer (particularly the unread-char buffer). */ - rv = lseek (fp->fdes, offset, whence); + rv = lseek_or_lseek64 (fp->fdes, offset, whence); result = rv - (pt->read_end - pt->read_pos); if (pt->read_buf == pt->putback_buf) @@ -626,7 +653,7 @@ fport_seek (SCM port, off_t offset, int whence) } else /* SCM_PORT_NEITHER */ { - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } if (rv == -1) @@ -635,6 +662,39 @@ fport_seek (SCM port, off_t offset, int whence) return result; } +/* If we've got largefile and off_t isn't already off64_t then + fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in + the port descriptor. + + Otherwise if no largefile, or off_t is the same as off64_t (which is the + case on NetBSD apparently), then fport_seek_or_seek64 is right to be + fport_seek already. */ + +#if HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T +static off_t +fport_seek (SCM port, off_t offset, int whence) +{ + off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence); + if (rv > OFF_T_MAX || rv < OFF_T_MIN) + { + errno = EOVERFLOW; + scm_syserror ("fport_seek"); + } + return (off_t) rv; + +} +#else +#define fport_seek fport_seek_or_seek64 +#endif + +/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */ +SCM +scm_i_fport_seek (SCM port, SCM offset, int how) +{ + return scm_from_off_t_or_off64_t + (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how)); +} + static void fport_truncate (SCM port, off_t length) { @@ -644,6 +704,13 @@ fport_truncate (SCM port, off_t length) scm_syserror ("ftruncate"); } +int +scm_i_fport_truncate (SCM port, SCM length) +{ + scm_t_fport *fp = SCM_FSTREAM (port); + return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length)); +} + /* helper for fport_write: try to write data, using multiple system calls if required. */ #define FUNC_NAME "write_all" diff --git a/libguile/fports.h b/libguile/fports.h index efc315792..634106760 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -58,6 +58,9 @@ SCM_API void scm_init_fports (void); /* internal functions */ SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); +SCM_API int scm_i_fport_truncate (SCM, SCM); +SCM_API SCM scm_i_fport_seek (SCM, SCM, int); + #endif /* SCM_FPORTS_H */ diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index d162e395a..43a2a989d 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -378,6 +378,10 @@ main (int argc, char *argv[]) pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n", SCM_I_GSC_USE_NULL_THREADS); + pf ("/* Define to 1 if need braces around PTHREAD_ONCE_INIT (for Solaris). */\n"); + pf ("#define SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT %d /* 0 or 1 */\n", + SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT); + #if USE_DLL_IMPORT pf ("\n"); pf ("/* Define some additional CPP macros on Win32 platforms. */\n"); diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in index 8ceed8463..b4e0561f1 100644 --- a/libguile/gen-scmconfig.h.in +++ b/libguile/gen-scmconfig.h.in @@ -28,6 +28,7 @@ #define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@ #define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@ #define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@ +#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@ /* Local Variables: diff --git a/libguile/numbers.c b/libguile/numbers.c index caaa6e2fc..2aa2de81b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -40,7 +40,7 @@ */ -/* tell glibc (2.3) to give prototype for C99 trunc() */ +/* tell glibc (2.3) to give prototype for C99 trunc(), csqrt(), etc */ #define _GNU_SOURCE #if HAVE_CONFIG_H @@ -51,6 +51,10 @@ #include #include +#if HAVE_COMPLEX_H +#include +#endif + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -66,6 +70,14 @@ #include "libguile/discouraged.h" +/* values per glibc, if not already defined */ +#ifndef M_LOG10E +#define M_LOG10E 0.43429448190325182765 +#endif +#ifndef M_PI +#define M_PI 3.14159265358979323846 +#endif + /* @@ -150,6 +162,21 @@ xisnan (double x) #endif } + +/* For an SCM object Z which is a complex number (ie. satisfies + SCM_COMPLEXP), return its value as a C level "complex double". */ +#define SCM_COMPLEX_VALUE(z) \ + (SCM_COMPLEX_REAL (z) + _Complex_I * SCM_COMPLEX_IMAG (z)) + +/* Convert a C "complex double" to an SCM value. */ +#if HAVE_COMPLEX_DOUBLE +static SCM +scm_from_complex_double (complex double z) +{ + return scm_c_make_rectangular (creal (z), cimag (z)); +} +#endif /* HAVE_COMPLEX_DOUBLE */ + static mpz_t z_negative_one; @@ -5977,6 +6004,142 @@ scm_is_number (SCM z) return scm_is_true (scm_number_p (z)); } + +/* In the following functions we dispatch to the real-arg funcs like log() + when we know the arg is real, instead of just handing everything to + clog() for instance. This is in case clog() doesn't optimize for a + real-only case, and because we have to test SCM_COMPLEXP anyway so may as + well use it to go straight to the applicable C func. */ + +SCM_DEFINE (scm_log, "log", 1, 0, 0, + (SCM z), + "Return the natural logarithm of @var{z}.") +#define FUNC_NAME s_scm_log +{ + if (SCM_COMPLEXP (z)) + { +#if HAVE_COMPLEX_DOUBLE + return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z))); +#else + double re = SCM_COMPLEX_REAL (z); + double im = SCM_COMPLEX_IMAG (z); + return scm_c_make_rectangular (log (hypot (re, im)), + atan2 (im, re)); +#endif + } + else + { + /* ENHANCE-ME: When z is a bignum the logarithm will fit a double + although the value itself overflows. */ + double re = scm_to_double (z); + double l = log (fabs (re)); + if (re >= 0.0) + return scm_from_double (l); + else + return scm_c_make_rectangular (l, M_PI); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_log10, "log10", 1, 0, 0, + (SCM z), + "Return the base 10 logarithm of @var{z}.") +#define FUNC_NAME s_scm_log10 +{ + if (SCM_COMPLEXP (z)) + { + /* Mingw has clog() but not clog10(). (Maybe it'd be worth using + clog() and a multiply by M_LOG10E, rather than the fallback + log10+hypot+atan2.) */ +#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG10 + return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z))); +#else + double re = SCM_COMPLEX_REAL (z); + double im = SCM_COMPLEX_IMAG (z); + return scm_c_make_rectangular (log10 (hypot (re, im)), + M_LOG10E * atan2 (im, re)); +#endif + } + else + { + /* ENHANCE-ME: When z is a bignum the logarithm will fit a double + although the value itself overflows. */ + double re = scm_to_double (z); + double l = log10 (fabs (re)); + if (re >= 0.0) + return scm_from_double (l); + else + return scm_c_make_rectangular (l, M_LOG10E * M_PI); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_exp, "exp", 1, 0, 0, + (SCM z), + "Return @math{e} to the power of @var{z}, where @math{e} is the\n" + "base of natural logarithms (2.71828@dots{}).") +#define FUNC_NAME s_scm_exp +{ + if (SCM_COMPLEXP (z)) + { +#if HAVE_COMPLEX_DOUBLE + return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z))); +#else + return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)), + SCM_COMPLEX_IMAG (z)); +#endif + } + else + { + /* When z is a negative bignum the conversion to double overflows, + giving -infinity, but that's ok, the exp is still 0.0. */ + return scm_from_double (exp (scm_to_double (z))); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_sqrt, "sqrt", 1, 0, 0, + (SCM x), + "Return the square root of @var{z}. Of the two possible roots\n" + "(positive and negative), the one with the a positive real part\n" + "is returned, or if that's zero then a positive imaginary part.\n" + "Thus,\n" + "\n" + "@example\n" + "(sqrt 9.0) @result{} 3.0\n" + "(sqrt -9.0) @result{} 0.0+3.0i\n" + "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n" + "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n" + "@end example") +#define FUNC_NAME s_scm_sqrt +{ + if (SCM_COMPLEXP (x)) + { +#if HAVE_COMPLEX_DOUBLE && HAVE_USABLE_CSQRT + return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (x))); +#else + double re = SCM_COMPLEX_REAL (x); + double im = SCM_COMPLEX_IMAG (x); + return scm_c_make_polar (sqrt (hypot (re, im)), + 0.5 * atan2 (im, re)); +#endif + } + else + { + double xx = scm_to_double (x); + if (xx < 0) + return scm_c_make_rectangular (0.0, sqrt (-xx)); + else + return scm_from_double (sqrt (xx)); + } +} +#undef FUNC_NAME + + + void scm_init_numbers () { diff --git a/libguile/numbers.h b/libguile/numbers.h index 40b836959..8448b7fd2 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -263,6 +263,10 @@ SCM_API SCM scm_angle (SCM z); SCM_API SCM scm_exact_to_inexact (SCM z); SCM_API SCM scm_inexact_to_exact (SCM z); SCM_API SCM scm_trunc (SCM x); +SCM_API SCM scm_log (SCM z); +SCM_API SCM scm_log10 (SCM z); +SCM_API SCM scm_exp (SCM z); +SCM_API SCM scm_sqrt (SCM z); /* bignum internal functions */ SCM_API SCM scm_i_mkbig (void); diff --git a/libguile/ports.c b/libguile/ports.c index 2628cfc06..a1ebb57d5 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -27,10 +27,12 @@ #include #include +#include /* for chsize on mingw */ #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" +#include "libguile/fports.h" /* direct access for seek and truncate */ #include "libguile/objects.h" #include "libguile/goops.h" #include "libguile/smob.h" @@ -66,9 +68,17 @@ #include #endif -#ifdef __MINGW32__ -#include +/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize + already, but have this code here in case that wasn't so in past versions, + or perhaps to help other minimal DOS environments. + + gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which + might be possibilities if we've got other systems without ftruncate. */ + +#if HAVE_CHSIZE && ! HAVE_FTRUNCATE #define ftruncate(fd, size) chsize (fd, size) +#undef HAVE_FTRUNCATE +#define HAVE_FTRUNCATE 1 #endif @@ -1382,7 +1392,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); - if (SCM_OPPORTP (fd_port)) + if (SCM_OPFPORTP (fd_port)) + { + /* go direct to fport code to allow 64-bit offsets */ + return scm_i_fport_seek (fd_port, offset, how); + } + else if (SCM_OPPORTP (fd_port)) { scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); off_t off = scm_to_off_t (offset); @@ -1407,28 +1422,48 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, } #undef FUNC_NAME -#ifdef __MINGW32__ -/* Define this function since it is not supported under Windows. */ -static int truncate (char *file, int length) +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +/* Mingw has ftruncate(), perhaps implemented above using chsize, but + doesn't have the filename version truncate(), hence this code. */ +#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE +static int +truncate (const char *file, off_t length) { - int ret = -1, fdes; - if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1) + int ret, fdes; + + fdes = open (file, O_BINARY | O_WRONLY); + if (fdes == -1) + return -1; + + ret = ftruncate (fdes, length); + if (ret == -1) { - ret = chsize (fdes, length); + int save_errno = errno; close (fdes); + errno = save_errno; + return -1; } - return ret; + + return close (fdes); } -#endif /* __MINGW32__ */ +#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, (SCM object, SCM length), - "Truncates the object referred to by @var{object} to at most\n" - "@var{length} bytes. @var{object} can be a string containing a\n" - "file name or an integer file descriptor or a port.\n" - "@var{length} may be omitted if @var{object} is not a file name,\n" - "in which case the truncation occurs at the current port\n" - "position. The return value is unspecified.") + "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n" + "filename string, a port object, or an integer file descriptor.\n" + "The return value is unspecified.\n" + "\n" + "For a port or file descriptor @var{length} can be omitted, in\n" + "which case the file is truncated at the current position (per\n" + "@code{ftell} above).\n" + "\n" + "On most systems a file can be extended by giving a length\n" + "greater than the current size, but this is not mandatory in the\n" + "POSIX standard.") #define FUNC_NAME s_scm_truncate_file { int rv; @@ -1455,6 +1490,11 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), c_length)); } + else if (SCM_OPOUTFPORTP (object)) + { + /* go direct to fport code to allow 64-bit offsets */ + rv = scm_i_fport_truncate (object, length); + } else if (SCM_OPOUTPORTP (object)) { off_t c_length = scm_to_off_t (length); diff --git a/libguile/posix.c b/libguile/posix.c index 136d77084..8a83a1e7e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -157,6 +157,12 @@ extern char ** environ; #define F_OK 0 #endif +/* No prototype for this on Solaris 10. The man page says it's in + ... but it lies. */ +#if ! HAVE_DECL_SETHOSTNAME +int sethostname (char *name, size_t namelen); +#endif + /* On NextStep, doesn't define struct utime, unless we #define _POSIX_SOURCE before #including it. I think this is less of a kludge than defining struct utimbuf ourselves. */ @@ -943,7 +949,12 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_argv, SCM_F_WIND_EXPLICITLY); - execv (exec_file, exec_argv); + execv (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; /* not reached. */ @@ -974,7 +985,12 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_argv, SCM_F_WIND_EXPLICITLY); - execvp (exec_file, exec_argv); + execvp (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; /* not reached. */ @@ -1013,7 +1029,17 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_env, SCM_F_WIND_EXPLICITLY); - execve (exec_file, exec_argv, exec_env); + execve (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_env); SCM_SYSERROR; /* not reached. */ diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 06e735f75..015a70767 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -66,8 +66,12 @@ extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1]; /* Onces */ #define scm_i_pthread_once_t pthread_once_t -#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT #define scm_i_pthread_once pthread_once +#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT +#define SCM_I_PTHREAD_ONCE_INIT { PTHREAD_ONCE_INIT } +#else +#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT +#endif /* Thread specific storage */ diff --git a/libguile/socket.c b/libguile/socket.c index a9b7ed8ca..5d09c615b 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -98,9 +98,7 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_htonl { - scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); - - return scm_from_ulong (htonl (c_in)); + return scm_from_ulong (htonl (scm_to_uint32 (value))); } #undef FUNC_NAME @@ -111,9 +109,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_ntohl { - scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); - - return scm_from_ulong (ntohl (c_in)); + return scm_from_ulong (ntohl (scm_to_uint32 (value))); } #undef FUNC_NAME @@ -1459,25 +1455,34 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, (SCM sock, SCM str, SCM flags, SCM start, SCM end), - "Return data from the socket port @var{sock} and also\n" - "information about where the data was received from.\n" - "@var{sock} must already be bound to the address from which\n" - "data is to be received. @code{str}, is a string into which the\n" - "data will be written. The size of @var{str} limits the amount\n" - "of data which can be received: in the case of packet protocols,\n" - "if a packet larger than this limit is encountered then some\n" - "data will be irrevocably lost.\n\n" - "The optional @var{flags} argument is a value or bitwise OR of\n" - "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n" - "The value returned is a pair: the @emph{car} is the number of\n" - "bytes read from the socket and the @emph{cdr} an address object\n" - "in the same form as returned by @code{accept}. The address\n" - "will given as @code{#f} if not available, as is usually the\n" - "case for stream sockets.\n\n" - "The @var{start} and @var{end} arguments specify a substring of\n" - "@var{str} to which the data should be written.\n\n" - "Note that the data is read directly from the socket file\n" - "descriptor: any unread buffered port data is ignored.") + "Receive data from socket port @var{sock} (which must be already\n" + "bound), returning the originating address as well as the data.\n" + "This is usually for use on datagram sockets, but can be used on\n" + "stream-oriented sockets too.\n" + "\n" + "The data received is stored in the given @var{str}, using\n" + "either the whole string or just the region between the optional\n" + "@var{start} and @var{end} positions. The size of @var{str}\n" + "limits the amount of data which can be received. For datagram\n" + "protocols, if a packet larger than this is received then excess\n" + "bytes are irrevocably lost.\n" + "\n" + "The return value is a pair. The @code{car} is the number of\n" + "bytes read. The @code{cdr} is a socket address object which is\n" + "where the data come from, or @code{#f} if the origin is\n" + "unknown.\n" + "\n" + "The optional @var{flags} argument is a or bitwise OR\n" + "(@code{logior}) of @code{MSG_OOB}, @code{MSG_PEEK},\n" + "@code{MSG_DONTROUTE} etc.\n" + "\n" + "Data is read directly from the socket file descriptor, any\n" + "buffered port data is ignored.\n" + "\n" + "On a GNU/Linux system @code{recvfrom!} is not multi-threading,\n" + "all threads stop while a @code{recvfrom!} call is in progress.\n" + "An application may need to use @code{select}, @code{O_NONBLOCK}\n" + "or @code{MSG_DONTWAIT} to avoid this.") #define FUNC_NAME s_scm_recvfrom { int rv; @@ -1728,6 +1733,9 @@ scm_init_socket () #endif /* recv/send options. */ +#ifdef MSG_DONTWAIT + scm_c_define ("MSG_DONTWAIT", scm_from_int (MSG_DONTWAIT)); +#endif #ifdef MSG_OOB scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB)); #endif diff --git a/libguile/stime.c b/libguile/stime.c index 37d2290cf..418e80f21 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -497,8 +497,10 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6)); lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7)); lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8)); +#if HAVE_STRUCT_TM_TM_GMTOFF + lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); +#endif #ifdef HAVE_TM_ZONE - lt->tm_gmtoff = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10))) lt->tm_zone = NULL; else @@ -731,6 +733,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, { struct tm t; const char *fmt, *str, *rest; + long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); @@ -748,6 +751,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, tm_init (tm_year); tm_init (tm_wday); tm_init (tm_yday); +#if HAVE_STRUCT_TM_TM_GMTOFF + tm_init (tm_gmtoff); +#endif #undef tm_init /* GNU glibc strptime() "%s" is affected by the current timezone, since it @@ -766,7 +772,15 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, SCM_SYSERROR; } - return scm_cons (filltime (&t, 0, NULL), + /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when + available */ +#if HAVE_STRUCT_TM_TM_GMTOFF + zoff = - t.tm_gmtoff; /* seconds west, not east */ +#else + zoff = 0; +#endif + + return scm_cons (filltime (&t, zoff, NULL), scm_from_signed_integer (rest - str)); } #undef FUNC_NAME diff --git a/libguile/threads.c b/libguile/threads.c index 20b8e38c9..428133d8a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -27,6 +27,11 @@ #endif #include #include + +#ifdef HAVE_STRING_H +#include /* for memset used by FD_ZERO on Solaris 10 */ +#endif + #if HAVE_SYS_TIME_H #include #endif @@ -566,7 +571,8 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } #if SCM_USE_PTHREAD_THREADS -#ifdef HAVE_PTHREAD_ATTR_GETSTACK +/* pthread_getattr_np not available on MacOS X and Solaris 10. */ +#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP #define HAVE_GET_THREAD_STACK_BASE @@ -600,7 +606,7 @@ get_thread_stack_base () } } -#endif /* HAVE_PTHREAD_ATTR_GETSTACK */ +#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */ #else /* !SCM_USE_PTHREAD_THREADS */ diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1a5c26a56..a35e29704 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,29 @@ +2006-10-05 Kevin Ryde + + * tests/ftw.test: New file. + * Makefile.am (SCM_TESTS): Add it. + +2006-10-03 Kevin Ryde + + * tests/eval.test (apply): New tests, exercising scm_tc7_subr_2o which + had lacked some arg count checking. + +2006-09-26 Kevin Ryde + + * tests/ports.test (seek): New tests. + (truncate-file): More tests. + +2006-09-23 Kevin Ryde + + * tests/numbers.test (exp, log, log10, sqrt): New tests. + + * tests/format.test, tests/srfi-1.test: Use define-module to prevent + redefined funcs in those modules extending on to subsequent tests. + + * tests/time.test (gmtime, strptime): Remove the "unresolved" throws, + the error+thread tests seem ok now (previously were upset by something + leaking out of syntax.test). + 2006-09-20 Ludovic Courts * tests/srfi-14.test: Use `define-module'. Use modules `(srfi @@ -7,6 +33,42 @@ (every?, find-latin1-locale): New procedures. (%latin1): New variable. +2006-09-08 Kevin Ryde + + * tests/format.test (~f): Test leading zeros bugfix. + +2006-08-25 Kevin Ryde + + * tests/popen.test (open-input-pipe, open-output-pipe): In the "no + duplicate" tests, close parent side of signalling pipe, to hopefully + generate an error instead of a hang if something bad in the child + means it doesn't write anything. + +2006-08-22 Kevin Ryde + + * tests/srfi-9.test: More tests, in particular check for exceptions on + wrong record types passed to accessor and modifier funcs. + +2006-07-25 Kevin Ryde + + * standalone/test-conversion.c, standalone/test-gh.c, + standalone/test-list.c, standalone/test-num2integral.c, + standalone/test-round.c: Use scm_boot_guile rather than + scm_init_guile, for the benefit of those systems where we can't + implement the latter. Reported by Claes Wallin. + + * standalone/test-require-extension: Use "&& exit 1" instead of "!" to + invert the sense of exit statuses, as the latter doesn't work on + Solaris 10. Reported by Claes Wallin. + +2006-07-24 Kevin Ryde + + * tests/socket.test (htonl, ntohl): New tests. + +2006-07-06 Kevin Ryde + + * tests/time.test (localtime, mktime, strptime): More tests. + 2006-06-13 Ludovic Courts * Makefile.am (SCM_TESTS): Added `tests/structs.test'. diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index c0efc78a9..2714eeb1e 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -36,6 +36,7 @@ SCM_TESTS = tests/alist.test \ tests/filesys.test \ tests/format.test \ tests/fractions.test \ + tests/ftw.test \ tests/gc.test \ tests/getopt-long.test \ tests/goops.test \ diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 9f1a7b60f..2ddbf75a6 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -1010,10 +1010,9 @@ test_locale_strings () test_11 ("(string #\\f #\\nul)", NULL, 1, 0); } -int -main (int argc, char *argv[]) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile(); test_is_signed_integer (); test_is_unsigned_integer (); test_to_signed_integer (); @@ -1024,5 +1023,11 @@ main (int argc, char *argv[]) test_from_double (); test_to_double (); test_locale_strings (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-gh.c b/test-suite/standalone/test-gh.c index 7e030f4d3..78cf87fa5 100644 --- a/test-suite/standalone/test-gh.c +++ b/test-suite/standalone/test-gh.c @@ -67,11 +67,16 @@ test_gh_set_substr () assert (string_equal (string, "Frdarnitrnit!")); } -int +static void +tests (void *data, int argc, char **argv) +{ + test_gh_set_substr (); +} + +int main (int argc, char *argv[]) { - scm_init_guile (); - test_gh_set_substr (); + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-list.c b/test-suite/standalone/test-list.c index de2645fb9..7a9514ae9 100644 --- a/test-suite/standalone/test-list.c +++ b/test-suite/standalone/test-list.c @@ -46,10 +46,15 @@ test_scm_list (void) } } -int -main (int argc, char **argv) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile(); test_scm_list (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index 947890a48..86c3e5db7 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -141,12 +141,17 @@ test_ulong_long () #endif /* SCM_SIZEOF_LONG_LONG != 0 */ } +static void +tests (void *data, int argc, char **argv) +{ + test_long_long (); + test_ulong_long (); +} + int main (int argc, char *argv[]) { - scm_init_guile(); - test_long_long (); - test_ulong_long (); + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-require-extension b/test-suite/standalone/test-require-extension index c953a30af..730137b55 100755 --- a/test-suite/standalone/test-require-extension +++ b/test-suite/standalone/test-require-extension @@ -2,10 +2,16 @@ set -e -! guile -c '(require-extension 7)' 2> /dev/null -! guile -c '(require-extension (blarg))' 2> /dev/null -! guile -c '(require-extension (srfi "foo"))' 2> /dev/null +# expect these to throw errors, if they succeed it's wrong +# +# (Note the syntax "! guile -c ..." isn't used here, because that doesn't +# work on Solaris 10.) +# +guile -c '(require-extension 7)' 2>/dev/null && exit 1 +guile -c '(require-extension (blarg))' 2>/dev/null && exit 1 +guile -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1 +# expect these to succeed guile -c '(require-extension (srfi 1)) (exit (procedure? take-right))' guile -c '(require-extension (srfi))' diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index c594d5812..a3928d26b 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -113,10 +113,15 @@ test_scm_c_round () } } +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_round (); +} + int main (int argc, char *argv[]) { - scm_init_guile(); - test_scm_c_round (); + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 6bca6235c..4adf0312f 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -99,10 +99,10 @@ )) ;;; -;;; apply +;;; call ;;; -(with-test-prefix "application" +(with-test-prefix "call" (with-test-prefix "wrong number of arguments" @@ -142,6 +142,30 @@ exception:wrong-num-args ((lambda (x y . rest) #f) 1)))) +;;; +;;; apply +;;; + +(with-test-prefix "apply" + + (with-test-prefix "scm_tc7_subr_2o" + + ;; prior to guile 1.6.9 and 1.8.1 this called the function with + ;; SCM_UNDEFIEND, which in the case of make-vector resulted in + ;; wrong-type-arg, instead of the intended wrong-num-args + (pass-if-exception "0 args" exception:wrong-num-args + (apply make-vector '())) + + (pass-if "1 arg" + (vector? (apply make-vector '(1)))) + + (pass-if "2 args" + (vector? (apply make-vector '(1 2)))) + + ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected + (pass-if-exception "3 args" exception:wrong-num-args + (apply make-vector '(1 2 3))))) + ;;; ;;; map ;;; diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index 3cdc8dc75..cc3b6684b 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -18,8 +18,10 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (test-suite lib) - (ice-9 format)) +(define-module (test-format) + #:use-module (test-suite lib) + #:use-module (ice-9 format)) + ;;; FORMAT Basic Output @@ -72,6 +74,20 @@ (pass-if "+1" (string=? (format #f "~@d" 1) "+1")))) +;;; +;;; ~f +;;; + +(with-test-prefix "~f fixed-point" + + (pass-if "1.5" + (string=? "1.5" (format #f "~f" 1.5))) + + ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly + ;; stripped, moving the decimal point and giving "25.0" here + (pass-if "string 02.5" + (string=? "2.5" (format #f "~f" "02.5")))) + ;;; ;;; ~{ ;;; diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test new file mode 100644 index 000000000..a61850af2 --- /dev/null +++ b/test-suite/tests/ftw.test @@ -0,0 +1,73 @@ +;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- +;;;; +;;;; Copyright 2006 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 2.1 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 + +(define-module (test-suite test-ice-9-ftw) + #:use-module (test-suite lib) + #:use-module (ice-9 ftw)) + + +;; the procedure-source checks here ensure the vector indexes we write match +;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match +;; libguile/filesys.c of course) + +(or (equal? (procedure-source stat:dev) + '(lambda (f) (vector-ref f 0))) + (error "oops, unexpected stat:dev definition")) +(define (stat:dev! st dev) + (vector-set! st 0 dev)) + +(or (equal? (procedure-source stat:ino) + '(lambda (f) (vector-ref f 1))) + (error "oops, unexpected stat:ino definition")) +(define (stat:ino! st ino) + (vector-set! st 1 ino)) + + +;; +;; visited?-proc +;; + +(with-test-prefix "visited?-proc" + + ;; normally internal-only + (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc)) + (visited? (visited?-proc 97)) + (s (stat "/"))) + + (define (try-visited? dev ino) + (stat:dev! s dev) + (stat:ino! s ino) + (visited? s)) + + (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0))) + (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0))) + (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0))) + + (pass-if "0 1" (eq? #f (try-visited? 0 1))) + (pass-if "0 2" (eq? #f (try-visited? 0 2))) + (pass-if "0 3" (eq? #f (try-visited? 0 3))) + + (pass-if "5 5" (eq? #f (try-visited? 5 5))) + (pass-if "5 7" (eq? #f (try-visited? 5 7))) + (pass-if "7 5" (eq? #f (try-visited? 7 5))) + (pass-if "7 7" (eq? #f (try-visited? 7 7))) + + (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5))) + (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7))) + (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5))) + (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7))))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index af67d6816..78d130a2b 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -71,6 +71,32 @@ (quotient (- n d -1) d) ;; neg/pos (quotient n d))) ;; pos/pos +;; return true of X is in the range LO to HI, inclusive +(define (within-range? lo hi x) + (and (>= x (min lo hi)) + (<= x (max lo hi)))) + +;; return true if GOT is within +/- 0.01 of GOT +;; for a complex number both real and imaginary parts must be in that range +(define (eqv-loosely? want got) + (and (within-range? (- (real-part want) 0.01) + (+ (real-part want) 0.01) + (real-part got)) + (within-range? (- (imag-part want) 0.01) + (+ (imag-part want) 0.01) + (imag-part got)))) + +;; return true if OBJ is negative infinity +(define (negative-infinity? obj) + (and (real? obj) + (negative? obj) + (inf? obj))) + +(define const-e 2.7182818284590452354) +(define const-e^2 7.3890560989306502274) +(define const-1/e 0.3678794411714423215) + + ;;; ;;; 1+ ;;; @@ -200,6 +226,36 @@ (pass-if "sqrt ((fixnum-max+1)^2 - 1)" (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) +;;; +;;; exp +;;; + +(with-test-prefix "exp" + (pass-if "documented?" + (documented? exp)) + + (pass-if-exception "no args" exception:wrong-num-args + (exp)) + (pass-if-exception "two args" exception:wrong-num-args + (exp 123 456)) + + (pass-if (eqv? 0.0 (exp -inf.0))) + (pass-if (eqv-loosely? 1.0 (exp 0))) + (pass-if (eqv-loosely? 1.0 (exp 0.0))) + (pass-if (eqv-loosely? const-e (exp 1.0))) + (pass-if (eqv-loosely? const-e^2 (exp 2.0))) + (pass-if (eqv-loosely? const-1/e (exp -1))) + + (pass-if "exp(pi*i) = -1" + (eqv-loosely? -1.0 (exp 0+3.14159i))) + (pass-if "exp(-pi*i) = -1" + (eqv-loosely? -1.0 (exp 0-3.14159i))) + (pass-if "exp(2*pi*i) = +1" + (eqv-loosely? 1.0 (exp 0+6.28318i))) + + (pass-if "exp(2-pi*i) = -e^2" + (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i)))) + ;;; ;;; odd? ;;; @@ -2930,6 +2986,62 @@ (pass-if n (= i (integer-length n)))))) +;;; +;;; log +;;; + +(with-test-prefix "log" + (pass-if "documented?" + (documented? log)) + + (pass-if-exception "no args" exception:wrong-num-args + (log)) + (pass-if-exception "two args" exception:wrong-num-args + (log 123 456)) + + (pass-if (negative-infinity? (log 0))) + (pass-if (negative-infinity? (log 0.0))) + (pass-if (eqv? 0.0 (log 1))) + (pass-if (eqv? 0.0 (log 1.0))) + (pass-if (eqv-loosely? 1.0 (log const-e))) + (pass-if (eqv-loosely? 2.0 (log const-e^2))) + (pass-if (eqv-loosely? -1.0 (log const-1/e))) + + (pass-if (eqv-loosely? 1.0+1.57079i (log 0+2.71828i))) + (pass-if (eqv-loosely? 1.0-1.57079i (log 0-2.71828i))) + + (pass-if (eqv-loosely? 0.0+3.14159i (log -1.0))) + (pass-if (eqv-loosely? 1.0+3.14159i (log -2.71828))) + (pass-if (eqv-loosely? 2.0+3.14159i (log (* -2.71828 2.71828))))) + +;;; +;;; log10 +;;; + +(with-test-prefix "log10" + (pass-if "documented?" + (documented? log10)) + + (pass-if-exception "no args" exception:wrong-num-args + (log10)) + (pass-if-exception "two args" exception:wrong-num-args + (log10 123 456)) + + (pass-if (negative-infinity? (log10 0))) + (pass-if (negative-infinity? (log10 0.0))) + (pass-if (eqv? 0.0 (log10 1))) + (pass-if (eqv? 0.0 (log10 1.0))) + (pass-if (eqv-loosely? 1.0 (log10 10.0))) + (pass-if (eqv-loosely? 2.0 (log10 100.0))) + (pass-if (eqv-loosely? -1.0 (log10 0.1))) + + (pass-if (eqv-loosely? 1.0+0.68218i (log10 0+10.0i))) + (pass-if (eqv-loosely? 1.0-0.68218i (log10 0-10.0i))) + + (pass-if (eqv-loosely? 0.0+1.36437i (log10 -1))) + (pass-if (eqv-loosely? 1.0+1.36437i (log10 -10))) + (pass-if (eqv-loosely? 2.0+1.36437i (log10 -100)))) + ;;; ;;; logbit? ;;; @@ -3035,3 +3147,36 @@ (lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))) (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF (lognot #x-100000000000000000000000000000000)))) + +;;; +;;; sqrt +;;; + +(with-test-prefix "sqrt" + (pass-if "documented?" + (documented? sqrt)) + + (pass-if-exception "no args" exception:wrong-num-args + (sqrt)) + (pass-if-exception "two args" exception:wrong-num-args + (sqrt 123 456)) + + (pass-if (eqv? 0.0 (sqrt 0))) + (pass-if (eqv? 0.0 (sqrt 0.0))) + (pass-if (eqv? 1.0 (sqrt 1.0))) + (pass-if (eqv-loosely? 2.0 (sqrt 4.0))) + (pass-if (eqv-loosely? 31.62 (sqrt 1000.0))) + + (pass-if (eqv? +1.0i (sqrt -1.0))) + (pass-if (eqv-loosely? +2.0i (sqrt -4.0))) + (pass-if (eqv-loosely? +31.62i (sqrt -1000.0))) + + (pass-if "+i swings back to 45deg angle" + (eqv-loosely? +0.7071+0.7071i (sqrt +1.0i))) + + ;; Note: glibc 2.3 csqrt() had a bug affecting this test case, so if it + ;; fails check whether that's the cause (there's a configure test to + ;; reject it, but when cross-compiling we assume the C library is ok). + (pass-if "-100i swings back to 45deg down" + (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) + diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 19d3edc49..1dd2bc78e 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -82,9 +82,10 @@ (port (with-error-to-port (cdr pair) (lambda () (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; sleep 999"))))) - (read-char (car pair)) ;; wait for child to do its thing - (and (char-ready? port) + "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) + (close-port (cdr pair)) ;; write side + (and (char? (read-char (car pair))) ;; wait for child to do its thing + (char-ready? port) (eof-object? (read-char port)))))) ;; @@ -131,15 +132,16 @@ (port (with-error-to-port (cdr pair) (lambda () (open-output-pipe - "exec 0&2; sleep 999"))))) - (read-char (car pair)) ;; wait for child to do its thing - (catch 'system-error + "exec 0&2; exec 2>/dev/null; sleep 999"))))) + (close-port (cdr pair)) ;; write side + (and (char? (read-char (car pair))) ;; wait for child to do its thing + (catch 'system-error (lambda () (write-char #\x port) (force-output port) #f) (lambda (key name fmt args errno-list) - (= (car errno-list) EPIPE)))))))) + (= (car errno-list) EPIPE))))))))) ;; ;; close-pipe diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index b738dc9f2..9690122b5 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -538,20 +538,73 @@ (while (not (eof-object? (read-char port)))) (= 8 (port-column port)))))) +;;; +;;; seek +;;; + +(with-test-prefix "seek" + + (with-test-prefix "file port" + + (pass-if "SEEK_CUR" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 2 SEEK_CUR) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_SET" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 3 SEEK_SET) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_END" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port -2 SEEK_END) + (eqv? #\d (read-char port)))))) + ;;; ;;; truncate-file ;;; (with-test-prefix "truncate-file" + (pass-if-exception "flonum file" exception:wrong-type-arg + (truncate-file 1.0 123)) + + (pass-if-exception "frac file" exception:wrong-type-arg + (truncate-file 7/3 123)) + (with-test-prefix "filename" + (pass-if-exception "flonum length" exception:wrong-type-arg + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file) 1.0)) + (pass-if "shorten" (call-with-output-file (test-file) (lambda (port) (display "hello" port))) (truncate-file (test-file) 1) - (eqv? 1 (stat:size (stat (test-file)))))) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if-exception "shorten to current pos" exception:miscellaneous-error + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file)))) (with-test-prefix "file descriptor" @@ -562,6 +615,16 @@ (let ((fd (open-fdes (test-file) O_RDWR))) (truncate-file fd 1) (close-fdes fd)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((fd (open-fdes (test-file) O_RDWR))) + (seek fd 1 SEEK_SET) + (truncate-file fd) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file)))))) (with-test-prefix "file port" @@ -572,6 +635,15 @@ (display "hello" port))) (let ((port (open-file (test-file) "r+"))) (truncate-file port 1)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((port (open-file (test-file) "r+"))) + (read-char port) + (truncate-file port)) (eqv? 1 (stat:size (stat (test-file))))))) diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index dd91f35b6..7663b56b7 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -20,6 +20,27 @@ #:use-module (test-suite lib)) + +;;; +;;; htonl +;;; + +(with-test-prefix "htonl" + + (pass-if "0" (eqv? 0 (htonl 0))) + + (pass-if-exception "-1" exception:out-of-range + (htonl -1)) + + ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect + ;; an overflow for values 2^32 <= x < 2^63 + (pass-if-exception "2^32" exception:out-of-range + (htonl (ash 1 32))) + + (pass-if-exception "2^1024" exception:out-of-range + (htonl (ash 1 1024)))) + + ;;; ;;; inet-ntop ;;; @@ -110,6 +131,25 @@ (and (= (sockaddr:fam sa) AF_UNIX) (string=? (sockaddr:path sa) "/tmp/unix-socket")))))) +;;; +;;; ntohl +;;; + +(with-test-prefix "ntohl" + + (pass-if "0" (eqv? 0 (ntohl 0))) + + (pass-if-exception "-1" exception:out-of-range + (ntohl -1)) + + ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect + ;; an overflow for values 2^32 <= x < 2^63 + (pass-if-exception "2^32" exception:out-of-range + (ntohl (ash 1 32))) + + (pass-if-exception "2^1024" exception:out-of-range + (ntohl (ash 1 1024)))) + ;;; diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index dd55c1335..22c4a9a68 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -17,8 +17,10 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-1) - (test-suite lib)) +(define-module (test-srfi-1) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + (define (ref-delete x lst . proc) "Reference implemenation of srfi-1 `delete'." diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 9a6f8e31a..18fa19328 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -18,25 +18,69 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-9)) +(define-module (test-suite test-numbers) + #:use-module (test-suite lib) + #:use-module (srfi srfi-9)) + + +(define exception:not-a-record + (cons 'misc-error "^not-a-record")) + (define-record-type :foo (make-foo x) foo? (x get-x) (y get-y set-y!)) +(define-record-type :bar (make-bar i j) bar? + (i get-i) (i get-j set-j!)) + (define f (make-foo 1)) (set-y! f 2) -(with-test-prefix "record procedures" +(define b (make-bar 123 456)) - (pass-if "predicate" +(with-test-prefix "constructor" + + (pass-if-exception "foo 0 args" exception:wrong-num-args + (make-foo)) + (pass-if-exception "foo 2 args" exception:wrong-num-args + (make-foo 1 2))) + +(with-test-prefix "predicate" + + (pass-if "pass" (foo? f)) + (pass-if "fail wrong record type" + (eq? #f (foo? b))) + (pass-if "fail number" + (eq? #f (foo? 123)))) - (pass-if "accessor 1" +(with-test-prefix "accessor" + + (pass-if "get-x" (= 1 (get-x f))) - - (pass-if "accessor 2" + (pass-if "get-y" (= 2 (get-y f))) - (pass-if "modifier" + (pass-if-exception "get-x on number" exception:not-a-record + (get-x 999)) + (pass-if-exception "get-y on number" exception:not-a-record + (get-y 999)) + + ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced + (pass-if-exception "get-x on bar" exception:wrong-type-arg + (get-x b)) + (pass-if-exception "get-y on bar" exception:wrong-type-arg + (get-y b))) + +(with-test-prefix "modifier" + + (pass-if "set-y!" (set-y! f #t) - (eq? #t (get-y f)))) + (eq? #t (get-y f))) + + (pass-if-exception "set-y! on number" exception:not-a-record + (set-y! 999 #t)) + + ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced + (pass-if-exception "set-y! on bar" exception:wrong-type-arg + (set-y! b 99))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index 3cbbb15f8..e228dfb09 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -32,15 +32,9 @@ (pass-if (list "in another thread after error" t) (or (provided? 'threads) (throw 'unsupported)) - ;; actually this test is perfectly good, but the "internal - ;; define - missing body expression" in syntax.test somehow - ;; ends up leaving SCM_DEFER_INTS, making the test here hang - ;; - (throw 'unresolved) - (alarm 5) (false-if-exception (gmtime t)) - (thread-join (begin-thread (catch 'out-of-range + (join-thread (begin-thread (catch 'out-of-range (lambda () (gmtime t)) (lambda args #f)))) (alarm 0) @@ -73,31 +67,187 @@ elapsed (* 2 internal-time-units-per-second)))))) +;;; +;;; localtime +;;; + +(with-test-prefix "localtime" + + ;; gmtoff is calculated with some explicit code, try to exercise that + ;; here, looking at cases where the localtime and gmtime are within the same + ;; day, or crossing midnight, or crossing new year + + (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 10) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing forward over day boundary + (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "AST-10"))) + (eqv? (* -10 3600) (tm:gmtoff tm))))) + + ;; crossing forward over year boundary + (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 1) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 31) + (set-tm:mon tm 11) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "AST-10"))) + (eqv? (* -10 3600) (tm:gmtoff tm)))))) + +;;; +;;; mktime +;;; + +(with-test-prefix "mktime" + + ;; gmtoff is calculated with some explicit code, try to exercise that + ;; here, looking at cases where the mktime and gmtime are within the same + ;; day, or crossing midnight, or crossing new year + + (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 10) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing forward over day boundary + (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "AST-10")))) + (eqv? (* -10 3600) (tm:gmtoff tm))))) + + ;; crossing forward over year boundary + (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 31) + (set-tm:mon tm 11) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 1) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "AST-10")))) + (eqv? (* -10 3600) (tm:gmtoff tm)))))) + ;;; ;;; strftime ;;; -;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX. -;; If localtime is in daylight savings then it will decide there's no -;; daylight savings zone name for the fake ZOW, and come back empty. -;; -;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone -;; field in struct tm passed by guile. That behaviour is reasonable enough -;; since that field is not in C99 so a C99 program won't know it has to be -;; set. For the details on that see -;; -;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722 -;; -;; Not sure what to do about this in guile, it'd be nice for %Z to look at -;; tm:zone everywhere. -;; -;; -;; (pass-if "strftime %Z doesn't return garbage" -;; (let ((t (localtime (current-time)))) -;; (set-tm:zone t "ZOW") -;; (set-tm:isdst t 0) -;; (string=? (strftime "%Z" t) -;; "ZOW"))) +(with-test-prefix "strftime" + + ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX. + ;; If localtime is in daylight savings then it will decide there's no + ;; daylight savings zone name for the fake ZOW, and come back empty. + ;; + ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone + ;; field in struct tm passed by guile. That behaviour is reasonable + ;; enough since that field is not in C99 so a C99 program won't know it + ;; has to be set. For the details on that see + ;; + ;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722 + ;; + ;; Not sure what to do about this in guile, it'd be nice for %Z to look at + ;; tm:zone everywhere. + ;; + ;; + ;; (pass-if "strftime %Z doesn't return garbage" + ;; (let ((t (localtime (current-time)))) + ;; (set-tm:zone t "ZOW") + ;; (set-tm:isdst t 0) + ;; (string=? (strftime "%Z" t) + ;; "ZOW"))) + + (with-test-prefix "C99 %z format" + + ;; C99 spec is empty string if no zone determinable + ;; + ;; on pre-C99 systems not sure what to expect if %z unsupported, probably + ;; "%z" unchanged in C99 if timezone + ;; + (define have-strftime-%z + (not (member (strftime "%z" (gmtime 0)) + '("" "%z")))) + + ;; %z here is quite possibly affected by the same tm:gmtoff vs current + ;; zone as %Z above is, so in the following tests we make them the same. + + (pass-if "GMT" + (or have-strftime-%z (throw 'unsupported)) + (putenv "TZ=GMT+0") + (tzset) + (let ((tm (localtime 86400))) + (string=? "+0000" (strftime "%z" tm)))) + + ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500", + ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus + ;; tm_gmtoff being east of Greenwich + (pass-if "EST+5" + (or have-strftime-%z (throw 'unsupported)) + (putenv "TZ=EST+5") + (tzset) + (let ((tm (localtime 86400))) + (string=? "-0500" (strftime "%z" tm)))))) ;;; ;;; strptime @@ -109,15 +259,31 @@ (or (defined? 'strptime) (throw 'unsupported)) (or (provided? 'threads) (throw 'unsupported)) - ;; actually this test is perfectly good, but the "internal define - - ;; missing body expression" in syntax.test somehow ends up leaving - ;; SCM_DEFER_INTS, making the test here hang - ;; - (throw 'unresolved) - (alarm 5) (false-if-exception (strptime "%a" "nosuchday")) - (thread-join (begin-thread (strptime "%d" "1"))) + (join-thread (begin-thread (strptime "%d" "1"))) (alarm 0) - #t)) + #t) + + (with-test-prefix "GNU %s format" + + ;; "%s" to parse a count of seconds since 1970 is a GNU extension + (define have-strptime-%s + (false-if-exception (strptime "%s" "0"))) + + (pass-if "gmtoff on GMT" + (or have-strptime-%s (throw 'unsupported)) + (putenv "TZ=GMT+0") + (tzset) + (let ((tm (car (strptime "%s" "86400")))) + (eqv? 0 (tm:gmtoff tm)))) + + ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from + ;; strptime + (pass-if "gmtoff on EST+5" + (or have-strptime-%s (throw 'unsupported)) + (putenv "TZ=EST+5") + (tzset) + (let ((tm (car (strptime "%s" "86400")))) + (eqv? (* 5 3600) (tm:gmtoff tm)))))) From bdb55624ca1fb984aa6b74ac6bdc384186a60e37 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 10 Oct 2006 00:11:22 +0000 Subject: [PATCH 054/116] stray tab --- ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 0aef5db3f..aad1690bd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -29,7 +29,7 @@ * NEWS: Mentioned the interaction between `setlocale' and SRFI-14 standard char sets. - + 2006-08-22 Kevin Ryde * configure.in: Test if need braces around PTHREAD_ONCE_INIT, set From c1ab3a6d6b490c73740419326b4e2b35f64cc0a3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 10 Oct 2006 21:52:40 +0000 Subject: [PATCH 055/116] (Setting and Managing Breakpoints): New text about what happens when a breakpoint is created. (Listing and Deleting Breakpoints, Moving and Losing Breakpoints): New. --- doc/ref/ChangeLog | 7 ++++ doc/ref/scheme-using.texi | 70 +++++++++++++++++++++++++++------------ 2 files changed, 56 insertions(+), 21 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 91a776004..bb9c18312 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2006-10-10 Neil Jerram + + * scheme-using.texi (Setting and Managing Breakpoints): New text + about what happens when a breakpoint is created. + (Listing and Deleting Breakpoints, Moving and Losing Breakpoints): + New. + 2006-10-08 Neil Jerram * scheme-using.texi (Working with GDS in Scheme Buffers): New diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 445c8f32d..93d0949f8 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -827,6 +827,8 @@ GDS provides for working on code in @code{scheme-mode} buffers. @menu * Access to Guile Help and Completion:: * Setting and Managing Breakpoints:: +* Listing and Deleting Breakpoints:: +* Moving and Losing Breakpoints:: * Evaluating Scheme Code:: @end menu @@ -902,29 +904,55 @@ default by using the alternative key sequences @kbd{C-c C-b d} (for @code{debug}), @kbd{C-c C-b t} (for @code{trace}) and @kbd{C-c C-b T} (for @code{trace-subtree}). -When you create a breakpoint like this, two things happen. Firstly, -if the current buffer is associated with a Guile client program, the -new breakpoint definition is immediately sent to that client (or, if -the client cannot accept input immediately, it is held in readiness to -pass to the client at the next possible opportunity). This allows the -new breakpoint to take effect as soon as possible in the relevant -client program. +GDS keeps all the breakpoints that you create in a single list, and +tries to set them in every Guile program that connects to GDS and calls +@code{set-gds-breakpoints}. That may sound surprising, because you are +probably thinking of one particular program when you create a +breakpoint; but GDS assumes that you would want the breakpoint to continue +taking effect if you stop and restart that program, and this is +currently achieved by giving all breakpoints to every program that asks +for them. In practice it doesn't matter if a program gets a breakpoint +definition --- such as ``break in procedure @code{foo}'' --- that it +can't actually map to any of its code. -Secondly, it is added to GDS's @emph{global} list of all breakpoints. -This list holds the breakpoint information that will be given to any -client program that asks for it by calling @code{set-gds-breakpoints}. -The fact that this list is global, rather than client-specific, means -that the breakpoints you have set will automatically be recreated if the -program you are debugging has to be stopped and restarted.@footnote{An -important point here is that there is nothing that unambiguously relates -two subsequent runs of the same client program, which might allow GDS to -pass on breakpoint settings more precisely.} +If there are already Guile programs connected to GDS when you create a +new breakpoint, GDS also tries to set the new breakpoint in each of +those programs at the earliest opportunity, which is usually when they +decide to stop and talk to GDS for some other reason. -(The only possible downside of this last point is that if you are -debugging two programs in parallel, which have some code in common, -you might not want a common code breakpoint in one program to be set -in the other program as well. But this feels like a small concern in -comparison to the benefit of breakpoints persisting as just described.) + +@node Listing and Deleting Breakpoints +@subsubsection Listing and Deleting Breakpoints + +To see a list of all breakpoints, type @kbd{C-c C-b ?} (or @kbd{M-x +gds-describe-breakpoints}). GDS will then pop up a buffer that +describes each breakpoint and reports whether it is actually set in each +of the Guile programs connected to GDS. + +To delete a breakpoint, type @kbd{C-c C-b @key{backspace}}. If the +region is active when you do this, GDS will delete all of the +breakpoints in the region. If the region is not active, GDS tries to +delete a ``break-in'' breakpoint for the procedure whose definition +contains point (the Emacs cursor). In either case, deletion means that +the breakpoint is removed both from GDS's global list and from all of +the connected Guile programs that had previously managed to set it. + + +@node Moving and Losing Breakpoints +@subsubsection Moving and Losing Breakpoints + +Imagine that you set a breakpoint at line 80 of a Scheme code file, and +execute some code that hits this breakpoint; then you add some new code +at line 40, or delete some code that is no longer needed, and save the +file. Now the breakpoint will have moved up or down from line 80, and +any attached Guile program needs to be told about the new line number. +Otherwise, when a program loads this file again, it will try incorrectly +to set a breakpoint on whatever code is now at line 80, and will +@emph{not} set a breakpoint on the code where you want it. + +For this reason, GDS checks all breakpoint positions whenever you save a +Scheme file, and sends the new position to connected Guile programs for +any breakpoints that have moved. @dots{} [to be continued] @node Evaluating Scheme Code From e2d23cc0f8ef473a8248b86d8928c70d3cb92873 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 12 Oct 2006 23:24:02 +0000 Subject: [PATCH 056/116] * gds.el (gds-run-debug-server): Use variable gds-server-port-or-path instead of hardcoded 8333. (gds-server-port-or-path): New. * gds-server.el (gds-start-server): Change port arg to port-or-path, to support Unix domain sockets. * gds-client.scm (connect-to-gds): Try to connect by Unix domain socket if TCP connection fails. * gds-server.scm (run-server): Update to support listening on a Unix domain socket. --- THANKS | 1 + emacs/ChangeLog | 9 +++++++++ emacs/gds-server.el | 17 +++++++++-------- emacs/gds.el | 9 ++++++++- ice-9/ChangeLog | 10 ++++++++++ ice-9/gds-client.scm | 22 ++++++++++++++++------ ice-9/gds-server.scm | 24 ++++++++++++++++++++---- 7 files changed, 73 insertions(+), 19 deletions(-) diff --git a/THANKS b/THANKS index 59eaf13f9..6c805fe31 100644 --- a/THANKS +++ b/THANKS @@ -79,3 +79,4 @@ For fixes or providing information which led to a fix: Michael Tuexen Andy Wingo Keith Wright + William Xu diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 6786c2844..0303fb064 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,12 @@ +2006-10-13 Neil Jerram + + * gds.el (gds-run-debug-server): Use variable + gds-server-port-or-path instead of hardcoded 8333. + (gds-server-port-or-path): New. + + * gds-server.el (gds-start-server): Change port arg to + port-or-path, to support Unix domain sockets. + 2006-08-18 Neil Jerram * gds-server.el (gds-start-server): Change "ossau" to "ice-9". diff --git a/emacs/gds-server.el b/emacs/gds-server.el index 722e613db..86defc07b 100644 --- a/emacs/gds-server.el +++ b/emacs/gds-server.el @@ -44,24 +44,25 @@ :group 'gds :type '(choice (const :tag "nil" nil) directory)) -(defun gds-start-server (procname port protocol-handler &optional bufname) - "Start a GDS server process called PROCNAME, listening on TCP port PORT. -PROTOCOL-HANDLER should be a function that accepts and processes one -protocol form. Optional arg BUFNAME specifies the name of the buffer -that is used for process output\; if not specified the buffer name is -the same as the process name." +(defun gds-start-server (procname port-or-path protocol-handler &optional bufname) + "Start a GDS server process called PROCNAME, listening on TCP port +or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a +function that accepts and processes one protocol form. Optional arg +BUFNAME specifies the name of the buffer that is used for process +output; if not specified the buffer name is the same as the process +name." (with-current-buffer (get-buffer-create (or bufname procname)) (erase-buffer) (let* ((code (format "(begin %s (use-modules (ice-9 gds-server)) - (run-server %d))" + (run-server %S))" (if gds-scheme-directory (concat "(set! %load-path (cons " (format "%S" gds-scheme-directory) " %load-path))") "") - port)) + port-or-path)) (process-connection-type nil) ; use a pipe (proc (start-process procname (current-buffer) diff --git a/emacs/gds.el b/emacs/gds.el index 3ce4696b6..132b571a2 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -42,7 +42,9 @@ (interactive) (if gds-debug-server (gds-kill-debug-server)) (setq gds-debug-server - (gds-start-server "gds-debug" 8333 'gds-debug-protocol)) + (gds-start-server "gds-debug" + gds-server-port-or-path + 'gds-debug-protocol)) (process-kill-without-query gds-debug-server)) (defun gds-kill-debug-server () @@ -602,6 +604,11 @@ you would add an element to this alist to transform :type 'boolean :group 'gds) +(defcustom gds-server-port-or-path 8333 + "TCP port number or Unix domain socket path for the server to listen on." + :group 'gds + :type '(choice (integer :tag "TCP port number") + (file :tag "Unix domain socket path"))) ;;;; If requested, autostart the server after loading. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 1b903da23..e241afed8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2006-10-13 Neil Jerram + + Integration of Unix domain socket patch from William Xu: + + * gds-client.scm (connect-to-gds): Try to connect by Unix domain + socket if TCP connection fails. + + * gds-server.scm (run-server): Update to support listening on a + Unix domain socket. + 2006-10-05 Kevin Ryde * ftw.scm (visited?-proc): Use hashv since we know we're getting diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index 26e76855e..8c7bdc742 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -174,12 +174,22 @@ (or gds-port (begin (set! gds-port - (let ((s (socket PF_INET SOCK_STREAM 0)) - (SOL_TCP 6) - (TCP_NODELAY 1)) - (setsockopt s SOL_TCP TCP_NODELAY 1) - (connect s AF_INET (inet-aton "127.0.0.1") 8333) - s)) + (or (let ((s (socket PF_INET SOCK_STREAM 0)) + (SOL_TCP 6) + (TCP_NODELAY 1)) + (setsockopt s SOL_TCP TCP_NODELAY 1) + (catch #t + (lambda () + (connect s AF_INET (inet-aton "127.0.0.1") 8333) + s) + (lambda _ #f))) + (let ((s (socket PF_UNIX SOCK_STREAM 0))) + (catch #t + (lambda () + (connect s AF_UNIX "/tmp/.gds_socket") + s) + (lambda _ #f))) + (error "Couldn't connect to GDS by TCP or Unix domain socket"))) (write-form (list 'name (getpid) (format #f "PID ~A" (getpid))))))) (if (not (defined? 'make-mutex)) diff --git a/ice-9/gds-server.scm b/ice-9/gds-server.scm index a8e9c99c8..f59758729 100644 --- a/ice-9/gds-server.scm +++ b/ice-9/gds-server.scm @@ -36,13 +36,29 @@ (define connection->id (make-object-property)) -(define (run-server port) +(define (run-server port-or-path) - (let ((server (socket PF_INET SOCK_STREAM 0))) + (or (integer? port-or-path) + (string? port-or-path) + (error "port-or-path should be an integer (port number) or a string (file name)" + port-or-path)) + + (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX) + SOCK_STREAM + 0))) ;; Initialize server socket. - (setsockopt server SOL_SOCKET SO_REUSEADDR 1) - (bind server AF_INET INADDR_ANY port) + (if (integer? port-or-path) + (begin + (setsockopt server SOL_SOCKET SO_REUSEADDR 1) + (bind server AF_INET INADDR_ANY port-or-path)) + (begin + (catch #t + (lambda () (delete-file port-or-path)) + (lambda _ #f)) + (bind server AF_UNIX port-or-path))) + + ;; Start listening. (listen server 5) (let loop ((clients '()) (readable-sockets '())) From ba6984d09bdc2298eb331f8ddedab3844e777e39 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 14 Oct 2006 16:34:16 +0000 Subject: [PATCH 057/116] (gds-socket-type-alist): New. (gds-run-debug-server): Use gds-server-socket-type and gds-socket-type-alist instead of gds-server-port-or-path. (gds-server-socket-type): New, replacing gds-server-port-or-path. --- emacs/ChangeLog | 7 +++++++ emacs/gds.el | 16 +++++++++++----- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 0303fb064..710f80e45 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,10 @@ +2006-10-14 Neil Jerram + + * gds.el (gds-socket-type-alist): New. + (gds-run-debug-server): Use gds-server-socket-type and + gds-socket-type-alist instead of gds-server-port-or-path. + (gds-server-socket-type): New, replacing gds-server-port-or-path. + 2006-10-13 Neil Jerram * gds.el (gds-run-debug-server): Use variable diff --git a/emacs/gds.el b/emacs/gds.el index 132b571a2..71d9a99d4 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -37,13 +37,19 @@ ;; The subprocess object for the debug server. (defvar gds-debug-server nil) +(defvar gds-socket-type-alist '((tcp . 8333) + (unix . "/tmp/.gds_socket")) + "Maps each of the possible socket types that the GDS server can +listen on to the path that it should bind to for each one.") + (defun gds-run-debug-server () "Start (or restart, if already running) the GDS debug server process." (interactive) (if gds-debug-server (gds-kill-debug-server)) (setq gds-debug-server (gds-start-server "gds-debug" - gds-server-port-or-path + (cdr (assq gds-server-socket-type + gds-socket-type-alist)) 'gds-debug-protocol)) (process-kill-without-query gds-debug-server)) @@ -604,11 +610,11 @@ you would add an element to this alist to transform :type 'boolean :group 'gds) -(defcustom gds-server-port-or-path 8333 - "TCP port number or Unix domain socket path for the server to listen on." +(defcustom gds-server-socket-type 'tcp + "What kind of socket the GDS server should listen on." :group 'gds - :type '(choice (integer :tag "TCP port number") - (file :tag "Unix domain socket path"))) + :type '(choice (const :tag "TCP" tcp) + (const :tag "Unix" unix))) ;;;; If requested, autostart the server after loading. From 9a5fa6e98a0078e6f3e47dd72d1545877ea862f7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 25 Oct 2006 22:37:24 +0000 Subject: [PATCH 058/116] * configure.in: New check for uca lib (needed for IA64 on HP-UX). * threads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base() instead of Linux-specific implementations. * gc.h (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New declarations. * gc.c (__libc_ia64_register_backing_store_base): Declaration removed. (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New, with implementations for Linux and HP-UX. * coop-pthreads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base() instead of Linux-specific implementations. * continuations.h (__libc_ia64_register_backing_store_base): Declaration removed. (scm_t_contregs): New "fresh" field. * continuations.c (ia64_getcontext): Removed. (scm_make_continuation): Use continuation fresh field instead of interpreting getcontext return values (which isn't portable). Use scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base() instead of Linux-specific implementations. (copy_stack_and_call): Use scm_ia64_register_backing_store_base() instead of Linux-specific implementation. * _scm.h (__ia64__): Also detect __ia64. --- ChangeLog | 16 ++++-- configure.in | 2 + libguile/ChangeLog | 110 +++++++++++++++++++++++++-------------- libguile/_scm.h | 3 ++ libguile/continuations.c | 36 ++++--------- libguile/continuations.h | 2 +- libguile/coop-pthreads.c | 5 +- libguile/gc.c | 43 +++++++++++++-- libguile/gc.h | 5 ++ libguile/threads.c | 4 +- 10 files changed, 147 insertions(+), 79 deletions(-) diff --git a/ChangeLog b/ChangeLog index aad1690bd..637b8fcd2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2006-10-25 Neil Jerram + + IA64 HP-UX patch from Hrvoje Nikšić. (Thanks!) + + * configure.in: New check for uca lib (needed for IA64 on HP-UX). + 2006-10-06 Rob Browning Guile 1.8.1 released. @@ -23,7 +29,7 @@ * configure.in (complex.h, complex double, csqrt): New tests. -2006-09-20 Ludovic Courts +2006-09-20 Ludovic Courtès * configure.in: Check for `isblank ()'. @@ -57,7 +63,7 @@ * configure.in (AC_CHECK_MEMBERS): Test struct tm.tm_gmtoff. -2006-06-13 Ludovic Courts +2006-06-13 Ludovic Courtès * NEWS: Mentioned the new behavior of `equal?' for structures. @@ -260,7 +266,7 @@ * acinclude.m4 (ACX_PTHREAD): New. * configure.in: Use it instead of simply looking for -lpthread. - Thanks to Andreas Vgele! + Thanks to Andreas Vögele! 2004-09-08 Marius Vollmer @@ -313,7 +319,7 @@ 2004-07-09 Marius Vollmer * configure.in: Bugfix: set SCM_I_GSC_T_UINTMAX, not - SCM_I_GSC_T_INTMAX in two places. Thanks to Andreas Vgele! + SCM_I_GSC_T_INTMAX in two places. Thanks to Andreas Vögele! 2004-07-07 Marius Vollmer @@ -2032,7 +2038,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros 1999-07-19 Jim Blandy - Fixes for EMX from Mikael Stldal. + Fixes for EMX from Mikael Ståldal. * configure.in: Check for . * configure: Regenerated. diff --git a/configure.in b/configure.in index 9578cdfc8..e63c0a749 100644 --- a/configure.in +++ b/configure.in @@ -212,6 +212,7 @@ if test "$enable_elisp" = yes; then else SCM_I_GSC_ENABLE_ELISP=0 fi +AC_CHECK_LIB(uca, __uc_get_ar_bsp) AC_C_CONST @@ -221,6 +222,7 @@ if test "$ac_cv_c_inline" != no; then else SCM_I_GSC_C_INLINE=NULL fi +AC_CHECK_LIB(uca, __uc_get_ar_bsp) AC_C_BIGENDIAN diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 01a17aa77..6d3a2db1d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,37 @@ +2006-10-25 Neil Jerram + + IA64 HP-UX GC patch from Hrvoje Nikšić. (Thanks!) + + * threads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and + scm_ia64_register_backing_store_base() instead of Linux-specific + implementations. + + * gc.h (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): + New declarations. + + * gc.c (__libc_ia64_register_backing_store_base): Declaration + removed. + (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New, with + implementations for Linux and HP-UX. + + * coop-pthreads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() + and scm_ia64_register_backing_store_base() instead of + Linux-specific implementations. + + * continuations.h (__libc_ia64_register_backing_store_base): + Declaration removed. + (scm_t_contregs): New "fresh" field. + + * continuations.c (ia64_getcontext): Removed. + (scm_make_continuation): Use continuation fresh field instead of + interpreting getcontext return values (which isn't portable). Use + scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base() + instead of Linux-specific implementations. + (copy_stack_and_call): Use scm_ia64_register_backing_store_base() + instead of Linux-specific implementation. + + * _scm.h (__ia64__): Also detect __ia64. + 2006-10-03 Kevin Ryde * eval.c (SCM_APPLY): For scm_tc7_subr_2o, throw wrong-num-args on 0 @@ -45,7 +79,7 @@ * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New functions. -2006-09-20 Ludovic Courts +2006-09-20 Ludovic Courtès * srfi-14.c: Include . Define `_GNU_SOURCE'. (make_predset, define_predset, make_strset, define_strset, false, @@ -132,7 +166,7 @@ arrangements and avoid an illegal instruction during call-with-current-continuation. -2006-07-12 Ludovic Courts +2006-07-12 Ludovic Courtès * numbers.c (guile_ieee_init): Use regular ANSI C casts rather than C++-style `X_CAST ()'. Patch posted by by Mike Gran. @@ -156,7 +190,7 @@ (scm_strptime): Use tm_gmtoff from the strptime result when that field exists, it's set by glibc strptime "%s". -2006-06-13 Ludovic Courts +2006-06-13 Ludovic Courtès * eq.c: Include "struct.h", "goops.h" and "objects.h". (scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that @@ -294,7 +328,7 @@ 2006-04-06 Kevin Ryde * fports.c (scm_setvbuf): Fix for not _IOLBF, clear SCM_BUFLINE - instead of toggling it. Reported by Ludovic Courts. + instead of toggling it. Reported by Ludovic Courtès. 2006-03-26 Marius Vollmer @@ -306,7 +340,7 @@ * gc_os_dep.c (scm_get_stack_base): Abort when the machine type is unknown instead of returning NULL. -2006-03-21 Ludovic Courts +2006-03-21 Ludovic Courtès * numbers.c (scm_i_mem2number): Renamed to scm_c_locale_stringn_to_number. @@ -398,7 +432,7 @@ (scm_i_sweep_statistics_init): New macro. (scm_i_sweep_statistics_sum): New macro -2006-02-14 Ludovic Courts +2006-02-14 Ludovic Courtès * strings.c (scm_i_take_stringbufn): Register LEN+1 bytes instead of LEN. Without this, too much collectable memory gets unregistered, @@ -516,7 +550,7 @@ * inline.h, pairs.c (scm_is_pair): Moved scm_is_pair from pairs.c to inline.h to make it inline. -2005-12-19 Ludovic Courts +2005-12-19 Ludovic Courtès * strings.c (scm_i_take_stringbufn): New. (scm_i_c_take_symbol): New. @@ -549,7 +583,7 @@ 2005-12-29 Neil Jerram - * fluids.c (next_fluid_num): [From Ludovic Courts:] Don't trigger + * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger the GC when allocated_fluids_len is zero. 2005-12-14 Neil Jerram @@ -581,7 +615,7 @@ * srfi-4.h, srfi-4.c, srfi-4.i.c (take_uvec): Make BASE pointer non-const. - (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courts! + (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès! * threads.h, threads.c (scm_t_guile_ticket, scm_leave_guile, scm_enter_guile): Removed from public API. See comment at @@ -596,7 +630,7 @@ * eval.c (scm_m_cond): Recognize SRFI 61 cond syntax. (CEVAL): Evaluate SRFI 61 cond clauses. -2005-12-06 Ludovic Courts +2005-12-06 Ludovic Courtès * gc-card.c (scm_i_card_statistics): Return if BITVEC is NULL. This was typically hit when running `gc-live-object-stats' right @@ -610,7 +644,7 @@ 2005-11-26 Kevin Ryde * gc-mark.c (scm_mark_all): Change C++ comment to C comment. Reported - by Ludovic Courts. + by Ludovic Courtès. * list.c (list): Should be "primitive" in SCM_SNARF_DOCS, not "register". @@ -622,7 +656,7 @@ * socket.c (scm_fill_sockaddr): Remove SCM_C_INLINE_KEYWORD, this is much too big to want to inline. -2005-11-17 Ludovic Courts +2005-11-17 Ludovic Courtès * print.c (EXIT_NESTED_DATA): Before popping from the stack, reset the value at its top. This fixes a reference leak. @@ -630,14 +664,14 @@ `PSTATE_STACK_SET ()' in order to avoid undesired potential side effects. -2005-11-12 Ludovic Courts +2005-11-12 Ludovic Courtès * gc.c (scm_weak_vectors): Removed. 2005-11-12 Kevin Ryde * socket.c (scm_setsockopt): Missing @defvar in docstring. Reported - by Ludovic Courts. + by Ludovic Courtès. 2005-11-07 Marius Vollmer @@ -659,7 +693,7 @@ * debug.h (SCM_CHEAPTRAPS_P): Removed. -2005-10-27 Ludovic Courts +2005-10-27 Ludovic Courtès * socket.c (scm_fill_sockaddr): No need to check NULL from scm_malloc. (scm_connect, scm_bind, scm_sendto): Accept sockaddr object. @@ -967,7 +1001,7 @@ 2005-05-11 Neil Jerram - Fix C99isms reported by Ludovic Courts: + Fix C99isms reported by Ludovic Courtès: * threads.c (s_scm_lock_mutex): Don't declare msg in middle of code. @@ -1082,7 +1116,7 @@ 2005-03-18 Kevin Ryde * arbiters.c (FETCH_STORE) [generic C]: Should be - scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courts. + scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès. 2005-03-13 Kevin Ryde @@ -2228,7 +2262,7 @@ 2004-11-02 Marius Vollmer - Mac OS X and OpenBSD compatibility patches from Andreas Vgele. + Mac OS X and OpenBSD compatibility patches from Andreas Vögele. Thanks! * backtrace.c (scm_display_backtrace_with_highlights): Join the @@ -2672,7 +2706,7 @@ * numbers.h, numbers.c: Include in numbers.h, not in numbers.c. (scm_to_mpz, scm_from_mpz): New. - Thanks to Andreas Vgele! + Thanks to Andreas Vögele! * read.c (skip_scsh_block_comment): Recognize "!#" everywhere, not just on a line of its own. @@ -2681,7 +2715,7 @@ scm_string_tabulate, string_upcase_x, string_down_case_x, string_titlecase_x, string_reverse_x, scm_string_tokenize): Use size_t instead of int for indices into strings. Make sure that no - over- or underflow occurs. Thanks to Andreas Vgele! + over- or underflow occurs. Thanks to Andreas Vögele! (scm_xsubstring, scm_string_xcopy_x): Use ints for 'extended' indices, which can also be negative. @@ -2703,7 +2737,7 @@ * filesys.c, stime.c (_POSIX_C_SOURCE): Use this only on hpux, it causes too many problems elsewhere (glibc, freebsd, mingw). Reported - by Andreas Vgele. + by Andreas Vögele. 2004-09-08 Marius Vollmer @@ -3538,7 +3572,7 @@ * gc_os_dep.c: update ifdefery for macosx. (scm_get_stack_base): separate result initialization from declaration to slience warnings with macosx and hp-ux using gcc - 3.3. Thanks to Andreas Vgele. + 3.3. Thanks to Andreas Vögele. 2004-06-13 Han-Wen Nienhuys @@ -3748,10 +3782,10 @@ 2004-05-02 Kevin Ryde * eval.c (scm_macroexp): Add prototype, since it's not in eval.h under - --disable-deprecated. Reported by Andreas Vgele. + --disable-deprecated. Reported by Andreas Vögele. * filesys.c (_POSIX_C_SOURCE): Define to 199506L to get readdir_r (in - particular on HP-UX). Reported by Andreas Vgele. + particular on HP-UX). Reported by Andreas Vögele. * list.c (varargs.h): Remove, leave just stdarg.h which is all the code has support for. Fixes building with AIX cc, which is ansi but @@ -3762,14 +3796,14 @@ 2004-05-01 Kevin Ryde * continuations.c (scm_dynthrow): Use >= instead of SCM_PTR_GE which - is now gone. Reported by Andreas Vgele. + is now gone. Reported by Andreas Vögele. 2004-04-28 Kevin Ryde * backtrace.c (display_frame_expr), numbers.c (XDIGIT2UINT, mem2uinteger, mem2decimal_from_point, mem2ureal): Cast char to int for ctype.h tests, to avoid warnings from gcc on HP-UX about char as array - subscript. Reported by Andreas Vgele. + subscript. Reported by Andreas Vögele. Also cast through unsigned char to avoid passing negatives to those macros if input contains 8-bit values. @@ -3783,17 +3817,17 @@ * numbers.c (scm_bit_extract): Use min instead of MIN. (MIN): Remove, this conflicts with similar macro defined by limits.h - on HP-UX. Reported by Andreas Vgele. + on HP-UX. Reported by Andreas Vögele. * stime.c (_POSIX_C_SOURCE): Define to 199506L to get gmtime_r (in - particular on HP-UX). Reported by Andreas Vgele. + particular on HP-UX). Reported by Andreas Vögele. * threads.c (scm_threads_mark_stacks): Correction sizet -> size_t. - Reported by Andreas Vgele. + Reported by Andreas Vögele. * threads-plugin.h (SCM_MUTEX_MAXSIZE): Increase to 25*sizeof(long), for the benefit of hpux11 where pthread_mutex_t is 88 bytes. Reported - by Andreas Vgele. + by Andreas Vögele. 2004-04-22 Dirk Herrmann @@ -7646,7 +7680,7 @@ 2002-08-26 Marius Vollmer * script.c (scm_compile_shell_switches): Added "2002" to Copyright - years. Thanks to Martin Grabmller! + years. Thanks to Martin Grabmüller! 2002-08-25 Han-Wen Nienhuys @@ -9562,7 +9596,7 @@ * deprecation.c (scm_include_deprecated_features): Simplified. * eval.c (EVALCAR, unmemocopy), eval.h (SCM_XEVALCAR): Use - `SCM_IMP' instead of `!SCM_CELLP. + `SCM_IMP' instead of `!SCM_CELLP´. * eval.c (unmemocopy): Eliminate redundant SCM_CELLP tests. Extract side-effecting operations from macros. @@ -10603,7 +10637,7 @@ 2001-06-09 Marius Vollmer * ports.c (scm_lfwrite): Maintain columnd and row count in port. - Thanks to Matthias Kppe! + Thanks to Matthias Köppe! 2001-06-08 Michael Livshin @@ -10611,7 +10645,7 @@ space-happy C preprocessors. * filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces - inside cookies. thanks to Matthias Kppe! + inside cookies. thanks to Matthias Köppe! 2001-06-08 Dirk Herrmann @@ -11186,7 +11220,7 @@ SCM_VARIABLE_INIT since that it what it used to be. * deprecation.c (scm_include_deprecated_features): Make docstring - ANSIsh. Thanks to Matthias Kppe! + ANSIsh. Thanks to Matthias Köppe! 2001-05-21 Marius Vollmer @@ -11540,7 +11574,7 @@ 2001-05-15 Marius Vollmer * values.c (print_values): Print as a unreadable object, not as - multiple lines. Thanks to Matthias Kppe! + multiple lines. Thanks to Matthias Köppe! 2001-05-14 Dirk Herrmann @@ -11572,7 +11606,7 @@ 2001-05-09 Michael Livshin - from Matthias Kppe (thanks!): + from Matthias Köppe (thanks!): * ports.c (scm_c_read): pointer arithmetic on void pointers isn't portable. @@ -13429,7 +13463,7 @@ 2001-01-11 Michael Livshin - from Matthias Kppe: + from Matthias Köppe: * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER casts its result, so doesn't yield an lvalue per ANSI C. diff --git a/libguile/_scm.h b/libguile/_scm.h index 906de3780..fd05770c2 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -54,6 +54,9 @@ and differences between _scm.h and __scm.h. **********************************************************************/ +#if defined(__ia64) && !defined(__ia64__) +# define __ia64__ +#endif #if HAVE_CONFIG_H # include diff --git a/libguile/continuations.c b/libguile/continuations.c index 5ae89d836..39785a528 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -92,22 +92,6 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) return 1; } -#ifdef __ia64__ -/* Extern declaration of getcontext()/setcontext() in order to redefine - getcontext() since on ia64-linux the second return value indicates whether - it returned from getcontext() itself or by running setcontext(). */ -struct rv -{ - long retval; - long first_return; -}; - -#ifdef __GNUC__ -__attribute__ ((returns_twice)) -#endif /* __GNUC__ */ -extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext"); -#endif /* __ia64__ */ - /* this may return more than once: the first time with the escape procedure, then subsequently with the value to be passed to the continuation. */ @@ -120,9 +104,6 @@ scm_make_continuation (int *first) scm_t_contregs *continuation; long stack_size; SCM_STACKITEM * src; -#ifdef __ia64__ - struct rv rv; -#endif /* __ia64__ */ SCM_FLUSH_REGISTER_WINDOWS; stack_size = scm_stack_size (thread->continuation_base); @@ -144,20 +125,23 @@ scm_make_continuation (int *first) memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); #ifdef __ia64__ - rv = ia64_getcontext (&continuation->ctx); - if (rv.first_return) + continuation->fresh = 1; + getcontext (&continuation->ctx); + if (continuation->fresh) { - continuation->backing_store_size = - continuation->ctx.uc_mcontext.sc_ar_bsp - - (unsigned long) __libc_ia64_register_backing_store_base; + continuation->backing_store_size = + (char *) scm_ia64_ar_bsp(&continuation->ctx) + - + (char *) scm_ia64_register_backing_store_base (); continuation->backing_store = NULL; continuation->backing_store = scm_gc_malloc (continuation->backing_store_size, "continuation backing store"); memcpy (continuation->backing_store, - (void *) __libc_ia64_register_backing_store_base, + (void *) scm_ia64_register_backing_store_base (), continuation->backing_store_size); *first = 1; + continuation->fresh = 0; return cont; } else @@ -252,7 +236,7 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, continuation->throw_value = val; #ifdef __ia64__ - memcpy ((void *) __libc_ia64_register_backing_store_base, + memcpy (scm_ia64_register_backing_store_base (), continuation->backing_store, continuation->backing_store_size); setcontext (&continuation->ctx); diff --git a/libguile/continuations.h b/libguile/continuations.h index d10297956..0274c1b2d 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -27,7 +27,6 @@ #ifdef __ia64__ #include #include -extern unsigned long * __libc_ia64_register_backing_store_base; #endif /* __ia64__ */ @@ -48,6 +47,7 @@ typedef struct SCM dynenv; #ifdef __ia64__ ucontext_t ctx; + int fresh; void *backing_store; unsigned long backing_store_size; #endif /* __ia64__ */ diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c index a9b1b86e7..b1759f9ed 100644 --- a/libguile/coop-pthreads.c +++ b/libguile/coop-pthreads.c @@ -31,6 +31,7 @@ #include "libguile/eval.h" #include "libguile/async.h" #include "libguile/ports.h" +#include "libguile/gc.h" #undef DEBUG @@ -847,8 +848,8 @@ scm_threads_init (SCM_STACKITEM *base) scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ / sizeof (SCM_STACKITEM))); \ - bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ - top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ + bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ + top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ scm_mark_locations (bot, top - bot); } while (0) #else # define SCM_MARK_BACKING_STORE() diff --git a/libguile/gc.c b/libguile/gc.c index 30d1cad89..89984888a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -28,11 +28,6 @@ #include #include -#ifdef __ia64__ -#include -extern unsigned long * __libc_ia64_register_backing_store_base; -#endif - #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" @@ -1036,6 +1031,44 @@ scm_init_gc () #include "libguile/gc.x" } +#ifdef __ia64__ +# ifdef __hpux +# include +# include +void * +scm_ia64_register_backing_store_base (void) +{ + struct pst_vm_status vm_status; + int i = 0; + while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1) + if (vm_status.pst_type == PS_RSESTACK) + return (void *) vm_status.pst_vaddr; + abort (); +} +void * +scm_ia64_ar_bsp (const void *ctx) +{ + uint64_t bsp; + __uc_get_ar_bsp(ctx, &bsp); + return (void *) bsp; +} +# endif /* hpux */ +# ifdef linux +# include +void * +scm_ia64_register_backing_store_base (void) +{ + extern void *__libc_ia64_register_backing_store_base; + return __libc_ia64_register_backing_store_base; +} +void * +scm_ia64_ar_bsp (const void *opaque) +{ + ucontext_t *ctx = opaque; + return (void *) ctx->uc_mcontext.sc_ar_bsp; +} +# endif /* linux */ +#endif /* __ia64__ */ void scm_gc_sweep (void) diff --git a/libguile/gc.h b/libguile/gc.h index 439cf8a4b..7c991bfbb 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -246,6 +246,11 @@ SCM_API scm_i_pthread_mutex_t scm_i_gc_admin_mutex; #define scm_gc_running_p (SCM_I_CURRENT_THREAD->gc_running_p) SCM_API scm_i_pthread_mutex_t scm_i_sweep_mutex; +#ifdef __ia64__ +void *scm_ia64_register_backing_store_base (void); +void *scm_ia64_ar_bsp (const void *); +#endif + #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/libguile/threads.c b/libguile/threads.c index 428133d8a..6e2bce9c7 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1304,8 +1304,8 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ / sizeof (SCM_STACKITEM))); \ - bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ - top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ + bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ + top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ scm_mark_locations (bot, top - bot); } while (0) #else # define SCM_MARK_BACKING_STORE() From d5074b473cceea3f051ea27eb05cfb797b7d788e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 26 Oct 2006 07:20:59 +0000 Subject: [PATCH 059/116] Changes from arch/CVS synchronization --- test-suite/ChangeLog | 5 +++++ test-suite/tests/srfi-14.test | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a35e29704..803cb44aa 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2006-10-26 Ludovic Courts + + * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a + typo: `thrown' instead of `throw'. + 2006-10-05 Kevin Ryde * tests/ftw.test: New file. diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index 5c3a3f509..fc6307149 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -290,7 +290,7 @@ (pass-if "char-set:punctuation (membership)" (if (not %latin1) - (thrown 'unresolved) + (throw 'unresolved) (let ((punctuation (char-set->list char-set:punctuation))) (every? (lambda (8-bit-char) (memq 8-bit-char punctuation)) From dd18d31211b6cbf9d1f1f8a83de8ba7ccb7ed32f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 2 Nov 2006 21:10:37 +0000 Subject: [PATCH 060/116] Remove environments.[ch] from the build. --- libguile/ChangeLog | 14 ++++++++++++++ libguile/Makefile.am | 8 ++++---- libguile/init.c | 6 ++++++ libguile/modules.c | 5 +++-- test-suite/ChangeLog | 4 ++++ test-suite/tests/environments.test | 5 +++++ 6 files changed, 36 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6d3a2db1d..4443132e7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2006-11-02 Neil Jerram + + * modules.c: Correct comment saying that low-level environments + will be used "in the next release". + + * init.c: Comment out #include of environments.h. + (scm_i_init_guile): Comment out scm_environments_prehistory() and + scm_init_environments() calls. + + * Makefile.am (libguile_la_SOURCES): Remove environments.c. + (DOT_X_FILES): Remove environments.x. + (DOT_DOC_FILES): Remove environments.doc. + (modinclude_HEADERS): Remove environments.h. + 2006-10-25 Neil Jerram IA64 HP-UX GC patch from Hrvoje Nikšić. (Thanks!) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index bf121161f..e8a161afa 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -94,7 +94,7 @@ libguile_la_CFLAGS = $(GUILE_CFLAGS) libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ chars.c continuations.c convert.c debug.c deprecation.c \ - deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \ + deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c \ @@ -111,7 +111,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ - dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ + dynl.x dynwind.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ @@ -128,7 +128,7 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ - environments.doc eq.doc error.doc eval.doc evalext.doc \ + eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \ gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc \ @@ -185,7 +185,7 @@ modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ - environments.h eq.h error.h eval.h evalext.h extensions.h \ + eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ diff --git a/libguile/init.c b/libguile/init.c index 44810be4e..e3a0bc41a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -46,7 +46,9 @@ #include "libguile/deprecation.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" +#if 0 #include "libguile/environments.h" +#endif #include "libguile/eq.h" #include "libguile/error.h" #include "libguile/eval.h" @@ -434,7 +436,9 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_struct_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */ scm_init_subr_table (); +#if 0 scm_environments_prehistory (); /* requires storage */ +#endif scm_modules_prehistory (); /* requires storage and hash tables */ scm_init_variable (); /* all bindings need variables */ scm_init_continuations (); @@ -443,7 +447,9 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_gsubr (); scm_init_thread_procs (); /* requires gsubrs */ scm_init_procprop (); +#if 0 scm_init_environments (); +#endif scm_init_alist (); scm_init_arbiters (); scm_init_async (); diff --git a/libguile/modules.c b/libguile/modules.c index 10f72da3c..cfb42a0b9 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -273,8 +273,9 @@ SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0, /* * C level implementation of the standard eval closure * - * This increases loading speed substantially. - * The code will be replaced by the low-level environments in next release. + * This increases loading speed substantially. The code may be + * replaced by something based on environments.[ch], in a future + * release. */ static SCM module_make_local_var_x_var; diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 803cb44aa..124b0b5b1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2006-11-02 Neil Jerram + + * tests/environments.test: Comment out all tests in this file. + 2006-10-26 Ludovic Courts * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 19117e3b5..646efc56a 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -17,6 +17,9 @@ (use-modules (ice-9 documentation)) +;;; environments are currently commented out of libguile, so these +;;; tests must be commented out also. - NJ 2006-11-02. +(if #f (let () ;;; ;;; miscellaneous @@ -1043,3 +1046,5 @@ (pass-if "documented?" (documented? make-import-environment)))) +;;; End of commenting out. - NJ 2006-11-02. +)) From d9f71a0754d8d01804028700e3f6adce00e7f44e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 8 Nov 2006 09:34:35 +0000 Subject: [PATCH 061/116] Changes from arch/CVS synchronization --- ChangeLog | 10 ++++ configure.in | 3 +- libguile/ChangeLog | 39 +++++++++++++++ libguile/gc-freelist.c | 14 +++--- libguile/gc-segment.c | 26 +++++----- libguile/gc.c | 107 +++++++++++++++++++++++++++-------------- libguile/gc.h | 4 -- libguile/private-gc.h | 9 ++-- 8 files changed, 149 insertions(+), 63 deletions(-) diff --git a/ChangeLog b/ChangeLog index 637b8fcd2..4cb803ce0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2006-11-08 Ludovic Courtès + + * configure.in: Pass `bug-guile@gnu.org' as a third argument to + `AC_INIT'. + 2006-10-25 Neil Jerram IA64 HP-UX patch from Hrvoje Nikšić. (Thanks!) @@ -2973,3 +2978,8 @@ Thu Aug 1 02:31:53 1996 Jim Blandy Makefile. Build doc/Makefile from doc/Makefile.in. * doc/Makefile.in: New file. + + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/configure.in b/configure.in index e63c0a749..6dd983933 100644 --- a/configure.in +++ b/configure.in @@ -28,7 +28,8 @@ Boston, MA 02110-1301, USA. AC_PREREQ(2.53) AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}), - m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION})) + m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}), + [bug-guile@gnu.org]) AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(GUILE-VERSION) AM_INIT_AUTOMAKE([no-define]) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4443132e7..9def3cd9a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,38 @@ +2006-11-08 Ludovic Courtès + + * libguile/gc-freelist.c (scm_i_adjust_min_yield): Take two + "sweep_stats" arguments; use them instead of accessing the global + variables `scm_gc_cells_collected' and `scm_gc_cells_collected_1'. + + * libguile/gc-segment.c (scm_i_sweep_some_cards): Reset SWEEP + before each iteration of the loop. + (scm_i_sweep_some_segments): Reset SWEEP at each iteration. + (scm_i_get_new_heap_segment): Take an additional argument + SWEEP_STATS. Compute MIN_CELLS as a function of it. + + * libguile/gc.c (scm_gc_cells_collected, + scm_gc_cells_collected_1): Removed. + (scm_i_gc_sweep_stats, scm_i_gc_sweep_stats_1): New. + (scm_gc_cells_marked_acc, scm_gc_cells_swept_acc, + scm_gc_time_taken, scm_gc_mark_time_taken, scm_gc_times, + scm_gc_cell_yield_percentage, protected_obj_count): Made `static'. + (scm_gc_stats): Use `scm_i_gc_sweep_stats' instead of + `scm_gc_cells_(collected|swept)'. + (gc_update_stats): New. + (gc_end_stats): Use `scm_i_gc_sweep_stats' and + `scm_i_gc_sweep_stats_1' instead of the former globals. + (scm_gc_for_newcell): Invoke `gc_update_stats ()' after each + `scm_i_sweep_some_segments' call. This fixes a bug where the GC + would keep allocating new segments instead of re-using collected + cells (because `scm_gc_cells_collected' would remain zero). + + * libguile/gc.h (scm_gc_cells_swept, scm_gc_cells_collected, + scm_gc_cell_yield_percentage): Removed. + + * libguile/private-gc.h (scm_gc_cells_collected_1): Removed. + (scm_i_adjust_min_yield): Updated. + (scm_i_get_new_heap_segment): Updated. + 2006-11-02 Neil Jerram * modules.c: Correct comment saying that low-level environments @@ -13546,3 +13581,7 @@ (write_all): new helper procedure. The ChangeLog continues in the file: "ChangeLog-2000" + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c index b3b558257..83c20f867 100644 --- a/libguile/gc-freelist.c +++ b/libguile/gc-freelist.c @@ -72,14 +72,13 @@ SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1 -/* - This adjust FREELIST variables to decide wether or not to allocate - more heap in the next GC run. It uses scm_gc_cells_collected and scm_gc_cells_collected1 - */ - +/* Adjust FREELIST variables to decide wether or not to allocate more heap in + the next GC run based on SWEEP_STATS on SWEEP_STATS_1 (statistics + collected after the two last full GC). */ void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist, - scm_t_sweep_statistics sweep_stats) + scm_t_sweep_statistics sweep_stats, + scm_t_sweep_statistics sweep_stats_1) { /* min yield is adjusted upwards so that next predicted total yield * (allocated cells actually freed by GC) becomes @@ -99,7 +98,8 @@ scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist, { /* Pick largest of last two yields. */ long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100) - - (long) sweep_stats.collected); + - (long) SCM_MAX (sweep_stats.collected, + sweep_stats_1.collected)); #ifdef DEBUGINFO fprintf (stderr, " after GC = %lu, delta = %ld\n", (unsigned long) scm_cells_allocated, diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c index 6e744184d..b26f1bd56 100644 --- a/libguile/gc-segment.c +++ b/libguile/gc-segment.c @@ -141,9 +141,8 @@ scm_i_clear_segment_mark_space (scm_t_heap_segment *seg) } /* Sweep cards from SEG until we've gathered THRESHOLD cells. On return, - *CELLS_SWEPT contains the number of cells that have been visited and - *CELLS_COLLECTED contains the number of cells actually collected. A - freelist is returned, potentially empty. */ + SWEEP_STATS contains the number of cells that have been visited and + collected. A freelist is returned, potentially empty. */ SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg, scm_t_sweep_statistics *sweep_stats) @@ -206,8 +205,12 @@ scm_i_sweep_segment (scm_t_heap_segment *seg, scm_i_sweep_statistics_init (sweep_stats); + scm_i_sweep_statistics_init (&sweep); while (scm_i_sweep_some_cards (seg, &sweep) != SCM_EOL) - scm_i_sweep_statistics_sum (sweep_stats, sweep); + { + scm_i_sweep_statistics_sum (sweep_stats, sweep); + scm_i_sweep_statistics_init (&sweep); + } seg->next_free_card =p; } @@ -339,6 +342,7 @@ scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl, if (scm_i_heap_segment_table[i]->freelist != fl) continue; + scm_i_sweep_statistics_init (&sweep); collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i], &sweep); @@ -461,14 +465,12 @@ scm_i_find_heap_segment_containing_object (SCM obj) } -/* - Important entry point: try to grab some memory, and make it into a - segment. - - RETURN: the index of the segment. - */ -int +/* Important entry point: try to grab some memory, and make it into a + segment; return the index of the segment. SWEEP_STATS should contain + global GC sweep statistics collected since the last full GC. */ +int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, + scm_t_sweep_statistics sweep_stats, policy_on_error error_policy) { size_t len; @@ -489,7 +491,7 @@ scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, */ float f = freelist->min_yield_fraction / 100.0; float h = SCM_HEAP_SIZE; - float min_cells = (f * h - scm_gc_cells_collected) / (1.0 - f); + float min_cells = (f * h - sweep_stats.collected) / (1.0 - f); /* Make heap grow with factor 1.5 */ len = freelist->heap_size / 2; diff --git a/libguile/gc.c b/libguile/gc.c index 89984888a..ead6d30be 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -209,20 +209,28 @@ unsigned long scm_mtrigger; */ unsigned long scm_cells_allocated = 0; unsigned long scm_mallocated = 0; -unsigned long scm_gc_cells_collected; -unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */ -unsigned long scm_gc_malloc_collected; -unsigned long scm_gc_ports_collected; -unsigned long scm_gc_time_taken = 0; + +/* Global GC sweep statistics since the last full GC. */ +static scm_t_sweep_statistics scm_i_gc_sweep_stats = { 0, 0 }; +static scm_t_sweep_statistics scm_i_gc_sweep_stats_1 = { 0, 0 }; + +/* Total count of cells marked/swept. */ +static double scm_gc_cells_marked_acc = 0.; +static double scm_gc_cells_swept_acc = 0.; + +static unsigned long scm_gc_time_taken = 0; static unsigned long t_before_gc; -unsigned long scm_gc_mark_time_taken = 0; -unsigned long scm_gc_times = 0; -unsigned long scm_gc_cells_swept = 0; -double scm_gc_cells_marked_acc = 0.; -double scm_gc_cells_swept_acc = 0.; -int scm_gc_cell_yield_percentage =0; +static unsigned long scm_gc_mark_time_taken = 0; + +static unsigned long scm_gc_times = 0; + +static int scm_gc_cell_yield_percentage = 0; +static unsigned long protected_obj_count = 0; + +/* The following are accessed from `gc-malloc.c' and `gc-card.c'. */ int scm_gc_malloc_yield_percentage = 0; -unsigned long protected_obj_count = 0; +unsigned long scm_gc_malloc_collected = 0; +unsigned long scm_gc_ports_collected = 0; SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); @@ -346,10 +354,10 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_protected_obj_count = protected_obj_count; local_scm_gc_cells_swept = (double) scm_gc_cells_swept_acc - + (double) scm_gc_cells_swept; + + (double) scm_i_gc_sweep_stats.swept; local_scm_gc_cells_marked = scm_gc_cells_marked_acc - +(double) scm_gc_cells_swept - -(double) scm_gc_cells_collected; + +(double) scm_i_gc_sweep_stats.swept + -(double) scm_i_gc_sweep_stats.collected; for (i = table_size; i--;) { @@ -393,6 +401,30 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, } #undef FUNC_NAME +/* Update the global sweeping/collection statistics by adding SWEEP_STATS to + SCM_I_GC_SWEEP_STATS and updating related variables. */ +static inline void +gc_update_stats (scm_t_sweep_statistics sweep_stats) +{ + /* CELLS SWEPT is another word for the number of cells that were examined + during GC. YIELD is the number that we cleaned out. MARKED is the number + that weren't cleaned. */ + + scm_gc_cell_yield_percentage = (sweep_stats.collected * 100) / SCM_HEAP_SIZE; + + scm_i_sweep_statistics_sum (&scm_i_gc_sweep_stats, sweep_stats); + + if ((scm_i_gc_sweep_stats.collected > scm_i_gc_sweep_stats.swept) + || (scm_cells_allocated < sweep_stats.collected)) + { + printf ("internal GC error, please report to `" + PACKAGE_BUGREPORT "'\n"); + abort (); + } + + scm_cells_allocated -= sweep_stats.collected; +} + static void gc_start_stats (const char *what SCM_UNUSED) { @@ -406,23 +438,18 @@ static void gc_end_stats (scm_t_sweep_statistics sweep_stats) { unsigned long t = scm_c_get_internal_run_time (); + scm_gc_time_taken += (t - t_before_gc); - /* - CELLS SWEPT is another word for the number of cells that were - examined during GC. YIELD is the number that we cleaned - out. MARKED is the number that weren't cleaned. - */ - scm_gc_cells_marked_acc += (double) sweep_stats.swept - - (double) scm_gc_cells_collected; - scm_gc_cells_swept_acc += (double) sweep_stats.swept; + /* Reset the number of cells swept/collected since the last full GC. */ + scm_i_gc_sweep_stats_1 = scm_i_gc_sweep_stats; + scm_i_gc_sweep_stats.collected = scm_i_gc_sweep_stats.swept = 0; - scm_gc_cell_yield_percentage = (sweep_stats.collected * 100) / SCM_HEAP_SIZE; + gc_update_stats (sweep_stats); - scm_gc_cells_swept = sweep_stats.swept; - scm_gc_cells_collected_1 = scm_gc_cells_collected; - scm_gc_cells_collected = sweep_stats.collected; - scm_cells_allocated -= sweep_stats.collected; + scm_gc_cells_marked_acc += (double) scm_i_gc_sweep_stats.swept + - (double) scm_i_gc_sweep_stats.collected; + scm_gc_cells_swept_acc += (double) scm_i_gc_sweep_stats.swept; ++scm_gc_times; } @@ -480,13 +507,17 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) scm_gc_running_p = 1; *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); - scm_cells_allocated -= sweep_stats.collected; + gc_update_stats (sweep_stats); if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist)) { - freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error); + freelist->heap_segment_idx = + scm_i_get_new_heap_segment (freelist, + scm_i_gc_sweep_stats, + abort_on_error); + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); - scm_cells_allocated -= sweep_stats.collected; + gc_update_stats (sweep_stats); } if (*free_cells == SCM_EOL) @@ -495,7 +526,9 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) with the advent of lazy sweep, GC yield is only known just before doing the GC. */ - scm_i_adjust_min_yield (freelist, sweep_stats); + scm_i_adjust_min_yield (freelist, + scm_i_gc_sweep_stats, + scm_i_gc_sweep_stats_1); /* out of fresh cells. Try to get some new ones. @@ -505,7 +538,7 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) scm_i_gc ("cells"); *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); - scm_cells_allocated -= sweep_stats.collected; + gc_update_stats (sweep_stats); } if (*free_cells == SCM_EOL) @@ -513,9 +546,13 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) /* failed getting new cells. Get new juice or die. */ - freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error); + freelist->heap_segment_idx = + scm_i_get_new_heap_segment (freelist, + scm_i_gc_sweep_stats, + abort_on_error); + *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats); - scm_cells_allocated -= sweep_stats.collected; + gc_update_stats (sweep_stats); } if (*free_cells == SCM_EOL) diff --git a/libguile/gc.h b/libguile/gc.h index 7c991bfbb..78ff02474 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -277,13 +277,9 @@ SCM_API scm_i_pthread_key_t scm_i_freelist2; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2; - -SCM_API unsigned long scm_gc_cells_swept; -SCM_API unsigned long scm_gc_cells_collected; SCM_API unsigned long scm_gc_malloc_collected; SCM_API unsigned long scm_gc_ports_collected; SCM_API unsigned long scm_cells_allocated; -SCM_API int scm_gc_cell_yield_percentage; SCM_API int scm_gc_malloc_yield_percentage; SCM_API unsigned long scm_mallocated; SCM_API unsigned long scm_mtrigger; diff --git a/libguile/private-gc.h b/libguile/private-gc.h index 8bda190c4..7c0fd883b 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -144,14 +144,13 @@ typedef struct scm_sweep_statistics } \ while (0) - extern scm_t_cell_type_statistics scm_i_master_freelist; extern scm_t_cell_type_statistics scm_i_master_freelist2; -extern unsigned long scm_gc_cells_collected_1; void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist, - scm_t_sweep_statistics sweep_stats); + scm_t_sweep_statistics sweep_stats, + scm_t_sweep_statistics sweep_stats_1); void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist); int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist); @@ -270,7 +269,9 @@ void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab); int scm_i_insert_segment (scm_t_heap_segment * seg); long int scm_i_find_heap_segment_containing_object (SCM obj); -int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error); +int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, + scm_t_sweep_statistics, + policy_on_error); void scm_i_clear_mark_space (void); void scm_i_sweep_segments (void); SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl, From 19b16cd0551758d5f9103eb90126afbdb60f7461 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 13 Nov 2006 22:21:36 +0000 Subject: [PATCH 062/116] *** empty log message *** --- emacs/ChangeLog | 5 +++++ emacs/gds-scheme.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 710f80e45..21c354c7b 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,8 @@ +2006-11-02 Neil Jerram + + * gds-scheme.el (gds-choose-client): Change assq to memq, so that + the mapcar really constructs a list of available clients. + 2006-10-14 Neil Jerram * gds.el (gds-socket-type-alist): New. diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index 8fb4ca2af..134e80592 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -158,7 +158,7 @@ Emacs to display an error or trap so that the user can debug it." (default nil)) ;; Prepare a table containing all current clients. (mapcar (lambda (client-info) - (setq table (cons (cons (cadr (assq 'name client-info)) + (setq table (cons (cons (cadr (memq 'name client-info)) (car client-info)) table))) gds-client-info) From 31b6212e9d357ef22ac66b0fe5189f19980aa21f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 13 Nov 2006 22:22:06 +0000 Subject: [PATCH 063/116] (environment-module): Change eval-closure-module call back to procedure-property lookup. (This completes the reversion of the change made on 2005-06-10, which was only partially undone by the change on 2005-08-01.) --- ice-9/ChangeLog | 7 +++++++ ice-9/boot-9.scm | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e241afed8..f50827ef8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,10 @@ +2006-11-13 Neil Jerram + + * boot-9.scm (environment-module): Change eval-closure-module call + back to procedure-property lookup. (This completes the reversion + of the change made on 2005-06-10, which was only partially undone + by the change on 2005-08-01.) + 2006-10-13 Neil Jerram Integration of Unix domain socket patch from William Xu: diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 3ecd7b596..b50ae2911 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -339,7 +339,7 @@ (define (environment-module env) (let ((closure (and (pair? env) (car (last-pair env))))) - (and closure (eval-closure-module closure)))) + (and closure (procedure-property closure 'module)))) From 51d079ab0d23e4175d333ce22eb3e74aeae5913d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 17 Nov 2006 15:51:37 +0000 Subject: [PATCH 064/116] * README: Note need for subscription to bug-guile@gnu.org. * NEWS: Note need for subscription to bug-guile@gnu.org. --- ChangeLog | 6 ++++++ NEWS | 4 +++- README | 4 +++- 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4cb803ce0..4c78c3efa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2006-11-17 Neil Jerram + + * README: Note need for subscription to bug-guile@gnu.org. + + * NEWS: Note need for subscription to bug-guile@gnu.org. + 2006-11-08 Ludovic Courtès * configure.in: Pass `bug-guile@gnu.org' as a third argument to diff --git a/NEWS b/NEWS index d5e136af6..c9ae42f13 100644 --- a/NEWS +++ b/NEWS @@ -2,7 +2,9 @@ Guile NEWS --- history of user-visible changes. Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. See the end for copying conditions. -Please send Guile bug reports to bug-guile@gnu.org. +Please send Guile bug reports to bug-guile@gnu.org. Note that you +must be subscribed to this list first, in order to successfully send a +report to it. Each release reports the NEWS in the following sections: diff --git a/README b/README index 1f346b081..d7a22805a 100644 --- a/README +++ b/README @@ -16,7 +16,9 @@ This has been the case since the 1.3.* series. The next stable release will likely be version 1.10.0. -Please send bug reports to bug-guile@gnu.org. +Please send bug reports to bug-guile@gnu.org. Note that you must be +subscribed to this list first, in order to successfully send a report +to it. See the LICENSE file for the specific terms that apply to Guile. From e563095988a1c64feb30307928bcc090828cdda9 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 17 Nov 2006 15:52:23 +0000 Subject: [PATCH 065/116] (Reporting Bugs): Note need for subscription to bug-guile@gnu.org. --- doc/ref/ChangeLog | 5 +++++ doc/ref/intro.texi | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index bb9c18312..0b3444cb5 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2006-11-17 Neil Jerram + + * intro.texi (Reporting Bugs): Note need for subscription to + bug-guile@gnu.org. + 2006-10-10 Neil Jerram * scheme-using.texi (Setting and Managing Breakpoints): New text diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index a31fe30f8..1494b81ee 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -420,7 +420,8 @@ purpose to check whether your code still relies on them. @section Reporting Bugs Any problems with the installation should be reported to -@email{bug-guile@@gnu.org}. +@email{bug-guile@@gnu.org}. Please note that you must be subscribed to +this list first, in order to successfully send a report to it. Whenever you have found a bug in Guile you are encouraged to report it to the Guile developers, so they can fix it. They may also be able to From f3e3f530c28cfa5c7830c5d9b01de6fc388bc42a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 17 Nov 2006 15:52:51 +0000 Subject: [PATCH 066/116] (scm_shell_usage): Note need for subscription to bug-guile@gnu.org. --- libguile/ChangeLog | 4 ++++ libguile/script.c | 4 +++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9def3cd9a..20186db64 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2006-11-17 Neil Jerram + + * script.c (scm_shell_usage): Note need for subscription to bug-guile@gnu.org. + 2006-11-08 Ludovic Courtès * libguile/gc-freelist.c (scm_i_adjust_min_yield): Take two diff --git a/libguile/script.c b/libguile/script.c index 33fcbc130..e3425e108 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -381,7 +381,9 @@ scm_shell_usage (int fatal, char *message) " -v, --version display version information and exit\n" " \\ read arguments from following script lines\n" "\n" - "Please report bugs to bug-guile@gnu.org\n", + "Please report bugs to bug-guile@gnu.org. (Note that you must\n" + "be subscribed to this list first, in order to successfully send\n" + "a report to it).\n", scm_usage_name); if (fatal) From cbea802b3763aa8cb43c88f7df272da3e41c32da Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 17 Nov 2006 15:53:17 +0000 Subject: [PATCH 067/116] Note need for subscription to bug-guile@gnu.org. --- benchmark-suite/ChangeLog | 4 ++++ benchmark-suite/README | 10 ++++++---- test-suite/ChangeLog | 4 ++++ test-suite/README | 8 +++++--- 4 files changed, 19 insertions(+), 7 deletions(-) diff --git a/benchmark-suite/ChangeLog b/benchmark-suite/ChangeLog index 2e3cbdcf8..0ec92fdb0 100644 --- a/benchmark-suite/ChangeLog +++ b/benchmark-suite/ChangeLog @@ -1,3 +1,7 @@ +2006-11-17 Neil Jerram + + * README: Note need for subscription to bug-guile@gnu.org. + 2006-05-02 Marius Vollmer * Makefile.am (SCM_BENCHMARKS_DIRS, dist-hook): Removed, they are diff --git a/benchmark-suite/README b/benchmark-suite/README index 186a74351..51051996b 100644 --- a/benchmark-suite/README +++ b/benchmark-suite/README @@ -12,7 +12,9 @@ You can reference the file `lib.scm' from your own code as the module (benchmark-suite lib); it also has comments at the top and before each function explaining what's going on. -Please write more Guile benchmarks, and send them to bug-guile@gnu.org. -We'll merge them into the distribution. All benchmark suites must be -licensed for our use under the GPL, but I don't think we're going to -collect assignment papers for them. +Please write more Guile benchmarks, and send them to +bug-guile@gnu.org. (Note that you must be subscribed to this list +first, in order to successfully send a message to it.) We'll merge +them into the distribution. All benchmark suites must be licensed for +our use under the GPL, but I don't think we're going to collect +assignment papers for them. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 124b0b5b1..799f2ee4a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2006-11-17 Neil Jerram + + * README: Note need for subscription to bug-guile@gnu.org. + 2006-11-02 Neil Jerram * tests/environments.test: Comment out all tests in this file. diff --git a/test-suite/README b/test-suite/README index 116869e17..35c0fc3c8 100644 --- a/test-suite/README +++ b/test-suite/README @@ -13,9 +13,11 @@ You can reference the file `lib.scm' from your own code as the module function explaining what's going on. Please write more Guile tests, and send them to bug-guile@gnu.org. -We'll merge them into the distribution. All test suites must be -licensed for our use under the GPL, but I don't think I'm going to -collect assignment papers for them. +(Note that you must be subscribed to this list first, in order to +successfully send a report to it.) We'll merge them into the +distribution. All test suites must be licensed for our use under the +GPL, but I don't think I'm going to collect assignment papers for +them. From b89c494395ce659d04508f47ea489d4fd1002182 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 18 Nov 2006 18:14:55 +0000 Subject: [PATCH 068/116] Changes from arch/CVS synchronization --- ChangeLog | 9 + GUILE-VERSION | 6 + NEWS | 2 + configure.in | 10 +- doc/ref/ChangeLog | 39 +- doc/ref/Makefile.am | 9 + doc/ref/api-data.texi | 9 +- doc/ref/api-i18n.texi | 292 ++++++++- doc/ref/guile.texi | 3 +- doc/ref/posix.texi | 15 +- libguile/ChangeLog | 37 ++ libguile/Makefile.am | 33 +- libguile/gettext.h | 94 +-- libguile/i18n.c | 1300 +++++++++++++++++++++++++++++++++------- libguile/i18n.h | 27 +- libguile/init.c | 4 +- libguile/posix.c | 27 +- libguile/posix.h | 5 +- test-suite/ChangeLog | 28 +- test-suite/Makefile.am | 1 + 20 files changed, 1607 insertions(+), 343 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4c78c3efa..033d75140 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2006-11-18 Ludovic Courtès + + * GUILE-VERSION: Added `LIBGUILE_I18N_*'. + + * configure.in: Look for `strcoll_l ()' and `newlocale ()'. + Substitute the `LIBGUILE_I18N_' variables. + + * NEWS: Mention `(ice-9 i18n)'. + 2006-11-17 Neil Jerram * README: Note need for subscription to bug-guile@gnu.org. diff --git a/GUILE-VERSION b/GUILE-VERSION index 9bc0caf4f..c23f8f6f9 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -54,3 +54,9 @@ LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT=3 LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION=0 LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE=0 LIBGUILE_SRFI_SRFI_60_INTERFACE="${LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE}" + +LIBGUILE_I18N_MAJOR=0 +LIBGUILE_I18N_INTERFACE_CURRENT=0 +LIBGUILE_I18N_INTERFACE_REVISION=0 +LIBGUILE_I18N_INTERFACE_AGE=0 +LIBGUILE_I18N_INTERFACE="${LIBGUILE_I18N_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_I18N_INTERFACE_AGE}" diff --git a/NEWS b/NEWS index c9ae42f13..0200931dd 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,8 @@ Changes in 1.8.1 (since 1.8.0): ** scm_exp - [C] ** scm_sqrt - [C] +* New `(ice-9 i18n)' module (see the manual for details) + * Bugs fixed ** Build problems have been fixed on MacOS, SunOS, and QNX. diff --git a/configure.in b/configure.in index 6dd983933..8444f60d2 100644 --- a/configure.in +++ b/configure.in @@ -616,8 +616,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # truncate - not in mingw # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific +# strcoll_l, newlocale - GNU extensions (glibc) # -AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate 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 truncate unsetenv isblank _NSGetEnviron]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate 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 truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale]) # Reasons for testing: # netdb.h - not in mingw @@ -1275,6 +1276,13 @@ AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION) AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE) AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE) +AC_SUBST(LIBGUILE_I18N_MAJOR) +AC_SUBST(LIBGUILE_I18N_INTERFACE_CURRENT) +AC_SUBST(LIBGUILE_I18N_INTERFACE_REVISION) +AC_SUBST(LIBGUILE_I18N_INTERFACE_AGE) +AC_SUBST(LIBGUILE_I18N_INTERFACE) + + ####################################################################### dnl Tell guile-config what flags guile users should compile and link with. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0b3444cb5..8b8e0befe 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,23 @@ +2006-11-18 Ludovic Courtès + + * Makefile.am (BUILT_SOURCES): New variable. + (lib-version.texi): New target. + + * guile.texi: Include `lib-version.texi'. + + * api-data.texi (Conversion): Link to `The ice-9 i18n Module' when + describing `string->number'. + (String Comparison): Likewise. + + * api-i18n.texi (Internationalization)[The ice-9 i18n Module]: New + node. + [Gettext Support]: New node; contains text formerly in + `Internationalization'. + + * posix.texi (Locales): Added a link to the glibc manual + describing the various locale categories. Mention locale objects + and link to `The ice-9 i18n Module' when describing `setlocale'. + 2006-11-17 Neil Jerram * intro.texi (Reporting Bugs): Note need for subscription to @@ -87,7 +107,7 @@ * api-data.texi (Scientific): In sqrt, note it's the positive root which is returned (as per R5RS). -2006-09-20 Ludovic Courts +2006-09-20 Ludovic Courtès * api-data.texi (Standard Character Sets): Documented the charset recomputation upon successful `setlocale'. @@ -214,12 +234,12 @@ * posix.texi (Time): In tm:gmtoff, give example values, note not the same as C tm_gmtoff. -2006-06-16 Ludovic Courts +2006-06-16 Ludovic Courtès * api-utility.texi (Equality): Mentioned the behavior of `equal?' for structures (as suggested by Kevin Ryde). -2006-06-13 Ludovic Courts +2006-06-13 Ludovic Courtès * api-compound.texi (Structure Concepts): Mentioned the behavior of `equal?' for structures. @@ -286,7 +306,7 @@ SCM_SIMPLE_VECTOR_SET not SCM_SIMPLE_VECTOR_SET_X, the former is what's in vector.h. -2006-03-21 Ludovic Courts +2006-03-21 Ludovic Courtès * api-data.texi (Conversion): Add scm_c_locale_stringn_to_number. @@ -338,7 +358,7 @@ contexts. Renamed all functions from scm_frame_ to scm_dynwind_. Updated documentation. -2005-12-19 Ludovic Courts +2005-12-19 Ludovic Courtès * api-data.texi (Operations Related to Symbols): Documented `scm_take_locale_symbol ()'. @@ -380,7 +400,7 @@ 2005-11-06 Kevin Ryde - From Ludovic Courts, partial rework by me: + From Ludovic Courtès, partial rework by me: * doc/ref/api-modules.texi (Creating Guile Modules): In define-module, describe #:re-export, #:export-syntax, #:re-export-syntax, #:replace and #:duplicates. Add re-export. @@ -393,7 +413,7 @@ * posix.texi (Network Socket Address): Add scm_make_socket_address, scm_c_make_socket_address, scm_from_sockaddr, scm_to_sockaddr. This - change by Ludovic Courts and revised a bit by me. + change by Ludovic Courtès and revised a bit by me. 2005-10-27 Kevin Ryde @@ -2499,3 +2519,8 @@ The change log for files in this directory continues backwards from 2001-08-27 in ../ChangeLog, as all the Guile documentation prior to this date was contained in a single directory. + + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 76a66f0c9..7d009ff52 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -21,6 +21,9 @@ AUTOMAKE_OPTIONS = gnu +BUILT_SOURCES = lib-version.texi + + info_TEXINFOS = guile.texi guile_TEXINFOS = preface.texi \ @@ -86,4 +89,10 @@ autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 $(preinstguiletool)/snarf-guile-m4-docs $< > $(srcdir)/$@ +lib-version.texi: $(top_srcdir)/GUILE-VERSION + cat "$^" | grep '^LIBGUILE_.*_MAJOR' | \ + sed 's/^LIBGUILE_\([A-Z0-9_]*\)_MAJOR=\([0-9]\+\)/@set LIBGUILE_\1_MAJOR \2/' \ + > "$@" + + MAINTAINERCLEANFILES = autoconf-macros.texi diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index ccd34e38f..abcb28de1 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1012,6 +1012,12 @@ zero. @rnindex number->string @rnindex string->number +The following procedures read and write numbers according to their +external representation as defined by R5RS (@pxref{Lexical structure, +R5RS Lexical Structure,, r5rs, The Revised^5 Report on the Algorithmic +Language Scheme}). @xref{The ice-9 i18n Module, the @code{(ice-9 +i18n)} module}, for locale-dependent number parsing. + @deffn {Scheme Procedure} number->string n [radix] @deffnx {C Function} scm_number_to_string (n, radix) Return a string holding the external representation of the @@ -2943,7 +2949,8 @@ predicates (@pxref{Characters}), but are defined on character sequences. The first set is specified in R5RS and has names that end in @code{?}. The second set is specified in SRFI-13 and the names have no ending @code{?}. The predicates ending in @code{-ci} ignore the character case -when comparing strings. +when comparing strings. @xref{The ice-9 i18n Module, the @code{(ice-9 +i18n)} module}, for locale-dependent string comparison. @rnindex string=? @deffn {Scheme Procedure} string=? s1 s2 diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index 63884254a..1927a755b 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8,6 +8,292 @@ @node Internationalization @section Support for Internationalization +@cindex internationalization +@cindex i18n + +Guile provides internationalization support for Scheme programs in two +ways. First, procedures to manipulate text and data in a way that +conforms to particular cultural conventions (i.e., in a +``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}. +Second, Guile allows the use of GNU @code{gettext} to translate +program message strings. + +@menu +* The ice-9 i18n Module:: Honoring cultural conventions. +* Gettext Support:: Translating message strings. +@end menu + + +@node The ice-9 i18n Module +@subsection The @code{(ice-9 i18n)} Module + +In order to make use of the following functions, one must import the +@code{(ice-9 i18n)} module in the usual way: + +@example +(use-modules (ice-9 i18n)) +@end example + +@cindex libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR} + +C programs can use the C functions corresponding to the procedures of +this module by including @code{} and by linking +against @code{libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}}. + +@cindex cultural conventions + +The @code{(ice-9 i18n)} module provides procedures to manipulate text +and other data in a way that conforms to the cultural conventions +chosen by the user. Each region of the world or language has its own +customs to, for instance, represent real numbers, classify characters, +collate text, etc. All these aspects comprise the so-called +``cultural conventions'' of that region or language. + +@cindex locale +@cindex locale category + +Computer systems typically refer to a set of cultural conventions as a +@dfn{locale}. For each particular aspect that comprise those cultural +conventions, a @dfn{locale category} is defined. For instance, the +way characters are classified is defined by the @code{LC_CTYPE} +category, while the language in which program messages are issued to +the user is defined by the @code{LC_MESSAGES} category +(@pxref{Locales, General Locale Information} for details). + +@cindex locale object + +The procedures provided by this module allow the development of +programs that adapt automatically to any locale setting. As we will +see later, many of the locale-dependent procedures provided by this +module can optionally take a @dfn{locale object} argument. This +additional argument defines the locale settings that must be followed +by the invoked procedure. When it is omitted, then the current locale +settings of the process are followed (@pxref{Locales, +@code{setlocale}}). + +The following procedures allow the manipulation of such locale +objects. + +@deffn {Scheme Procedure} make-locale category-mask locale-name [base-locale] +@deffnx {C Function} scm_make_locale (category_mask, locale_name, base_locale) +Return a reference to a data structure representing a set of locale +datasets. @var{locale-name} should be a string denoting a particular +locale, e.g., @code{"aa_DJ"}. Unlike for the @var{category} parameter +for @code{setlocale}, the @var{category-mask} parameter here uses a +single bit for each category, made by OR'ing together @code{LC_*_MASK} +bits. The optional @var{base-locale} argument can be used to specify +a locale object whose settings are to be used as a basis for the +locale object being returned. + +The available locale category masks are the following: + +@defvar LC_COLLATE_MASK +Represents the collation locale category. +@end defvar +@defvar LC_CTYPE_MASK +Represents the character classification locale category. +@end defvar +@defvar LC_MESSAGES_MASK +Represents the messages locale category. +@end defvar +@defvar LC_MONETARY_MASK +Represents the monetary locale category. +@end defvar +@defvar LC_NUMERIC_MASK +Represents the way numbers are displayed. +@end defvar +@defvar LC_TIME_MASK +Represents the way date and time are displayed +@end defvar + +The following category masks are also available but will not have any +effect on systems that do not support them: + +@defvar LC_PAPER_MASK +@defvarx LC_NAME_MASK +@defvarx LC_ADDRESS_MASK +@defvarx LC_TELEPHONE_MASK +@defvarx LC_MEASUREMENT_MASK +@defvarx LC_IDENTIFICATION_MASK +@end defvar + +Finally, there is also: + +@defvar LC_ALL_MASK +This represents all the locale categories supported by the system. +@end defvar + +The @code{LC_*_MASK} variables are bound to integers which may be OR'd +together using @code{logior} (@pxref{Primitive Numerics, +@code{logior}}). For instance, the following invocation creates a +locale object that combines the use of Esperanto for messages and +character classification with the default settings for the other +categories (i.e., the settings of the default @code{C} locale which +usually represents conventions in use in the USA): + +@example +(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO") +@end example + +The following example combines the use of Swedish conventions with +monetary conventions from Croatia: + +@example +(make-locale LC_MONETARY_MASK "hr_HR" + (make-locale LC_ALL_MASK "sv_SE")) +@end example + +A @code{system-error} exception (@pxref{Handling Errors}) is raised by +@code{make-locale} when @var{locale-name} does not match any of the +locales compiled on the system. Note that on non-GNU systems, this +error may be raised later, when the locale object is actually used. + +@end deffn + +@deffn {Scheme Procedure} locale? obj +@deffnx {C Function} scm_locale_p (obj) +Return true if @var{obj} is a locale object. +@end deffn + +The following procedures provide support for text collation. + +@deffn {Scheme Procedure} string-locale? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_gt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a locale-dependent way. If +@var{locale} is provided, it should be locale object (as returned by +@code{make-locale}) and will be used to perform the comparison; +otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale-ci? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a case-insensitive, and +locale-dependent way. If @var{locale} is provided, it should be +locale object (as returned by @code{make-locale}) and will be used to +perform the comparison; otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_eq (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a case-insensitive, and +locale-dependent way. If @var{locale} is provided, it should be +locale object (as returned by @code{make-locale}) and will be used to +perform the comparison; otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} char-locale? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_gt (c1, c2, locale) +Return true if character @var{c1} is greater than @var{c2} according +to @var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_ci_gt (c1, c2, locale) +Return true if character @var{c1} is greater than @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_ci_eq (c1, c2, locale) +Return true if character @var{c1} is equal to @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +The procedures below provide support for ``character case mapping'', +i.e., to convert characters or strings to their upper-case or +lower-case equivalent. Note that SRFI-13 provides procedures that +look similar (@pxref{Alphabetic Case Mapping}). However, the SRFI-13 +procedures are locale-independent. Therefore, they do not take into +account specificities of the customs in use in a particular language +or region of the world. For instance, while most languages using the +Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'', +Turkish maps lower-case ``i'' to ``Latin capital letter I with dot +above''. The following procedures allow to provide idiomatic +character mapping. + +@deffn {Scheme Procedure} char-locale-downcase chr [locale] +@deffnx {C Function} scm_char_locale_upcase (chr, locale) +Return the lowercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-upcase chr [locale] +@deffnx {C Function} scm_char_locale_downcase (chr, locale) +Return the uppercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-upcase str [locale] +@deffnx {C Function} scm_string_locale_upcase (str, locale) +Return a new string that is the uppercase version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-downcase str [locale] +@deffnx {C Function} scm_string_locale_downcase (str, locale) +Return a new string that is the down-case version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +Finally, the following procedures allow programs to read numbers +written according to a particular locale. As an example, in English, +``ten thousand and a half'' is usually written @code{10,000.5} while +in French it is written @code{10000,5}. These procedures allow to +account for these differences. + +@deffn {Scheme Procedure} locale-string->integer str [base [locale]] +@deffnx {C Function} scm_locale_string_to_integer (str, base, locale) +Convert string @var{str} into an integer according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current process locale. If @var{base} is specified, then it +determines the base of the integer being read (e.g., @code{16} for an +hexadecimal number, @code{10} for a decimal number); by default, +decimal numbers are read. Return two values: an integer (on success) +or @code{#f}, and the number of characters read from @var{str} +(@code{0} on failure). +@end deffn + +@deffn {Scheme Procedure} locale-string->inexact str [locale] +@deffnx {C Function} scm_locale_string_to_inexact (str, locale) +Convert string @var{str} into an inexact number according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current process locale. Return two values: an inexact number (on +success) or @code{#f}, and the number of characters read from +@var{str} (@code{0} on failure). +@end deffn + + +@node Gettext Support +@subsection Gettext Support + Guile provides an interface to GNU @code{gettext} for translating message strings (@pxref{Introduction,,, gettext, GNU @code{gettext} utilities}). @@ -19,7 +305,8 @@ catalog filename). When @code{gettext} is not available, or if Guile was configured @samp{--without-nls}, dummy functions doing no translation are -provided. +provided. When @code{gettext} support is available in Guile, the +@code{i18n} feature is provided (@pxref{Feature Tracking}). @deffn {Scheme Procedure} gettext msg [domain [category]] @deffnx {C Function} scm_gettext (msg, domain, category) @@ -155,4 +442,5 @@ future. @c Local Variables: @c TeX-master: "guile.texi" +@c ispell-local-dictionary: "american" @c End: diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 992ca28c4..109a50b7f 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -7,6 +7,7 @@ @set MANUAL-EDITION 1.1 @c %**end of header @include version.texi +@include lib-version.texi @copying This reference manual documents Guile, GNU's Ubiquitous Intelligent @@ -137,7 +138,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.47 2006-10-09 22:45:02 kryde Exp $ +@c @subtitle $Id: guile.texi,v 1.48 2006-11-18 18:14:55 civodul Exp $ @c See preface.texi for the list of authors @author The Guile Developers diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 0711b9a1e..6f496fe8d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -3139,10 +3139,11 @@ specified. Get or set the current locale, used for various internationalizations. Locales are strings, such as @samp{sv_SE}. -If @var{locale} is given then the locale for the given @var{category} is set -and the new value returned. If @var{locale} is not given then the -current value is returned. @var{category} should be one of the -following values +If @var{locale} is given then the locale for the given @var{category} +is set and the new value returned. If @var{locale} is not given then +the current value is returned. @var{category} should be one of the +following values (@pxref{Locale Categories, Categories of Activities +that Locales Affect,, libc, The GNU C Library Reference Manual}): @defvar LC_ALL @defvarx LC_COLLATE @@ -3159,6 +3160,10 @@ categories based on standard environment variables (@code{LANG} etc). For full details on categories and locale names @pxref{Locales,, Locales and Internationalization, libc, The GNU C Library Reference Manual}. + +Note that @code{setlocale} affects locale settings for the whole +process. @xref{The ice-9 i18n Module, locale objects and +@code{make-locale}}, for a thread-safe alternative. @end deffn @node Encryption diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 20186db64..cc567810b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,40 @@ +2006-11-18 Ludovic Courtès + + * Makefile.am (lib_LTLIBRARIES): Added `libguile-i18n-v-XX.la'. + (libguile_la_SOURCES): Added `gettext.c', removed `i18n.c'. + (libguile_i18n_v_XX_la_SOURCES, libguile_i18n_v_XX_la_CFLAGS, + libguile_i18n_v_XX_la_LIBADD, libguile_i18n_v_XX_la_LDFLAGS): New. + (DOT_X_FILES): Added `gettext.x'. + (DOT_DOC_FILES): Likewise. + (EXTRA_libguile_la_SOURCES): Added `locale-categories.h'. + (modinclude_HEADERS): Added `gettext.h'. + (EXTRA_DIST): Added `libgettext.h'. + + * gettext.h: Renamed to... + * libgettext.h: New file. + + * i18n.c: Renamed to... + * gettext.c: New file. + + * i18n.h: Renamed to... + * gettext.h: New file. + + * i18n.c, i18n.h, locale-categories.h: New files. + + * init.c: Include "libguile/gettext.h" instead of + "libguile/i18n.h". + (scm_i_init_guile): Invoke `scm_init_gettext ()' instead of + `scm_init_i18n ()'. + + * posix.c: Include "libguile/gettext.h" instead of + "libguile/i18n.h" Test `HAVE_NEWLOCALE' and `HAVE_STRCOLL_L'. + (USE_GNU_LOCALE_API): New macro. + (scm_i_locale_mutex): New variable. + (scm_setlocale): Lock and unlock it around `setlocale ()' calls. + + * posix.h: Include "libguile/threads.h". + (scm_i_locale_mutex): New declaration. + 2006-11-17 Neil Jerram * script.c (scm_shell_usage): Note need for subscription to bug-guile@gnu.org. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e8a161afa..47220ddb6 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -31,7 +31,8 @@ INCLUDES = -I.. -I$(top_srcdir) ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \ --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/' -lib_LTLIBRARIES = libguile.la +lib_LTLIBRARIES = libguile.la \ + libguile-i18n-v-@LIBGUILE_I18N_MAJOR@.la bin_PROGRAMS = guile noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig @@ -97,9 +98,10 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ - gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c \ + gc-freelist.c gc_os_dep.c gdbint.c gettext.c \ + gh_data.c gh_eval.c gh_funcs.c \ gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \ - guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \ + guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ @@ -109,11 +111,21 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ ramap.c unif.c +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \ + $(libguile_la_CFLAGS) +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \ + libguile.la +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ + -module -L$(builddir) -lguile \ + -version-info @LIBGUILE_I18N_INTERFACE@ + DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ - gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x \ + gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \ + gsubr.x guardians.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ @@ -131,7 +143,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \ - gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc \ + gc-malloc.doc gc-card.doc gettext.doc \ + guardians.doc hash.doc hashtab.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ @@ -153,8 +166,9 @@ EXTRA_libguile_la_SOURCES = _scm.h \ inet_aton.c memmove.c putenv.c strerror.c \ dynl.c regex-posix.c \ filesys.c posix.c net_db.c socket.c \ - debug-malloc.c mkstemp.c \ - win32-uname.c win32-dirent.c win32-socket.c + debug-malloc.c mkstemp.c \ + win32-uname.c win32-dirent.c win32-socket.c \ + locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's ## lingering there due to an earlier guile version not having been @@ -187,7 +201,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ - gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h \ + gdb_interface.h gdbint.h gettext.h goops.h \ + gsubr.h guardians.h hash.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ @@ -212,7 +227,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top gettext.h + scmconfig.h.top libgettext.h # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi diff --git a/libguile/gettext.h b/libguile/gettext.h index f54b6bff7..4d91358e5 100644 --- a/libguile/gettext.h +++ b/libguile/gettext.h @@ -1,69 +1,41 @@ -/* Convenience header for conditional use of GNU . - Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc. +/* classes: h_files */ - This program is free software; you can redistribute it and/or modify it - under the terms of the GNU Library General Public License as published - by the Free Software Foundation; either version 2, or (at your option) - any later version. +#ifndef SCM_GETTEXT_H +#define SCM_GETTEXT_H - This program 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 - Library General Public License for more details. +/* Copyright (C) 2004, 2006 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 2.1 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 + */ - You should have received a copy of the GNU Library General Public - License along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, - USA. */ +#include "libguile/__scm.h" -#ifndef _LIBGETTEXT_H -#define _LIBGETTEXT_H 1 +SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category); +SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category); +SCM_API SCM scm_textdomain (SCM domainname); +SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory); +SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding); -/* NLS can be disabled through the configure --disable-nls option. */ -#if ENABLE_NLS +SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all); -/* Get declarations of GNU message catalog functions. */ -# include +SCM_API void scm_init_gettext (void); -#else +#endif /* SCM_GETTEXT_H */ -/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which - chokes if dcgettext is defined as a macro. So include it now, to make - later inclusions of a NOP. We don't include - as well because people using "gettext.h" will not include , - and also including would fail on SunOS 4, whereas - is OK. */ -#if defined(__sun) -# include -#endif - -/* Disabled NLS. - The casts to 'const char *' serve the purpose of producing warnings - for invalid uses of the value returned from these functions. - On pre-ANSI systems without 'const', the config.h file is supposed to - contain "#define const". */ -# define gettext(Msgid) ((const char *) (Msgid)) -# define dgettext(Domainname, Msgid) ((const char *) (Msgid)) -# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid)) -# define ngettext(Msgid1, Msgid2, N) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define dngettext(Domainname, Msgid1, Msgid2, N) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define textdomain(Domainname) ((const char *) (Domainname)) -# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname)) -# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset)) - -#endif - -/* A pseudo function call that serves as a marker for the automated - extraction of messages, but does not call gettext(). The run-time - translation is done at a different place in the code. - The argument, String, should be a literal string. Concatenated strings - and other string expressions won't work. - The macro's expansion is not parenthesized, so that it is suitable as - initializer for static 'char[]' or 'const char[]' variables. */ -#define gettext_noop(String) String - -#endif /* _LIBGETTEXT_H */ +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/i18n.c b/libguile/i18n.c index 16e45e495..76dd9a514 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2006 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 @@ -15,308 +15,1142 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */ #if HAVE_CONFIG_H # include #endif +#if HAVE_ALLOCA_H +# include +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" +# endif +void *alloca (size_t); +#endif + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/i18n.h" #include "libguile/strings.h" +#include "libguile/chars.h" #include "libguile/dynwind.h" +#include "libguile/validate.h" +#include "libguile/values.h" -#include "gettext.h" #include +#include /* `strcoll ()' */ +#include /* `toupper ()' et al. */ +#include +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif -int -scm_i_to_lc_category (SCM category, int allow_lc_all) +#ifndef USE_GNU_LOCALE_API +# include "libguile/posix.h" /* for `scm_i_locale_mutex' */ +#endif + +#ifndef HAVE_SETLOCALE +static inline char * +setlocale (int category, const char *name) { - int c_category = scm_to_int (category); - switch (c_category) - { -#ifdef LC_CTYPE - case LC_CTYPE: + errno = ENOSYS; + return NULL; +} #endif -#ifdef LC_NUMERIC - case LC_NUMERIC: + + + +/* Locale objects, string and character collation, and other locale-dependent + string operations. + + A large part of the code here deals with emulating glibc's reentrant + locale API on non-GNU systems. The emulation is a bit "brute-force": + Whenever a `-locale as found in glibc 2.3.6). This must be kept in sync with + `locale-categories.h'. */ + +# define LC_CTYPE_MASK (1 << LC_CTYPE) +# define LC_COLLATE_MASK (1 << LC_COLLATE) +# define LC_MESSAGES_MASK (1 << LC_MESSAGES) +# define LC_MONETARY_MASK (1 << LC_MONETARY) +# define LC_NUMERIC_MASK (1 << LC_NUMERIC) +# define LC_TIME_MASK (1 << LC_TIME) + +# ifdef LC_PAPER +# define LC_PAPER_MASK (1 << LC_PAPER) +# else +# define LC_PAPER_MASK 0 +# endif +# ifdef LC_NAME +# define LC_NAME_MASK (1 << LC_NAME) +# else +# define LC_NAME_MASK 0 +# endif +# ifdef LC_ADDRESS +# define LC_ADDRESS_MASK (1 << LC_ADDRESS) +# else +# define LC_ADDRESS_MASK 0 +# endif +# ifdef LC_TELEPHONE +# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) +# else +# define LC_TELEPHONE_MASK 0 +# endif +# ifdef LC_MEASUREMENT +# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) +# else +# define LC_MEASUREMENT_MASK 0 +# endif +# ifdef LC_IDENTIFICATION +# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) +# else +# define LC_IDENTIFICATION_MASK 0 +# endif + +# define LC_ALL_MASK (LC_CTYPE_MASK \ + | LC_NUMERIC_MASK \ + | LC_TIME_MASK \ + | LC_COLLATE_MASK \ + | LC_MONETARY_MASK \ + | LC_MESSAGES_MASK \ + | LC_PAPER_MASK \ + | LC_NAME_MASK \ + | LC_ADDRESS_MASK \ + | LC_TELEPHONE_MASK \ + | LC_MEASUREMENT_MASK \ + | LC_IDENTIFICATION_MASK \ + ) + +/* Locale objects as returned by `make-locale' on non-GNU systems. */ +typedef struct scm_locale +{ + SCM base_locale; /* a `locale' object */ + char *locale_name; + int category_mask; +} *scm_t_locale; + +#else + +/* Alias for glibc's locale type. */ +typedef locale_t scm_t_locale; + #endif -#ifdef LC_COLLATE - case LC_COLLATE: + +/* Validate parameter ARG as a locale object and set C_LOCALE to the + corresponding C locale object. */ +#define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \ + (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \ + } \ + while (0) + +/* Validate optional parameter ARG as either undefined or bound to a locale + object. Set C_LOCALE to the corresponding C locale object or NULL. */ +#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + if ((_arg) != SCM_UNDEFINED) \ + SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \ + else \ + (_c_locale) = NULL; \ + } \ + while (0) + + +SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0); + +SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) +{ + scm_t_locale c_locale; + + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + +#ifdef USE_GNU_LOCALE_API + freelocale ((locale_t)c_locale); +#else + c_locale->base_locale = SCM_UNDEFINED; + free (c_locale->locale_name); + + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); #endif -#ifdef LC_TIME - case LC_TIME: -#endif -#ifdef LC_MONETARY - case LC_MONETARY: -#endif -#ifdef LC_MESSAGES - case LC_MESSAGES: -#endif -#ifdef LC_PAPER - case LC_PAPER: -#endif -#ifdef LC_NAME - case LC_NAME: -#endif -#ifdef LC_ADDRESS - case LC_ADDRESS: -#endif -#ifdef LC_TELEPHONE - case LC_TELEPHONE: -#endif -#ifdef LC_MEASUREMENT - case LC_MEASUREMENT: -#endif -#ifdef LC_IDENTIFICATION - case LC_IDENTIFICATION: -#endif - return c_category; -#ifdef LC_ALL - case LC_ALL: - if (allow_lc_all) - return c_category; -#endif - } - scm_wrong_type_arg (0, 0, category); + + return 0; } -SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0, - (SCM msgid, SCM domain, SCM category), - "Return the translation of @var{msgid} in the message domain " - "@var{domain}. @var{domain} is optional and defaults to the " - "domain set through (textdomain). @var{category} is optional " - "and defaults to LC_MESSAGES.") -#define FUNC_NAME s_scm_gettext +#ifndef USE_GNU_LOCALE_API +static SCM +smob_locale_mark (SCM locale) { - char *c_msgid; - char const *c_result; - SCM result; + scm_t_locale c_locale; - scm_dynwind_begin (0); + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + return (c_locale->base_locale); +} +#endif - c_msgid = scm_to_locale_string (msgid); - scm_dynwind_free (c_msgid); - if (SCM_UNBNDP (domain)) +SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, + (SCM category_mask, SCM locale_name, SCM base_locale), + "Return a reference to a data structure representing a set of " + "locale datasets. Unlike for the @var{category} parameter for " + "@code{setlocale}, the @var{category_mask} parameter here uses " + "a single bit for each category, made by OR'ing together " + "@code{LC_*_MASK} bits.") +#define FUNC_NAME s_scm_make_locale +{ + SCM locale = SCM_BOOL_F; + int c_category_mask; + char *c_locale_name; + scm_t_locale c_base_locale, c_locale; + + SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask); + SCM_VALIDATE_STRING (2, locale_name); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); + + c_locale_name = scm_to_locale_string (locale_name); + +#ifdef USE_GNU_LOCALE_API + + c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + + if (!c_locale) + locale = SCM_BOOL_F; + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + + free (c_locale_name); + +#else + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + c_locale->base_locale = base_locale; + + c_locale->category_mask = c_category_mask; + c_locale->locale_name = c_locale_name; + + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + +#endif + + return locale; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a locale object.") +#define FUNC_NAME s_scm_locale_p +{ + if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)) + return SCM_BOOL_T; + + return SCM_BOOL_F; +} +#undef FUNC_NAME + + + +#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */ + + +/* Maximum number of chained locales (via `base_locale'). */ +#define LOCALE_STACK_SIZE_MAX 256 + +typedef struct +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} scm_t_locale_settings; + +/* Fill out SETTINGS according to the current locale settings. On success + zero is returned and SETTINGS is properly initialized. */ +static int +get_current_locale_settings (scm_t_locale_settings *settings) +{ + const char *locale_name; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + { \ + SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \ + if (!locale_name) \ + goto handle_error; \ + \ + settings-> _name = strdup (locale_name); \ + if (settings-> _name == NULL) \ + goto handle_oom; \ + } + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; + + handle_oom: + return ENOMEM; +} + +/* Restore locale settings SETTINGS. On success, return zero. */ +static int +restore_locale_settings (const scm_t_locale_settings *settings) +{ + const char *result; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \ + if (result == NULL) \ + goto handle_error; + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; +} + +/* Free memory associated with SETTINGS. */ +static void +free_locale_settings (scm_t_locale_settings *settings) +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + free (settings-> _name); \ + settings->_name = NULL; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} + +/* Install the locale named LOCALE_NAME for all the categories listed in + CATEGORY_MASK. */ +static int +install_locale_categories (const char *locale_name, int category_mask) +{ + const char *result; + + if (category_mask == LC_ALL_MASK) { - /* 1 argument case. */ - c_result = gettext (c_msgid); + SCM_SYSCALL (result = setlocale (LC_ALL, locale_name)); + if (result == NULL) + goto handle_error; } else { - char *c_domain; +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + if (category_mask & LC_ ## _name ## _MASK) \ + { \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \ + if (result == NULL) \ + goto handle_error; \ + } +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + } - c_domain = scm_to_locale_string (domain); - scm_dynwind_free (c_domain); + return 0; - if (SCM_UNBNDP (category)) - { - /* 2 argument case. */ - c_result = dgettext (c_domain, c_msgid); - } + handle_error: + return errno; +} + +/* Install LOCALE, recursively installing its base locales first. On + success, zero is returned. */ +static int +install_locale (scm_t_locale locale) +{ + scm_t_locale stack[LOCALE_STACK_SIZE_MAX]; + size_t stack_size = 0; + int stack_offset = 0; + const char *result = NULL; + + /* Build up a locale stack by traversing the `base_locale' link. */ + do + { + if (stack_size >= LOCALE_STACK_SIZE_MAX) + /* We cannot use `scm_error ()' here because otherwise the locale + mutex may remain locked. */ + return EINVAL; + + stack[stack_size++] = locale; + + if (locale->base_locale != SCM_UNDEFINED) + locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale); else - { - /* 3 argument case. */ - int c_category; + locale = NULL; + } + while (locale != NULL); - c_category = scm_i_to_lc_category (category, 0); - c_result = dcgettext (c_domain, c_msgid, c_category); - } + /* Install the C locale to start from a pristine state. */ + SCM_SYSCALL (result = setlocale (LC_ALL, "C")); + if (result == NULL) + goto handle_error; + + /* Install the locales in reverse order. */ + for (stack_offset = stack_size - 1; + stack_offset >= 0; + stack_offset--) + { + int err; + scm_t_locale locale; + + locale = stack[stack_offset]; + err = install_locale_categories (locale->locale_name, + locale->category_mask); + if (err) + goto handle_error; } - if (c_result == c_msgid) - result = msgid; - else - result = scm_from_locale_string (c_result); + return 0; + + handle_error: + return errno; +} + +/* Leave the locked locale section. */ +static inline void +leave_locale_section (const scm_t_locale_settings *settings) +{ + /* Restore the previous locale settings. */ + (void)restore_locale_settings (settings); + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +} + +/* Enter a locked locale section. */ +static inline int +enter_locale_section (scm_t_locale locale, + scm_t_locale_settings *prev_locale) +{ + int err; + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + err = get_current_locale_settings (prev_locale); + if (err) + { + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + return err; + } + + err = install_locale (locale); + if (err) + { + leave_locale_section (prev_locale); + free_locale_settings (prev_locale); + } + + return err; +} + +/* Throw an exception corresponding to error ERR. */ +static void inline +scm_locale_error (const char *func_name, int err) +{ + SCM s_err; + + s_err = scm_from_int (err); + scm_error (scm_system_error_key, func_name, + "Failed to install locale", + scm_cons (scm_strerror (s_err), SCM_EOL), + scm_cons (s_err, SCM_EOL)); +} + +/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */ +#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \ + do \ + { \ + int lsec_err; \ + scm_t_locale_settings lsec_prev_locale; \ + \ + lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \ + if (lsec_err) \ + scm_locale_error (FUNC_NAME, lsec_err); \ + else \ + { \ + _statement ; \ + \ + leave_locale_section (&lsec_prev_locale); \ + free_locale_settings (&lsec_prev_locale); \ + } \ + } \ + while (0) + +#endif /* !USE_GNU_LOCALE_API */ + + +/* Locale-dependent string comparison. */ + +/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return + an integer whose sign is the same as the difference between C_S1 and + C_S2. */ +static inline int +compare_strings (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + result = strcoll_l (c_s1, c_s2, c_locale); +#else +#ifdef HAVE_STRCOLL + RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2)); +#else + result = strcmp (c_s1, c_s2); +#endif +#endif /* !USE_GNU_LOCALE_API */ + } + else + +#ifdef HAVE_STRCOLL + result = strcoll (c_s1, c_s2); +#else + result = strcmp (c_s1, c_s2); +#endif + + return result; +} +#undef FUNC_NAME + +/* Store into DST an upper-case version of SRC. */ +static inline void +str_upcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper (*src); + *dst = '\0'; +} + +static inline void +str_downcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower (*src); + *dst = '\0'; +} + +#ifdef USE_GNU_LOCALE_API +static inline void +str_upcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper_l (*src, locale); + *dst = '\0'; +} + +static inline void +str_downcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower_l (*src, locale); + *dst = '\0'; +} +#endif + + +/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way + according to LOCALE. Return an integer whose sign is the same as the + difference between C_S1 and C_S2. */ +static inline int +compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; + char *c_us1, *c_us2; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + c_us1 = (char *) alloca (strlen (c_s1) + 1); + c_us2 = (char *) alloca (strlen (c_s2) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_us1, c_s1, c_locale); + str_upcase_l (c_us2, c_s2, c_locale); + + result = strcoll_l (c_us1, c_us2, c_locale); +#else + int err; + scm_t_locale_settings prev_locale; + + err = enter_locale_section (c_locale, &prev_locale); + if (err) + { + scm_locale_error (func_name, err); + return 0; + } + + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif /* !HAVE_STRCOLL */ + + leave_locale_section (&prev_locale); + free_locale_settings (&prev_locale); +#endif /* !USE_GNU_LOCALE_API */ + } + else + { + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif + } - scm_dynwind_end (); return result; } #undef FUNC_NAME -SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0, - (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category), - "Return the translation of @var{msgid}/@var{msgid_plural} in the " - "message domain @var{domain}, with the plural form being chosen " - "appropriately for the number @var{n}. @var{domain} is optional " - "and defaults to the domain set through (textdomain). " - "@var{category} is optional and defaults to LC_MESSAGES.") -#define FUNC_NAME s_scm_ngettext +SCM_DEFINE (scm_string_locale_lt, "string-locale?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a locale-dependent way." + "If @var{locale} is provided, it should be locale object (as " + "returned by @code{make-locale}) and will be used to perform the " + "comparison; otherwise, the current system locale is used.") +#define FUNC_NAME s_scm_string_locale_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a case-insensitive, " + "and locale-dependent way. If @var{locale} is provided, it " + "should be locale object (as returned by @code{make-locale}) " + "and will be used to perform the comparison; otherwise, the " + "current system locale is used.") +#define FUNC_NAME s_scm_string_locale_ci_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a case-insensitive, " + "and locale-dependent way. If @var{locale} is provided, it " + "should be locale object (as returned by @code{make-locale}) " + "and will be used to perform the comparison; otherwise, the " + "current system locale is used.") +#define FUNC_NAME s_scm_string_locale_ci_eq +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_locale_lt, "char-locale?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is greater than @var{c2} " + "according to @var{locale} or to the current locale.") +#define FUNC_NAME s_scm_char_locale_gt +{ + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is greater than @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_gt +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is equal to @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_eq +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + + +/* Locale-dependent alphabetic character mapping. */ + +SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the lowercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_downcase +{ + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = tolower_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr)); +#endif + } + else + c_result = tolower (c_chr); + + return (SCM_MAKE_CHAR (c_result)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the uppercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_upcase +{ + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = toupper_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr)); +#endif + } + else + c_result = toupper (c_chr); + + return (SCM_MAKE_CHAR (c_result)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the uppercase version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_upcase +{ + const char *c_str; + char *c_ustr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + c_str = scm_i_string_chars (str); + c_ustr = (char *) alloca (strlen (c_str) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_ustr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str)); +#endif + } + else + str_upcase (c_ustr, c_str); + + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_ustr)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the down-case version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_downcase +{ + const char *c_str; + char *c_lstr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + c_str = scm_i_string_chars (str); + c_lstr = (char *) alloca (strlen (c_str) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_downcase_l (c_lstr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str)); +#endif + } + else + str_downcase (c_lstr, c_str); + + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_lstr)); +} +#undef FUNC_NAME + +/* Note: We don't provide mutative versions of `string-locale-(up|down)case' + because, in some languages, a single downcase character maps to a couple + of uppercase characters. Read the SRFI-13 document for a detailed + discussion about this. */ + + + +/* Locale-dependent number parsing. */ + +SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", + 1, 2, 0, (SCM str, SCM base, SCM locale), + "Convert string @var{str} into an integer according to either " + "@var{locale} (a locale object as returned by @code{make-locale}) " + "or the current process locale. Return two values: an integer " + "(on success) or @code{#f}, and the number of characters read " + "from @var{str} (@code{0} on failure).") +#define FUNC_NAME s_scm_locale_string_to_integer { - char *c_msgid; - char *c_msgid_plural; - unsigned long c_n; - const char *c_result; SCM result; + long c_result; + int c_base; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; - scm_dynwind_begin (0); + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); - c_msgid = scm_to_locale_string (msgid); - scm_dynwind_free (c_msgid); + if (base != SCM_UNDEFINED) + SCM_VALIDATE_INT_COPY (2, base, c_base); + else + c_base = 10; - c_msgid_plural = scm_to_locale_string (msgid_plural); - scm_dynwind_free (c_msgid_plural); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); - c_n = scm_to_ulong (n); - - if (SCM_UNBNDP (domain)) + if (c_locale != NULL) { - /* 3 argument case. */ - c_result = ngettext (c_msgid, c_msgid_plural, c_n); +#ifdef USE_GNU_LOCALE_API + c_result = strtol_l (c_str, &c_endptr, c_base, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtol (c_str, &c_endptr, c_base)); +#endif } else - { - char *c_domain; + c_result = strtol (c_str, &c_endptr, c_base); - c_domain = scm_to_locale_string (domain); - scm_dynwind_free (c_domain); + scm_remember_upto_here (str); - if (SCM_UNBNDP (category)) - { - /* 4 argument case. */ - c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n); - } - else - { - /* 5 argument case. */ - int c_category; - - c_category = scm_i_to_lc_category (category, 0); - c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n, - c_category); - } - } - - if (c_result == c_msgid) - result = msgid; - else if (c_result == c_msgid_plural) - result = msgid_plural; - else - result = scm_from_locale_string (c_result); - - scm_dynwind_end (); - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0, - (SCM domainname), - "If optional parameter @var{domainname} is supplied, " - "set the textdomain. " - "Return the textdomain.") -#define FUNC_NAME s_scm_textdomain -{ - char const *c_result; - char *c_domain; - SCM result = SCM_BOOL_F; - - scm_dynwind_begin (0); - - if (SCM_UNBNDP (domainname)) - c_domain = NULL; - else - { - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); - } - - c_result = textdomain (c_domain); - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (domainname)) - SCM_SYSERROR; - - scm_dynwind_end (); - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0, - (SCM domainname, SCM directory), - "If optional parameter @var{directory} is supplied, " - "set message catalogs to directory @var{directory}. " - "Return the directory bound to @var{domainname}.") -#define FUNC_NAME s_scm_bindtextdomain -{ - char *c_domain; - char *c_directory; - char const *c_result; - SCM result; - - scm_dynwind_begin (0); - - if (SCM_UNBNDP (directory)) - c_directory = NULL; - else - { - c_directory = scm_to_locale_string (directory); - scm_dynwind_free (c_directory); - } - - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); - - c_result = bindtextdomain (c_domain, c_directory); - - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (directory)) - SCM_SYSERROR; - else + if (c_endptr == c_str) result = SCM_BOOL_F; + else + result = scm_from_long (c_result); - scm_dynwind_end (); - return result; + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); } #undef FUNC_NAME -SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0, - (SCM domainname, SCM encoding), - "If optional parameter @var{encoding} is supplied, " - "set encoding for message catalogs of @var{domainname}. " - "Return the encoding of @var{domainname}.") -#define FUNC_NAME s_scm_bind_textdomain_codeset +SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", + 1, 1, 0, (SCM str, SCM locale), + "Convert string @var{str} into an inexact number according to " + "either @var{locale} (a locale object as returned by " + "@code{make-locale}) or the current process locale. Return " + "two values: an inexact number (on success) or @code{#f}, and " + "the number of characters read from @var{str} (@code{0} on " + "failure).") +#define FUNC_NAME s_scm_locale_string_to_inexact { - char *c_domain; - char *c_encoding; - char const *c_result; SCM result; + double c_result; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; - scm_dynwind_begin (0); + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); - if (SCM_UNBNDP (encoding)) - c_encoding = NULL; - else + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) { - c_encoding = scm_to_locale_string (encoding); - scm_dynwind_free (c_encoding); +#ifdef USE_GNU_LOCALE_API + c_result = strtod_l (c_str, &c_endptr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtod (c_str, &c_endptr)); +#endif } - - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); - - c_result = bind_textdomain_codeset (c_domain, c_encoding); - - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (encoding)) - SCM_SYSERROR; else - result = SCM_BOOL_F; + c_result = strtod (c_str, &c_endptr); - scm_dynwind_end (); - return result; + scm_remember_upto_here (str); + + if (c_endptr == c_str) + result = SCM_BOOL_F; + else + result = scm_from_double (c_result); + + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); } #undef FUNC_NAME -void + + +void scm_init_i18n () { - scm_add_feature ("i18n"); + scm_add_feature ("ice-9-i18n"); + +#define _SCM_STRINGIFY_LC(_name) # _name +#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name) + + /* Define all the relevant `_MASK' variables. */ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \ + SCM_I_MAKINUM (LC_ ## _name ## _MASK)); +#include "locale-categories.h" + +#undef SCM_DEFINE_LOCALE_CATEGORY +#undef SCM_STRINGIFY_LC +#undef _SCM_STRINGIFY_LC + + scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK)); + #include "libguile/i18n.x" + +#ifndef USE_GNU_LOCALE_API + scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); +#endif } diff --git a/libguile/i18n.h b/libguile/i18n.h index 1f0cb0852..7d5d9baa9 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -3,7 +3,7 @@ #ifndef SCM_I18N_H #define SCM_I18N_H -/* Copyright (C) 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2006 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 @@ -22,13 +22,24 @@ #include "libguile/__scm.h" -SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category); -SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category); -SCM_API SCM scm_textdomain (SCM domainname); -SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory); -SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding); - -SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all); +SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale); +SCM_API SCM scm_locale_p (SCM obj); +SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_eq (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_char_locale_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale); +SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale); +SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale); +SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale); +SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale); +SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale); SCM_API void scm_init_i18n (void); diff --git a/libguile/init.c b/libguile/init.c index e3a0bc41a..219ef620d 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -65,7 +65,7 @@ #include "libguile/hash.h" #include "libguile/hashtab.h" #include "libguile/hooks.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/iselect.h" #include "libguile/ioext.h" #include "libguile/keywords.h" @@ -479,7 +479,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_properties (); scm_init_hooks (); /* Requires smob_prehistory */ scm_init_gc (); /* Requires hooks, async */ - scm_init_i18n (); + scm_init_gettext (); scm_init_ioext (); scm_init_keywords (); scm_init_list (); diff --git a/libguile/posix.c b/libguile/posix.c index 8a83a1e7e..8129c6413 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -40,7 +40,7 @@ #include "libguile/validate.h" #include "libguile/posix.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/threads.h" @@ -115,6 +115,10 @@ extern char ** environ; #include #endif +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif + #if HAVE_CRYPT_H # include #endif @@ -1380,7 +1384,15 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, } #undef FUNC_NAME +#ifndef USE_GNU_LOCALE_API +/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU + systems (i.e., systems where a reentrant locale API is not available). + See `i18n.c' for details. */ +scm_i_pthread_mutex_t scm_i_locale_mutex; +#endif + #ifdef HAVE_SETLOCALE + SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, (SCM category, SCM locale), "If @var{locale} is omitted, return the current value of the\n" @@ -1409,7 +1421,14 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, scm_dynwind_free (clocale); } +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); +#endif rv = setlocale (scm_i_to_lc_category (category, 1), clocale); +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +#endif + if (rv == NULL) { /* POSIX and C99 don't say anything about setlocale setting errno, so @@ -1943,9 +1962,13 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ -void +void scm_init_posix () { +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL); +#endif + scm_add_feature ("posix"); #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); diff --git a/libguile/posix.h b/libguile/posix.h index 3bef9f96d..871bba850 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -23,8 +23,7 @@ #include "libguile/__scm.h" - - +#include "libguile/threads.h" @@ -87,6 +86,8 @@ SCM_API SCM scm_sethostname (SCM name); SCM_API SCM scm_gethostname (void); SCM_API void scm_init_posix (void); +SCM_API scm_i_pthread_mutex_t scm_i_locale_mutex; + #endif /* SCM_POSIX_H */ /* diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 799f2ee4a..f0384d15a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2006-11-18 Ludovic Courtès + + * Makefile.am (SCM_TESTS): Added `tests/i18n.test'. + + * tests/i18n.test: New file. + 2006-11-17 Neil Jerram * README: Note need for subscription to bug-guile@gnu.org. @@ -6,7 +12,7 @@ * tests/environments.test: Comment out all tests in this file. -2006-10-26 Ludovic Courts +2006-10-26 Ludovic Courtès * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a typo: `thrown' instead of `throw'. @@ -37,7 +43,7 @@ the error+thread tests seem ok now (previously were upset by something leaking out of syntax.test). -2006-09-20 Ludovic Courts +2006-09-20 Ludovic Courtès * tests/srfi-14.test: Use `define-module'. Use modules `(srfi srfi-1)' and `(test-suite lib)'. @@ -82,7 +88,7 @@ * tests/time.test (localtime, mktime, strptime): More tests. -2006-06-13 Ludovic Courts +2006-06-13 Ludovic Courtès * Makefile.am (SCM_TESTS): Added `tests/structs.test'. * tests/structs.test: New file. @@ -145,7 +151,7 @@ * tests/unif.test (make-shared-array): Add example usages from the manual, two of which currently fail. -2006-03-04 Ludovic Courts +2006-03-04 Ludovic Courtès * test-suite/tests/modules.test: New file. * test-suite/Makefile.am (SCM_TESTS): Added it. @@ -193,7 +199,7 @@ * tests/srfi-1.test (lset-difference!): More tests. -2005-10-27 Ludovic Courts +2005-10-27 Ludovic Courtès * tests/socket.test (make-socket-address): New tests. (connect, bind, sendto): Exercise sockaddr object. @@ -724,7 +730,7 @@ * lib.scm (exception:numerical-overflow): New define. * tests/numbers.test (modulo-expt): Use it and exception:wrong-type-arg, avoiding empty "" regexp which is invalid on - BSD. Reported by Andreas Vgele. + BSD. Reported by Andreas Vögele. 2004-05-29 Dirk Herrmann @@ -749,12 +755,12 @@ * tests/srfi-19.test (test-dst, string->date local DST): Test with "EST5EDT" instead of "CET", since HP-UX doesn't know CET. Reported by - Andreas Vgele. + Andreas Vögele. 2004-05-03 Kevin Ryde * tests/time.test (strftime): Force tm:isdst to 0 for the test, for - the benefit of HP-UX. Reported by Andreas Vgele. + the benefit of HP-UX. Reported by Andreas Vögele. Use set-tm:zone rather than a hard coded vector offset. 2004-04-29 Dirk Herrmann @@ -1695,7 +1701,7 @@ 2001-06-16 Marius Vollmer - Thanks to Matthias Kppe! + Thanks to Matthias Köppe! * tests/ports.test: New test for output port line counts. * tests/format.test, tests/optargs.test, tests/srfi-19.test: New @@ -2289,3 +2295,7 @@ Fri Dec 17 12:14:10 1999 Greg J. Badros * lib.scm, guile-test, paths.scm: Log begins. + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 2714eeb1e..c7ec21520 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -43,6 +43,7 @@ SCM_TESTS = tests/alist.test \ tests/guardians.test \ tests/hash.test \ tests/hooks.test \ + tests/i18n.test \ tests/import.test \ tests/interp.test \ tests/list.test \ From 5b3a39c7ff472eee3978784549a6902c09600810 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 18 Nov 2006 18:18:23 +0000 Subject: [PATCH 069/116] Added missing files for `(ice-9 i18n)'. --- ice-9/i18n.scm | 67 +++++++ libguile/gettext.c | 331 +++++++++++++++++++++++++++++++++++ libguile/libgettext.h | 69 ++++++++ libguile/locale-categories.h | 47 +++++ test-suite/tests/i18n.test | 143 +++++++++++++++ 5 files changed, 657 insertions(+) create mode 100644 ice-9/i18n.scm create mode 100644 libguile/gettext.c create mode 100644 libguile/libgettext.h create mode 100644 libguile/locale-categories.h create mode 100644 test-suite/tests/i18n.test diff --git a/ice-9/i18n.scm b/ice-9/i18n.scm new file mode 100644 index 000000000..e782ee21a --- /dev/null +++ b/ice-9/i18n.scm @@ -0,0 +1,67 @@ +;;;; i18n.scm --- internationalization support + +;;;; Copyright (C) 2006 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 2.1 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 + +;;; Author: Ludovic Courts + +;;; Commentary: +;;; +;;; This module provides a number of routines that support +;;; internationalization (e.g., locale-dependent text collation, character +;;; mapping, etc.). It also defines `locale' objects, representing locale +;;; settings, that may be passed around to most of these procedures. +;;; + +;;; Code: + +(define-module (ice-9 i18n) + :export (;; `locale' type + make-locale locale? + + ;; locale category masks (standard) + LC_ALL_MASK + LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK + LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK + + ;; locale category masks (non-standard) + LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK + LC_TELEPHONE_MASK LC_MEASUREMENT_MASK + LC_IDENTIFICATION_MASK + + ;; text collation + string-locale? + string-locale-ci? string-locale-ci=? + + char-locale? + char-locale-ci? char-locale-ci=? + + ;; character mapping + char-locale-downcase char-locale-upcase + string-locale-downcase string-locale-upcase + + ;; reading numbers + locale-string->integer locale-string->inexact)) + + +(load-extension "libguile-i18n-v-0" "scm_init_i18n") + + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; i18n.scm ends here diff --git a/libguile/gettext.c b/libguile/gettext.c new file mode 100644 index 000000000..91a51439c --- /dev/null +++ b/libguile/gettext.c @@ -0,0 +1,331 @@ +/* Copyright (C) 2004, 2006 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 2.1 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 + */ + + +#if HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/dynwind.h" + +#include "libguile/gettext.h" +#include "libgettext.h" +#include + + +int +scm_i_to_lc_category (SCM category, int allow_lc_all) +{ + int c_category = scm_to_int (category); + switch (c_category) + { +#ifdef LC_CTYPE + case LC_CTYPE: +#endif +#ifdef LC_NUMERIC + case LC_NUMERIC: +#endif +#ifdef LC_COLLATE + case LC_COLLATE: +#endif +#ifdef LC_TIME + case LC_TIME: +#endif +#ifdef LC_MONETARY + case LC_MONETARY: +#endif +#ifdef LC_MESSAGES + case LC_MESSAGES: +#endif +#ifdef LC_PAPER + case LC_PAPER: +#endif +#ifdef LC_NAME + case LC_NAME: +#endif +#ifdef LC_ADDRESS + case LC_ADDRESS: +#endif +#ifdef LC_TELEPHONE + case LC_TELEPHONE: +#endif +#ifdef LC_MEASUREMENT + case LC_MEASUREMENT: +#endif +#ifdef LC_IDENTIFICATION + case LC_IDENTIFICATION: +#endif + return c_category; +#ifdef LC_ALL + case LC_ALL: + if (allow_lc_all) + return c_category; +#endif + } + scm_wrong_type_arg (0, 0, category); +} + +SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0, + (SCM msgid, SCM domain, SCM category), + "Return the translation of @var{msgid} in the message domain " + "@var{domain}. @var{domain} is optional and defaults to the " + "domain set through (textdomain). @var{category} is optional " + "and defaults to LC_MESSAGES.") +#define FUNC_NAME s_scm_gettext +{ + char *c_msgid; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + c_msgid = scm_to_locale_string (msgid); + scm_dynwind_free (c_msgid); + + if (SCM_UNBNDP (domain)) + { + /* 1 argument case. */ + c_result = gettext (c_msgid); + } + else + { + char *c_domain; + + c_domain = scm_to_locale_string (domain); + scm_dynwind_free (c_domain); + + if (SCM_UNBNDP (category)) + { + /* 2 argument case. */ + c_result = dgettext (c_domain, c_msgid); + } + else + { + /* 3 argument case. */ + int c_category; + + c_category = scm_i_to_lc_category (category, 0); + c_result = dcgettext (c_domain, c_msgid, c_category); + } + } + + if (c_result == c_msgid) + result = msgid; + else + result = scm_from_locale_string (c_result); + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0, + (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category), + "Return the translation of @var{msgid}/@var{msgid_plural} in the " + "message domain @var{domain}, with the plural form being chosen " + "appropriately for the number @var{n}. @var{domain} is optional " + "and defaults to the domain set through (textdomain). " + "@var{category} is optional and defaults to LC_MESSAGES.") +#define FUNC_NAME s_scm_ngettext +{ + char *c_msgid; + char *c_msgid_plural; + unsigned long c_n; + const char *c_result; + SCM result; + + scm_dynwind_begin (0); + + c_msgid = scm_to_locale_string (msgid); + scm_dynwind_free (c_msgid); + + c_msgid_plural = scm_to_locale_string (msgid_plural); + scm_dynwind_free (c_msgid_plural); + + c_n = scm_to_ulong (n); + + if (SCM_UNBNDP (domain)) + { + /* 3 argument case. */ + c_result = ngettext (c_msgid, c_msgid_plural, c_n); + } + else + { + char *c_domain; + + c_domain = scm_to_locale_string (domain); + scm_dynwind_free (c_domain); + + if (SCM_UNBNDP (category)) + { + /* 4 argument case. */ + c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n); + } + else + { + /* 5 argument case. */ + int c_category; + + c_category = scm_i_to_lc_category (category, 0); + c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n, + c_category); + } + } + + if (c_result == c_msgid) + result = msgid; + else if (c_result == c_msgid_plural) + result = msgid_plural; + else + result = scm_from_locale_string (c_result); + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0, + (SCM domainname), + "If optional parameter @var{domainname} is supplied, " + "set the textdomain. " + "Return the textdomain.") +#define FUNC_NAME s_scm_textdomain +{ + char const *c_result; + char *c_domain; + SCM result = SCM_BOOL_F; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (domainname)) + c_domain = NULL; + else + { + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + } + + c_result = textdomain (c_domain); + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (domainname)) + SCM_SYSERROR; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0, + (SCM domainname, SCM directory), + "If optional parameter @var{directory} is supplied, " + "set message catalogs to directory @var{directory}. " + "Return the directory bound to @var{domainname}.") +#define FUNC_NAME s_scm_bindtextdomain +{ + char *c_domain; + char *c_directory; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (directory)) + c_directory = NULL; + else + { + c_directory = scm_to_locale_string (directory); + scm_dynwind_free (c_directory); + } + + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + + c_result = bindtextdomain (c_domain, c_directory); + + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (directory)) + SCM_SYSERROR; + else + result = SCM_BOOL_F; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0, + (SCM domainname, SCM encoding), + "If optional parameter @var{encoding} is supplied, " + "set encoding for message catalogs of @var{domainname}. " + "Return the encoding of @var{domainname}.") +#define FUNC_NAME s_scm_bind_textdomain_codeset +{ + char *c_domain; + char *c_encoding; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (encoding)) + c_encoding = NULL; + else + { + c_encoding = scm_to_locale_string (encoding); + scm_dynwind_free (c_encoding); + } + + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + + c_result = bind_textdomain_codeset (c_domain, c_encoding); + + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (encoding)) + SCM_SYSERROR; + else + result = SCM_BOOL_F; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +void +scm_init_gettext () +{ + /* When gettext support was first added (in 1.8.0), it provided feature + `i18n'. We keep this as is although the name is a bit misleading + now. */ + scm_add_feature ("i18n"); + +#include "libguile/gettext.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/libgettext.h b/libguile/libgettext.h new file mode 100644 index 000000000..f54b6bff7 --- /dev/null +++ b/libguile/libgettext.h @@ -0,0 +1,69 @@ +/* Convenience header for conditional use of GNU . + Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU Library General Public License as published + by the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, + USA. */ + +#ifndef _LIBGETTEXT_H +#define _LIBGETTEXT_H 1 + +/* NLS can be disabled through the configure --disable-nls option. */ +#if ENABLE_NLS + +/* Get declarations of GNU message catalog functions. */ +# include + +#else + +/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which + chokes if dcgettext is defined as a macro. So include it now, to make + later inclusions of a NOP. We don't include + as well because people using "gettext.h" will not include , + and also including would fail on SunOS 4, whereas + is OK. */ +#if defined(__sun) +# include +#endif + +/* Disabled NLS. + The casts to 'const char *' serve the purpose of producing warnings + for invalid uses of the value returned from these functions. + On pre-ANSI systems without 'const', the config.h file is supposed to + contain "#define const". */ +# define gettext(Msgid) ((const char *) (Msgid)) +# define dgettext(Domainname, Msgid) ((const char *) (Msgid)) +# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid)) +# define ngettext(Msgid1, Msgid2, N) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define dngettext(Domainname, Msgid1, Msgid2, N) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define textdomain(Domainname) ((const char *) (Domainname)) +# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname)) +# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset)) + +#endif + +/* A pseudo function call that serves as a marker for the automated + extraction of messages, but does not call gettext(). The run-time + translation is done at a different place in the code. + The argument, String, should be a literal string. Concatenated strings + and other string expressions won't work. + The macro's expansion is not parenthesized, so that it is suitable as + initializer for static 'char[]' or 'const char[]' variables. */ +#define gettext_noop(String) String + +#endif /* _LIBGETTEXT_H */ diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h new file mode 100644 index 000000000..cec91fb91 --- /dev/null +++ b/libguile/locale-categories.h @@ -0,0 +1,47 @@ +/* Copyright (C) 2006 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 2.1 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 + */ + +/* A list of all available locale categories, not including `ALL'. */ + + +/* The six standard categories, as defined in IEEE Std 1003.1-2001. */ +SCM_DEFINE_LOCALE_CATEGORY (COLLATE) +SCM_DEFINE_LOCALE_CATEGORY (CTYPE) +SCM_DEFINE_LOCALE_CATEGORY (MESSAGES) +SCM_DEFINE_LOCALE_CATEGORY (MONETARY) +SCM_DEFINE_LOCALE_CATEGORY (NUMERIC) +SCM_DEFINE_LOCALE_CATEGORY (TIME) + +/* Additional non-standard categories. */ +#ifdef LC_PAPER +SCM_DEFINE_LOCALE_CATEGORY (PAPER) +#endif +#ifdef LC_NAME +SCM_DEFINE_LOCALE_CATEGORY (NAME) +#endif +#ifdef LC_ADDRESS +SCM_DEFINE_LOCALE_CATEGORY (ADDRESS) +#endif +#ifdef LC_TELEPHONE +SCM_DEFINE_LOCALE_CATEGORY (TELEPHONE) +#endif +#ifdef LC_MEASUREMENT +SCM_DEFINE_LOCALE_CATEGORY (MEASUREMENT) +#endif +#ifdef LC_IDENTIFICATION +SCM_DEFINE_LOCALE_CATEGORY (IDENTIFICATION) +#endif diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test new file mode 100644 index 000000000..fca99c768 --- /dev/null +++ b/test-suite/tests/i18n.test @@ -0,0 +1,143 @@ +;;;; i18n.test --- Exercise the i18n API. +;;;; +;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Ludovic Courts +;;;; +;;;; 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 2.1 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 + +(define-module (test-suite i18n) + :use-module (ice-9 i18n) + :use-module (test-suite lib)) + +;; Start from a pristine locale state. +(setlocale LC_ALL "C") + + +(with-test-prefix "locale objects" + + (pass-if "make-locale (2 args)" + (not (not (make-locale LC_ALL_MASK "C")))) + + (pass-if "make-locale (3 args)" + (not (not (make-locale LC_COLLATE_MASK "C" + (make-locale LC_MESSAGES_MASK "C"))))) + + (pass-if "locale?" + (and (locale? (make-locale LC_ALL_MASK "C")) + (locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C" + (make-locale LC_CTYPE_MASK "C")))))) + + + +(with-test-prefix "text collation (English)" + + (pass-if "string-locale?" + (under-french-locale-or-unresolved + (lambda () + (and (string-locale-ci? "HiVeR" "t" %french-locale))))) + + (pass-if "char-locale-ci<>?" + (under-french-locale-or-unresolved + (lambda () + (and (char-locale-ci? #\h #\ %french-locale)))))) + + +(with-test-prefix "character mapping" + + (pass-if "char-locale-downcase" + (and (eq? #\a (char-locale-downcase #\A)) + (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL_MASK "C"))))) + + (pass-if "char-locale-upcase" + (and (eq? #\Z (char-locale-upcase #\z)) + (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL_MASK "C")))))) + + +(with-test-prefix "number parsing" + + (pass-if "locale-string->integer" + (call-with-values (lambda () (locale-string->integer "123")) + (lambda (result char-count) + (and (equal? result 123) + (equal? char-count 3))))) + + (pass-if "locale-string->inexact" + (call-with-values + (lambda () + (locale-string->inexact "123.456" + (make-locale LC_NUMERIC_MASK "C"))) + (lambda (result char-count) + (and (equal? result 123.456) + (equal? char-count 7)))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: From 22be72d35f90fa94f5dd09444cd891e2bb963cc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 29 Nov 2006 09:05:10 +0000 Subject: [PATCH 070/116] Changes from arch/CVS synchronization --- libguile/ChangeLog | 7 +++++++ libguile/vectors.c | 12 ++++++------ test-suite/ChangeLog | 6 ++++++ test-suite/tests/vectors.test | 12 ++++++++++++ 4 files changed, 31 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cc567810b..e0a50633e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2006-11-29 Ludovic Courtès + + * libguile/vectors.c (scm_vector_to_list): Fixed list + construction: elements were not copied when INC is zero (see + "shared array" example in `vectors.test'). Reported by + Szavai Gyula. + 2006-11-18 Ludovic Courtès * Makefile.am (lib_LTLIBRARIES): Added `libguile-i18n-v-XX.la'. diff --git a/libguile/vectors.c b/libguile/vectors.c index 7a6fdfd92..fef48cc3e 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -392,15 +392,15 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, SCM res = SCM_EOL; const SCM *data; scm_t_array_handle handle; - size_t i, len; + size_t i, count, len; ssize_t inc; data = scm_vector_elements (v, &handle, &len, &inc); - for (i = len*inc; i > 0;) - { - i -= inc; - res = scm_cons (data[i], res); - } + for (i = (len - 1) * inc, count = 0; + count < len; + i -= inc, count++) + res = scm_cons (data[i], res); + scm_array_handle_release (&handle); return res; } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f0384d15a..aad8a1c0e 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2006-11-29 Ludovic Courtès + + * test-suite/tests/vectors.test: Use `define-module'. + (vector->list): New test prefix. "Shared array" test contributed + by Szavai Gyula. + 2006-11-18 Ludovic Courtès * Makefile.am (SCM_TESTS): Added `tests/i18n.test'. diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index 1fb16bcb0..738a0828a 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -17,6 +17,8 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA +(define-module (test-suite vectors) + :use-module (test-suite lib)) ;; FIXME: As soon as guile supports immutable vectors, this has to be ;; replaced with the appropriate error type and message. @@ -29,3 +31,13 @@ (expect-fail-exception "vector constant" exception:immutable-vector (vector-set! '#(1 2 3) 0 4))) + +(with-test-prefix "vector->list" + + (pass-if "simple vector" + (equal? '(1 2 3) (vector->list #(1 2 3)))) + + (pass-if "shared array" + (let ((b (make-shared-array #(1) (lambda (x) '(0)) 2))) + (equal? b (list->vector (vector->list b)))))) + From f30e1bdf97ae8b2b2918da585f887a4d3a23a347 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Dec 2006 14:01:40 +0000 Subject: [PATCH 071/116] Changes from arch/CVS synchronization --- libguile/ChangeLog | 13 +++++++++++++ libguile/unif.c | 14 +++++++++----- test-suite/ChangeLog | 6 ++++++ test-suite/tests/unif.test | 38 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 66 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e0a50633e..8ba446c6c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2006-12-12 Ludovic Courtès + + * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES + instead of RES (reported by Gyula Szavai). This allows the use of + negative lower bounds. + (scm_i_read_array): Make sure LEN is non-negative (reported by + Gyula Szavai). + + (scm_array_in_bounds_p): Iterate over S instead of always + comparing indices with the bounds of S[0]. This fixes + `array-in-bounds?' for arrays with a rank greater than one and + with different lower bounds for each dimension. + 2006-11-29 Ludovic Courtès * libguile/vectors.c (scm_vector_to_list): Fixed list diff --git a/libguile/unif.c b/libguile/unif.c index 7f01f62dd..d61532bb0 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1150,10 +1150,10 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) { - size_t k = SCM_I_ARRAY_NDIM (v); + size_t k, ndim = SCM_I_ARRAY_NDIM (v); scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); - while (k > 0) + for (k = 0; k < ndim; k++) { long ind; @@ -1161,9 +1161,8 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, SCM_WRONG_NUM_ARGS (); ind = scm_to_long (SCM_CAR (args)); args = SCM_CDR (args); - k -= 1; - if (ind < s->lbnd || ind > s->ubnd) + if (ind < s[k].lbnd || ind > s[k].ubnd) { res = SCM_BOOL_F; /* We do not stop the checking after finding a violation @@ -2669,7 +2668,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) } if (got_it) - *resp = res; + *resp = sign * res; return c; } @@ -2753,6 +2752,11 @@ scm_i_read_array (SCM port, int c) { c = scm_getc (port); c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index aad8a1c0e..cd2141c0d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2006-12-12 Ludovic Courtès + + * tests/unif.test (syntax): New test prefix. Check syntax for + negative lower bounds and negative lengths (reported by Gyula + Szavai) as well as `array-in-bounds?'. + 2006-11-29 Ludovic Courtès * test-suite/tests/vectors.test: Use `define-module'. diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 2a0048483..576a9286c 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -26,6 +26,10 @@ (define exception:wrong-num-indices (cons 'misc-error "^wrong number of indices.*")) +(define exception:length-non-negative + (cons 'read-error ".*array length must be non-negative.*")) + + (with-test-prefix "array?" (let ((bool (make-typed-array 'b #t '(5 6))) @@ -513,7 +517,41 @@ (array-set! a -128 0) (= -128 (uniform-vector-ref a 0))))))) +;;; +;;; syntax +;;; + +(with-test-prefix "syntax" + + (pass-if "rank and lower bounds" + ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8. + (let ((a '#2u32@2@7((1 2) (3 4)))) + (and (array? a) + (typed-array? a 'u32) + (= (array-rank a) 2) + (let loop ((bounds '((2 7) (2 8) (3 7) (3 8))) + (result #t)) + (if (null? bounds) + result + (and result + (loop (cdr bounds) + (apply array-in-bounds? a (car bounds))))))))) + + (pass-if "negative lower bound" + (let ((a '#1@-3(a b))) + (and (array? a) + (= (array-rank a) 1) + (array-in-bounds? a -3) (array-in-bounds? a -2) + (eq? 'a (array-ref a -3)) + (eq? 'b (array-ref a -2))))) + + (pass-if-exception "negative length" exception:length-non-negative + (with-input-from-string "'#1:-3(#t #t)" read))) + + +;;; ;;; equal? with vector and one-dimensional array +;;; (pass-if "vector equal? one-dimensional array" (equal? (make-shared-array #2((a b c) (d e f) (g h i)) From e2bf3b19f666260d2e666a8686fee0ef553b87fb Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sat, 23 Dec 2006 20:35:32 +0000 Subject: [PATCH 072/116] * numbers.c (scm_i_fraction_reduce): move logic into scm_i_make_ratio(), so fractions are only read. scm_i_fraction_reduce() modifies a fraction when reading it. A race condition might lead to fractions being corrupted by reading them concurrently. * numbers.h: remove SCM_FRACTION_SET_NUMERATOR, SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT, SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, SCM_FRACTION_REDUCED. --- libguile/ChangeLog | 17 +++++++++++++++++ libguile/numbers.c | 45 ++++++++++++++------------------------------- libguile/numbers.h | 8 -------- 3 files changed, 31 insertions(+), 39 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8ba446c6c..4fe7b08f7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2006-12-23 Han-Wen Nienhuys + + * numbers.c (scm_i_fraction_reduce): move logic into + scm_i_make_ratio(), so fractions are only read. + scm_i_fraction_reduce() modifies a fraction when reading it. A + race condition might lead to fractions being corrupted by reading + them concurrently. + + Also, the REDUCED bit alters the SCM_CELL_TYPE(), making + comparisons between reduced and unreduced fractions go wrong. + + * numbers.h: remove SCM_FRACTION_SET_NUMERATOR, + SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT, + SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, + SCM_FRACTION_REDUCED. + + 2006-12-12 Ludovic Courtès * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES diff --git a/libguile/numbers.c b/libguile/numbers.c index 2aa2de81b..2a833c83c 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -452,28 +452,21 @@ scm_i_make_ratio (SCM numerator, SCM denominator) /* No, it's a proper fraction. */ - return scm_double_cell (scm_tc16_fraction, - SCM_UNPACK (numerator), - SCM_UNPACK (denominator), 0); + { + SCM divisor = scm_gcd (numerator, denominator); + if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) + { + numerator = scm_divide (numerator, divisor); + denominator = scm_divide (denominator, divisor); + } + + return scm_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0); + } } #undef FUNC_NAME -static void scm_i_fraction_reduce (SCM z) -{ - if (!(SCM_FRACTION_REDUCED (z))) - { - SCM divisor; - divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z)); - if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) - { - /* is this safe? */ - SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor)); - SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor)); - } - SCM_FRACTION_REDUCED_SET (z); - } -} - double scm_i_fraction2double (SCM z) { @@ -2387,7 +2380,6 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, } else if (SCM_FRACTIONP (n)) { - scm_i_fraction_reduce (n); return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), scm_from_locale_string ("/"), scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); @@ -2441,7 +2433,6 @@ int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM str; - scm_i_fraction_reduce (sexp); str = scm_number_to_string (sexp, SCM_UNDEFINED); scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port); scm_remember_upto_here_1 (str); @@ -3109,8 +3100,6 @@ scm_complex_equalp (SCM x, SCM y) SCM scm_i_fraction_equalp (SCM x, SCM y) { - scm_i_fraction_reduce (x); - scm_i_fraction_reduce (y); if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_NUMERATOR (y))) || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), @@ -5424,10 +5413,7 @@ scm_numerator (SCM z) else if (SCM_BIGP (z)) return z; else if (SCM_FRACTIONP (z)) - { - scm_i_fraction_reduce (z); - return SCM_FRACTION_NUMERATOR (z); - } + return SCM_FRACTION_NUMERATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z))); else @@ -5446,10 +5432,7 @@ scm_denominator (SCM z) else if (SCM_BIGP (z)) return SCM_I_MAKINUM (1); else if (SCM_FRACTIONP (z)) - { - scm_i_fraction_reduce (z); - return SCM_FRACTION_DENOMINATOR (z); - } + return SCM_FRACTION_DENOMINATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z))); else diff --git a/libguile/numbers.h b/libguile/numbers.h index 8448b7fd2..2c2fdcf07 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -157,14 +157,6 @@ #define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction) #define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x)) #define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x)) -#define SCM_FRACTION_SET_NUMERATOR(x, v) (SCM_SET_CELL_OBJECT_1 ((x), (v))) -#define SCM_FRACTION_SET_DENOMINATOR(x, v) (SCM_SET_CELL_OBJECT_2 ((x), (v))) - - /* I think the left half word is free in the type, so I'll use bit 17 */ -#define SCM_FRACTION_REDUCED_BIT 0x10000 -#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT))) -#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT))) -#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x)) From c6a576f7669b27c05405fe65abca015d50a01c1a Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sun, 24 Dec 2006 01:05:56 +0000 Subject: [PATCH 073/116] ("equal?"): add case for reduction of rational numbers. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/numbers.test | 12 ++++++++++++ 2 files changed, 17 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index cd2141c0d..11018c308 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2006-12-24 Han-Wen Nienhuys + + * tests/numbers.test ("equal?"): add case for reduction of + rational numbers. + 2006-12-12 Ludovic Courtès * tests/unif.test (syntax): New test prefix. Check syntax for diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 78d130a2b..fd1ced2d2 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3180,3 +3180,15 @@ (pass-if "-100i swings back to 45deg down" (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) + +;; +;; equal? +;; + + +(with-test-prefix "equal?" + (pass-if + + ;; lazy reduction bit for rationals should not affect equal? + (equal? 1/2 ((lambda (x) (denominator x) x) 1/2)))) + From 73cc2740d456a5d50c0a140748a8da2cc9b283c0 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Wed, 3 Jan 2007 17:23:15 +0000 Subject: [PATCH 074/116] (Module): only try to run render-bugs if it exists. --- ChangeLog | 4 ++++ autogen.sh | 6 ++++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 033d75140..20476aaca 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2007-01-03 Han-Wen Nienhuys + + * autogen.sh (Module): only try to run render-bugs if it exists. + 2006-11-18 Ludovic Courtès * GUILE-VERSION: Added `LIBGUILE_I18N_*'. diff --git a/autogen.sh b/autogen.sh index 90dc4805f..18e639b8c 100755 --- a/autogen.sh +++ b/autogen.sh @@ -31,8 +31,10 @@ ln -s $workbook/build/dist-files/.gdbinit examples/example.gdbinit # TODO: This should be moved to dist-guile mscripts=../guile-scripts -rm -f BUGS -$mscripts/render-bugs > BUGS +if test -x $mscripts/render-bugs ; then + rm -f BUGS + $mscripts/render-bugs > BUGS +fi ###################################################################### ### update infrastructure From 93632e3cfda6f7bbd55b85096d5fe1a3b3bdacd5 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Wed, 3 Jan 2007 17:26:32 +0000 Subject: [PATCH 075/116] (s_scm_gc_stats): return an entry for total-cells-allocated too. (gc_update_stats): update scm_gc_cells_allocated_acc too. --- libguile/ChangeLog | 6 ++++++ libguile/gc.c | 16 ++++++++++++++-- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4fe7b08f7..ac65cbb3b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2007-01-03 Han-Wen Nienhuys + + * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated + too. + (gc_update_stats): update scm_gc_cells_allocated_acc too. + 2006-12-23 Han-Wen Nienhuys * numbers.c (scm_i_fraction_reduce): move logic into diff --git a/libguile/gc.c b/libguile/gc.c index ead6d30be..915098904 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -208,6 +208,7 @@ unsigned long scm_mtrigger; /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; +unsigned long scm_last_cells_allocated = 0; unsigned long scm_mallocated = 0; /* Global GC sweep statistics since the last full GC. */ @@ -217,6 +218,7 @@ static scm_t_sweep_statistics scm_i_gc_sweep_stats_1 = { 0, 0 }; /* Total count of cells marked/swept. */ static double scm_gc_cells_marked_acc = 0.; static double scm_gc_cells_swept_acc = 0.; +static double scm_gc_cells_allocated_acc = 0.; static unsigned long scm_gc_time_taken = 0; static unsigned long t_before_gc; @@ -246,8 +248,7 @@ SCM_SYMBOL (sym_cells_swept, "cells-swept"); SCM_SYMBOL (sym_malloc_yield, "malloc-yield"); SCM_SYMBOL (sym_cell_yield, "cell-yield"); SCM_SYMBOL (sym_protected_objects, "protected-objects"); - - +SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated"); /* Number of calls to SCM_NEWCELL since startup. */ @@ -318,6 +319,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, unsigned long int local_protected_obj_count; double local_scm_gc_cells_swept; double local_scm_gc_cells_marked; + double local_scm_total_cells_allocated; SCM answer; unsigned long *bounds = 0; int table_size = scm_i_heap_segment_table_size; @@ -359,6 +361,9 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, +(double) scm_i_gc_sweep_stats.swept -(double) scm_i_gc_sweep_stats.collected; + local_scm_total_cells_allocated = scm_gc_cells_allocated_acc + + (double) (scm_cells_allocated - scm_last_cells_allocated); + for (i = table_size; i--;) { heap_segs = scm_cons (scm_cons (scm_from_ulong (bounds[2*i]), @@ -372,6 +377,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, scm_from_ulong (local_scm_gc_time_taken)), scm_cons (sym_cells_allocated, scm_from_ulong (local_scm_cells_allocated)), + scm_cons (sym_total_cells_allocated, + scm_from_double (local_scm_total_cells_allocated)), scm_cons (sym_heap_size, scm_from_ulong (local_scm_heap_size)), scm_cons (sym_mallocated, @@ -393,6 +400,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, scm_cons (sym_protected_objects, scm_from_ulong (local_protected_obj_count)), scm_cons (sym_heap_segments, heap_segs), + SCM_UNDEFINED); SCM_CRITICAL_SECTION_END; @@ -422,7 +430,11 @@ gc_update_stats (scm_t_sweep_statistics sweep_stats) abort (); } + scm_gc_cells_allocated_acc += + (double) (scm_cells_allocated - scm_last_cells_allocated); + scm_cells_allocated -= sweep_stats.collected; + scm_last_cells_allocated = scm_cells_allocated; } static void From 391f57e6ad53a2855b4f3ab270edd328da275dfd Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sat, 6 Jan 2007 18:20:35 +0000 Subject: [PATCH 076/116] (s_scm_read_hash_extend): document #f argument to read-hash-extend. --- libguile/ChangeLog | 5 +++++ libguile/read.c | 4 +++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ac65cbb3b..882c8074d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2007-01-06 Han-Wen Nienhuys + + * read.c (s_scm_read_hash_extend): document #f argument to + read-hash-extend. + 2007-01-03 Han-Wen Nienhuys * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated diff --git a/libguile/read.c b/libguile/read.c index d75839589..53283ad62 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -898,7 +898,9 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, "starting with the character sequence @code{#} and @var{chr}.\n" "@var{proc} will be called with two arguments: the character\n" "@var{chr} and the port to read further data from. The object\n" - "returned will be the return value of @code{read}.") + "returned will be the return value of @code{read}. \n" + "Passing @code{#f} for @var{proc} will remove a previous setting. \n" + ) #define FUNC_NAME s_scm_read_hash_extend { SCM this; From a2c40dc7c0c52eaf6a58660a7c44665fdebba252 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Wed, 10 Jan 2007 11:42:04 +0000 Subject: [PATCH 077/116] (scm_ithrow): print out key symbol and string arguments when error happens inside a critical section, and document why. --- libguile/ChangeLog | 5 +++++ libguile/throw.c | 18 ++++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 882c8074d..b2244a975 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2007-01-10 Han-Wen Nienhuys + + * throw.c (scm_ithrow): print out key symbol and string arguments + when error happens inside a critical section, and document why. + 2007-01-06 Han-Wen Nienhuys * read.c (s_scm_read_hash_extend): document #f argument to diff --git a/libguile/throw.c b/libguile/throw.c index 115bb0c03..86e4d1fa7 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -37,6 +37,7 @@ #include "libguile/validate.h" #include "libguile/throw.h" #include "libguile/init.h" +#include "libguile/strings.h" /* the jump buffer data structure */ @@ -695,7 +696,24 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) if (scm_i_critical_section_level) { + SCM s = args; + int i = 0; + + /* + We have much better routines for displaying Scheme, but we're + already inside a pernicious error, and it's unlikely that they + are available to us. We try to print something useful anyway, + so users don't need a debugger to find out what went wrong. + */ fprintf (stderr, "throw from within critical section.\n"); + if (scm_is_symbol (key)) + fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key)); + + + for (; scm_is_pair (s); s = scm_cdr (s), i++) + if (scm_is_string (scm_car (s))) + fprintf (stderr, "argument %d: %s\n", i, scm_i_string_chars (scm_car (s))); + abort (); } From 329e03949c777c1e19a005177333d7dd632ac72c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 22:54:26 +0000 Subject: [PATCH 078/116] merge from 1.8 --- Makefile.am | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index ab72bed9f..98b1c7e4a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,7 +19,10 @@ ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA -AUTOMAKE_OPTIONS = 1.5 +# want automake 1.10 or higher so that AM_GNU_GETTEXT can tell automake that +# config.rpath is needed +# +AUTOMAKE_OPTIONS = 1.10 SUBDIRS = oop libguile ice-9 guile-config guile-readline emacs \ scripts srfi doc examples test-suite benchmark-suite lang am From 01ec9e9459bf4b83fa064785bf7456ce72e17049 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 22:56:45 +0000 Subject: [PATCH 079/116] *** empty log message *** --- ChangeLog | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/ChangeLog b/ChangeLog index 20476aaca..c42959184 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,45 @@ * autogen.sh (Module): only try to run render-bugs if it exists. +2006-12-27 Kevin Ryde + + * configure.in (pthread_get_stackaddr_np, pthread_sigmask): New tests. + +2006-12-24 Han-Wen Nienhuys + + * autogen.sh (mscripts): only execute render-bugs if it exists. + +2006-12-23 Kevin Ryde + + * configure.in (-lm): No need to suppress libm on mingw, it's not + needed because it's empty, but including it does no harm. + (-lm): Look for "cos" instead of "main", since cos and friends are the + purpose of looking for libm. + (winsock etc): Test $host = *-*-mingw* rather than $MINGW32, autoconf + regards the latter as obsolete. + (AC_MINGW32): Remove test, $MINGW32 now unused. + (uint32_t): Look at HAVE_NETDB_H rather than hard-coding __MINGW32__ + in the test program. + +2006-12-15 Kevin Ryde + + * configure.in (process.h, pipe, _pipe): New checks. + +2006-12-14 Kevin Ryde + + * configure.in (struct timespec, pthread.h): Look for struct timespec + in as well as , it's in pthread.h on mingw. + Reported by Nils Durner. + +2006-12-03 Kevin Ryde + + * Makefile.am (AUTOMAKE_OPTIONS): Bump to automake 1.10 required, so + that config.rpath from gettext will go into the dist (and give an + error if not). + + * configure.in (AM_PROG_CC_C_O): New macro, needed by automake 1.10 + for per-target cflags in libguile/Makefile.am. + 2006-11-18 Ludovic Courtès * GUILE-VERSION: Added `LIBGUILE_I18N_*'. From 45c0ff10689a6b0ab8ce27f4ec8c3f8eadb8d74d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:06:45 +0000 Subject: [PATCH 080/116] merge from 1.8 --- NEWS | 26 ++++++++++++++++++++++++++ configure.in | 44 +++++++++++++++++++++++++++++++------------- 2 files changed, 57 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 0200931dd..a68cff011 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,32 @@ Changes in 1.9.XXXXXXXX: * Changes to Scheme functions and syntax * Changes to the C interface + +Changes in 1.8.2 (since 1.8.1): + +* New procedures (see the manual for details) + +** set-program-arguments + +* Bugs fixed + +** Fractions were not `equal?' if stored in unreduced form. +(A subtle problem, since printing a value reduced it, making it work.) +** srfi-60 `copy-bit' failed on 64-bit systems +** "guile --use-srfi" option at the REPL can replace core functions +(Programs run with that option were ok, but in the interactive REPL +the core bindings got priority, preventing SRFI replacements or +extensions.) +** `regexp-exec' doesn't abort() on #\nul in the input or bad flags arg +** `kill' on mingw throws an error for a pid other than oneself +** Procedure names are attached to procedure-with-setters +** Array read syntax works with negative lower bound +** `array-in-bounds?' fix if an array has different lower bounds on each index +** `*' returns exact 0 for "(* inexact 0)" +This follows what it always did for "(* 0 inexact)". +** Build problems on Solaris fixed +** Build problems on Mingw fixed + Changes in 1.8.1 (since 1.8.0): diff --git a/configure.in b/configure.in index 8444f60d2..9792db311 100644 --- a/configure.in +++ b/configure.in @@ -55,7 +55,6 @@ AC_CONFIG_SUBDIRS(guile-readline) dnl Some more checks for Win32 AC_CYGWIN -AC_MINGW32 AC_LIBTOOL_WIN32_DLL AC_PROG_INSTALL @@ -68,6 +67,8 @@ AC_ISC_POSIX AC_MINIX AM_PROG_CC_STDC +# for per-target cflags in the libguile subdir +AM_PROG_CC_C_O AC_LIBTOOL_DLOPEN AC_PROG_LIBTOOL @@ -528,8 +529,9 @@ AC_HEADER_SYS_WAIT # Reasons for testing: # complex.h - new in C99 # fenv.h - available in C99, but not older systems +# process.h - mingw specific # -AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h string.h \ +AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.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 \ @@ -560,9 +562,11 @@ AC_TYPE_GETGROUPS AC_TYPE_SIGNAL AC_TYPE_MODE_T -if test $MINGW32 = no; then - AC_CHECK_LIB(m, main) -fi +# On mingw -lm is empty, so this test is unnecessary, but it's +# harmless so we don't hard-code to suppress it. +# +AC_CHECK_LIB(m, cos) + AC_CHECK_FUNCS(gethostbyname) if test $ac_cv_func_gethostbyname = no; then AC_CHECK_LIB(nsl, gethostbyname) @@ -577,7 +581,8 @@ dnl dnl Check for Winsock and other functionality on Win32 (*not* CygWin) dnl EXTRA_DEFS="" -if test "$MINGW32" = "yes" ; then +case $host in + *-*-mingw*) AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1, [Define if you have the header file.])]) AC_CHECK_LIB(ws2_32, main) @@ -591,7 +596,8 @@ if test "$MINGW32" = "yes" ; then AC_DEFINE(USE_DLL_IMPORT, 1, [Define if you need additional CPP macros on Win32 platforms.]) fi -fi + ;; +esac AC_SUBST(EXTRA_DEFS) # Reasons for testing: @@ -610,6 +616,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # has it as an inline for chsize) # ioctl - not in mingw. # gmtime_r - recent posix, not on old systems +# pipe - not in mingw +# _pipe - specific to mingw, taking 3 args # readdir_r - recent posix, not on old systems # stat64 - SuS largefile stuff, not on old systems # sysconf - not on old systems @@ -618,15 +626,17 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # _NSGetEnviron - Darwin specific # strcoll_l, newlocale - GNU extensions (glibc) # -AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate 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 truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe 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 truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale]) # Reasons for testing: # netdb.h - not in mingw # 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. # sethostname - the function itself check because it's not in mingw, # the DECL is checked because Solaris 10 doens't have in any header # -AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h) +AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) AC_CHECK_DECLS([sethostname]) @@ -794,7 +804,7 @@ AC_CACHE_VAL(guile_cv_have_uint32_t, #if HAVE_STDINT_H #include #endif - #ifndef __MINGW32__ + #ifndef HAVE_NETDB_H #include #endif], [uint32_t a;], @@ -1035,17 +1045,22 @@ if test $scm_cv_struct_linger = yes; then fi +# On mingw, struct timespec is in . +# AC_MSG_CHECKING(for struct timespec) AC_CACHE_VAL(scm_cv_struct_timespec, AC_TRY_COMPILE([ -#include ], +#include +#if HAVE_PTHREAD_H +#include +#endif], [struct timespec t; t.tv_nsec = 100], scm_cv_struct_timespec="yes", scm_cv_struct_timespec="no")) AC_MSG_RESULT($scm_cv_struct_timespec) if test $scm_cv_struct_timespec = yes; then AC_DEFINE(HAVE_STRUCT_TIMESPEC, 1, - [Define this if your system defines struct timespec via .]) + [Define this if your system defines struct timespec via either or .]) fi #-------------------------------------------------------------------- @@ -1079,8 +1094,11 @@ case "$with_threads" in # Reasons for testing: # pthread_getattr_np - "np" meaning "non portable" says it # 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_sigmask - not available on mingw # - AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np) + AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_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 };". From 2039f7be7dddf59829a25a0263ac56944e14f970 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:07:49 +0000 Subject: [PATCH 081/116] avoid tab/space difference from 1.8 --- configure.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.in b/configure.in index 9792db311..d2eca30cc 100644 --- a/configure.in +++ b/configure.in @@ -29,7 +29,7 @@ AC_PREREQ(2.53) AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}), m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}), - [bug-guile@gnu.org]) + [bug-guile@gnu.org]) AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(GUILE-VERSION) AM_INIT_AUTOMAKE([no-define]) From 9a18d8d431e4d3d9f524bb6d20611c8693e47d6c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:22:36 +0000 Subject: [PATCH 082/116] merge from 1.8 --- doc/ref/ChangeLog | 29 +++++++++++++++ doc/ref/api-control.texi | 2 +- doc/ref/api-data.texi | 4 +-- doc/ref/api-init.texi | 6 ++-- doc/ref/posix.texi | 74 ++++++++++++++++++++++++++++++++++----- doc/ref/srfi-modules.texi | 71 ++++++++++++++++++++++++++++--------- guile-config/ChangeLog | 6 ++++ guile-config/Makefile.am | 4 +-- ice-9/ChangeLog | 18 ++++++++++ ice-9/boot-9.scm | 44 +++++++++++++---------- 10 files changed, 207 insertions(+), 51 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 8b8e0befe..9ffa06b25 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,32 @@ +2007-01-16 Kevin Ryde + + * api-data.texi (Mapping Folding and Unfolding): In string-unfold, + ssay make_final default is nothing extra. The `(lambda (x) )' shown + was not quite right, it would have been `(lambda (x) "")' if anything. + + * api-init.texi (Initialization): Cross reference Runtime Environment + for scm_set_program_arguments. + + * posix.texi (Runtime Environment): Expand program-arguments + description, add set-program-arguments, add scm_set_program_arguments, + note args are per-thread. + +2006-12-14 Kevin Ryde + + * api-procedures.texi (let-keywords Reference): Expand variously to + make it clear what's actually taken and done. Shortfalls reported by + Han-Wen Nienhuys. + +2006-12-13 Kevin Ryde + + * api-control.texi (Handling Errors): Cross reference "Error + Reporting" for `scm-error', not just "above". + + * posix.texi (Encryption): Cross reference crypt in the glibc manual. + Clarify that key and salt are strings. + + * srfi-modules.texi (SRFI-17): Expand variously. + 2006-11-18 Ludovic Courtès * Makefile.am (BUILT_SOURCES): New variable. diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 11a276a13..512733cd5 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1476,7 +1476,7 @@ In the following C functions, @var{SUBR} and @var{MESSAGE} parameters can be @code{NULL} to give the effect of @code{#f} described above. @deftypefn {C Function} SCM scm_error (SCM @var{key}, char *@var{subr}, char *@var{message}, SCM @var{args}, SCM @var{rest}) -Throw an error, as per @code{scm-error} above. +Throw an error, as per @code{scm-error} (@pxref{Error Reporting}). @end deftypefn @deftypefn {C Function} void scm_syserror (char *@var{subr}) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index abcb28de1..0b31b15e3 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -3525,7 +3525,7 @@ string. @item @var{make_final} is applied to the terminal seed value (on which @var{p} returns true) to produce the final/rightmost portion of the constructed string. -It defaults to @code{(lambda (x) )}. +The default is nothing extra. @end itemize @end deffn diff --git a/doc/ref/api-init.texi b/doc/ref/api-init.texi index 26e6e71ef..0e4e8b8b7 100644 --- a/doc/ref/api-init.texi +++ b/doc/ref/api-init.texi @@ -1,12 +1,13 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Initialization @section Initializing Guile +@cindex Initializing Guile Each thread that wants to use functions from the Guile API needs to put itself into guile mode with either @code{scm_with_guile} or @@ -93,7 +94,8 @@ The function @code{scm_boot_guile} arranges for the Scheme @code{command-line} function to return the strings given by @var{argc} and @var{argv}. If @var{main_func} modifies @var{argc} or @var{argv}, it should call @code{scm_set_program_arguments} with the final list, so -Scheme code will know which arguments have been processed. +Scheme code will know which arguments have been processed +(@pxref{Runtime Environment}). @end deftypefn @deftypefn {C Function} void scm_shell (int @var{argc}, char **@var{argv}) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 6f496fe8d..31ca20b0d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1348,15 +1348,72 @@ included but subprocesses are not. @deffn {Scheme Procedure} program-arguments @deffnx {Scheme Procedure} command-line +@deffnx {Scheme Procedure} set-program-arguments @deffnx {C Function} scm_program_arguments () +@deffnx {C Function} scm_set_program_arguments_scm (lst) @cindex command line @cindex program arguments -Return the list of command line arguments passed to Guile, as a list of -strings. The list includes the invoked program name, which is usually -@code{"guile"}, but excludes switches and parameters for command line -options like @code{-e} and @code{-l}. +Get the command line arguments passed to Guile, or set new arguments. + +The arguments are a list of strings, the first of which is the invoked +program name. This is just @nicode{"guile"} (or the executable path) +when run interactively, or it's the script name when running a script +with @option{-s} (@pxref{Invoking Guile}). + +@example +guile -L /my/extra/dir -s foo.scm abc def + +(program-arguments) @result{} ("foo.scm" "abc" "def") +@end example + +@code{set-program-arguments} allows a library module or similar to +modify the arguments, for example to strip options it recognises, +leaving the rest for the mainline. + +The argument list is held in a fluid, which means it's separate for +each thread. Neither the list nor the strings within it are copied at +any point and normally should not be mutated. + +The two names @code{program-arguments} and @code{command-line} are an +historical accident, they both do exactly the same thing. The name +@code{scm_set_program_arguments_scm} has an extra @code{_scm} on the +end to avoid clashing with the C function below. @end deffn +@deftypefn {C Function} void scm_set_program_arguments (int argc, char **argv, char *first) +@cindex command line +@cindex program arguments +Set the list of command line arguments for @code{program-arguments} +and @code{command-line} above. + +@var{argv} is an array of null-terminated strings, as in a C +@code{main} function. @var{argc} is the number of strings in +@var{argv}, or if it's negative then a @code{NULL} entry in @var{argv} +marks its end. + +@var{first} is an extra string put at the start of the arguments, or +@code{NULL} for no such extra. This is a convenient way to pass the +program name after advancing @var{argv} to strip option arguments. + +@example +@{ + char *progname = argv[0]; + int i; + for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++) + @{ + /* munch option ... */ + @} + /* remaining args for scheme level use */ + scm_set_program_arguments (-1, argv, progname); +@} +@end example + +This sort of thing is often done at startup under +@code{scm_boot_guile} with any options handled at the C level removed. +The given strings are all copied, so the C data is not accessed again +once @code{scm_set_program_arguments} returns. +@end deftypefn + @deffn {Scheme Procedure} getenv nam @deffnx {C Function} scm_getenv (nam) @cindex environment @@ -3174,12 +3231,13 @@ Please note that the procedures in this section are not suited for strong encryption, they are only interfaces to the well-known and common system library functions of the same name. They are just as good (or bad) as the underlying functions, so you should refer to your system -documentation before using them. +documentation before using them (@pxref{crypt,, Encrypting Passwords, +libc, The GNU C Library Reference Manual}). @deffn {Scheme Procedure} crypt key salt @deffnx {C Function} scm_crypt (key, salt) -Encrypt @var{key} using @var{salt} as the salt value to the -crypt(3) library call. +Encrypt @var{key}, with the addition of @var{salt} (both strings), +using the @code{crypt} C library call. @end deffn Although @code{getpass} is not an encryption procedure per se, it diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 8a027c00b..61c105c5b 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1616,24 +1616,61 @@ applied to zero arguments, yields 1. @subsection SRFI-17 - Generalized set! @cindex SRFI-17 -This is an implementation of SRFI-17: Generalized set! +This SRFI implements a generalized @code{set!}, allowing some +``referencing'' functions to be used as the target location of a +@code{set!}. This feature is available from -@findex getter-with-setter -It exports the Guile procedure @code{make-procedure-with-setter} under -the SRFI name @code{getter-with-setter} and exports the standard -procedures @code{car}, @code{cdr}, @dots{}, @code{cdddr}, -@code{string-ref} and @code{vector-ref} as procedures with setters, as -required by the SRFI. +@example +(use-modules (srfi srfi-17)) +@end example -SRFI-17 was heavily criticized during its discussion period but it was -finalized anyway. One issue was its concept of globally associating -setter @dfn{properties} with (procedure) values, which is non-Schemy. -For this reason, this implementation chooses not to provide a way to set -the setter of a procedure. In fact, @code{(set! (setter @var{proc}) -@var{setter})} signals an error. The only way to attach a setter to a -procedure is to create a new object (a @dfn{procedure with setter}) via -the @code{getter-with-setter} procedure. This procedure is also -specified in the SRFI. Using it avoids the described problems. +@noindent +For example @code{vector-ref} is extended so that + +@example +(set! (vector-ref vec idx) new-value) +@end example + +@noindent +is equivalent to + +@example +(vector-set! vec idx new-value) +@end example + +The idea is that a @code{vector-ref} expression identifies a location, +which may be either fetched or stored. The same form is used for the +location in both cases, encouraging visual clarity. This is similar +to the idea of an ``lvalue'' in C. + +The mechanism for this kind of @code{set!} is in the Guile core +(@pxref{Procedures with Setters}). This module adds definitions of +the following functions as procedures with setters, allowing them to +be targets of a @code{set!}, + +@quotation +@nicode{car}, @nicode{cdr}, @nicode{caar}, @nicode{cadr}, +@nicode{cdar}, @nicode{cddr}, @nicode{caaar}, @nicode{caadr}, +@nicode{cadar}, @nicode{caddr}, @nicode{cdaar}, @nicode{cdadr}, +@nicode{cddar}, @nicode{cdddr}, @nicode{caaaar}, @nicode{caaadr}, +@nicode{caadar}, @nicode{caaddr}, @nicode{cadaar}, @nicode{cadadr}, +@nicode{caddar}, @nicode{cadddr}, @nicode{cdaaar}, @nicode{cdaadr}, +@nicode{cdadar}, @nicode{cdaddr}, @nicode{cddaar}, @nicode{cddadr}, +@nicode{cdddar}, @nicode{cddddr} + +@nicode{string-ref}, @nicode{vector-ref} +@end quotation + +The SRFI specifies @code{setter} (@pxref{Procedures with Setters}) as +a procedure with setter, allowing the setter for a procedure to be +changed, eg.@: @code{(set! (setter foo) my-new-setter-handler)}. +Currently Guile does not implement this, a setter can only be +specified on creation (@code{getter-with-setter} below). + +@defun getter-with-setter +The same as the Guile core @code{make-procedure-with-setter} +(@pxref{Procedures with Setters}). +@end defun @node SRFI-19 diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index de7091980..65cea517c 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,9 @@ +2007-01-04 Kevin Ryde + + * Makefile.am (guile-config): Use "|" as the sed delimiter, for the + benefit of DOS systems where $(bindir) might include a drive letter + like "c:". + 2006-09-19 Rob Browning * guile-config.in (build-link): Restore the removal of "/usr/lib" diff --git a/guile-config/Makefile.am b/guile-config/Makefile.am index be61fcdba..4a2d9ba4f 100644 --- a/guile-config/Makefile.am +++ b/guile-config/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## Jim Blandy --- September 1997 ## -## Copyright (C) 1998, 1999, 2001, 2006 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2001, 2006, 2007 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -35,7 +35,7 @@ aclocal_DATA = guile.m4 guile-config: guile-config.in ${top_builddir}/libguile/libpath.h rm -f guile-config.tmp sed < ${srcdir}/guile-config.in > guile-config.tmp \ - -e s:@-bindir-@:${bindir}: \ + -e 's|@-bindir-@|${bindir}|' \ -e s:@-GUILE_VERSION-@:${GUILE_VERSION}: chmod +x guile-config.tmp mv guile-config.tmp guile-config diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f50827ef8..574c96b7d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,21 @@ +2007-01-04 Kevin Ryde + + * boot-9.scm (top-repl): Check (defined? 'SIGBUS) before using that + value, there's no such signal on mingw. Reported by Cesar Strauss. + +2006-12-13 Kevin Ryde + + * boot-9.scm (use-srfis, top-repl): Use process-use-modules, to + correctly handle duplicates between the core and other modules, in + particular srfi-17 which should replace `car' etc (but didn't). + +2006-12-09 Kevin Ryde + + * boot-9.scm (top-repl): Remove module-use! of the core `(guile)' + module. It's already in `(guile-user)' and the module-use! elevates + it making core bindings override those from elsewhere, such as `iota' + under a run of "guile --use-srfi=1". Reported by Sven Hartrumpf. + 2006-11-13 Neil Jerram * boot-9.scm (environment-module): Change eval-closure-module call diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index b50ae2911..e8f5bb691 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006 +;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -3313,13 +3313,11 @@ ;; numbers, which are the numbers of the SRFIs to be loaded on startup. ;; (define (use-srfis srfis) - (let lp ((s srfis)) - (if (pair? s) - (let* ((srfi (string->symbol - (string-append "srfi-" (number->string (car s))))) - (mod-i (resolve-interface (list 'srfi srfi)))) - (module-use! (current-module) mod-i) - (lp (cdr s)))))) + (process-use-modules + (map (lambda (num) + (list (list 'srfi (string->symbol + (string-append "srfi-" (number->string num)))))) + srfis))) @@ -3387,30 +3385,38 @@ ;; Use some convenient modules (in reverse order) - (if (provided? 'regex) - (module-use! guile-user-module (resolve-interface '(ice-9 regex)))) - (if (provided? 'threads) - (module-use! guile-user-module (resolve-interface '(ice-9 threads)))) + (set-current-module guile-user-module) + (process-use-modules + (append + '(((ice-9 r5rs)) + ((ice-9 session)) + ((ice-9 debug))) + (if (provided? 'regex) + '(((ice-9 regex))) + '()) + (if (provided? 'threads) + '(((ice-9 threads))) + '()))) ;; load debugger on demand (module-use! guile-user-module (make-autoload-interface guile-user-module '(ice-9 debugger) '(debug))) - (module-use! guile-user-module (resolve-interface '(ice-9 session))) - (module-use! guile-user-module (resolve-interface '(ice-9 debug))) - ;; so that builtin bindings will be checked first - (module-use! guile-user-module (resolve-interface '(ice-9 r5rs))) - (module-use! guile-user-module (resolve-interface '(guile))) - (set-current-module guile-user-module) + ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see + ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have + ;; no effect. (let ((old-handlers #f) (signals (if (provided? 'posix) `((,SIGINT . "User interrupt") (,SIGFPE . "Arithmetic error") - (,SIGBUS . "Bad memory access (bus error)") (,SIGSEGV . "Bad memory access (Segmentation violation)")) '()))) + ;; no SIGBUS on mingw + (if (defined? 'SIGBUS) + (set! signals (acons SIGBUS "Bad memory access (bus error)" + signals))) (dynamic-wind From cea95a2fa1f2ec810f0322a038a3af33da309e4a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:31:08 +0000 Subject: [PATCH 083/116] *** empty log message *** --- guile-config/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index 65cea517c..6156dc812 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -2,7 +2,7 @@ * Makefile.am (guile-config): Use "|" as the sed delimiter, for the benefit of DOS systems where $(bindir) might include a drive letter - like "c:". + like "c:". Reported by Cesar Strauss. 2006-09-19 Rob Browning From 23d72566286b3b2b6fec9548cbfdb5d79685e973 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:42:45 +0000 Subject: [PATCH 084/116] merge from 1.8 --- libguile/ChangeLog | 106 +++++++++++++++++++++++++++++- libguile/Makefile.am | 2 +- libguile/deprecated.h | 4 +- libguile/eval.c | 2 +- libguile/feature.c | 18 ++++- libguile/feature.h | 1 + libguile/filesys.c | 40 +++++------ libguile/numbers.c | 16 ++++- libguile/posix.c | 75 +++++++++++++-------- libguile/print.c | 6 ++ libguile/regex-posix.c | 27 +++++--- libguile/scmsigs.c | 24 +++++-- libguile/threads.c | 56 ++++++++++++++-- libguile/version.h.in | 12 ++-- srfi/ChangeLog | 6 ++ srfi/srfi-60.c | 2 +- test-suite/ChangeLog | 39 ++++++++++- test-suite/standalone/Makefile.am | 8 ++- test-suite/tests/eval.test | 27 ++++++++ test-suite/tests/numbers.test | 80 ++++++++++++++++------ 20 files changed, 445 insertions(+), 106 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b2244a975..fed459b90 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,33 @@ +<<<<<<< ChangeLog +2007-01-16 Kevin Ryde + + * feature.c, feature.h (scm_set_program_arguments_scm): New function, + implementing `set-program-arguments'. + + * filesys.c (scm_init_filesys): Use scm_from_int rather than + scm_from_long for O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL, + O_NOCTTY, O_TRUNC, O_APPEND, O_NONBLOCK, O_NDELAY, O_SYNC and + O_LARGEFILE. These are all int not long, per arg to open(). + (scm_init_filesys): Use scm_from_int rather than scm_from_long for + F_DUPFD, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, F_SETOWN, these + are all ints (per command arg to fcntl). Likewise FD_CLOEXEC which is + an int arg to fcntl. + + * posix.c (scm_putenv): Correction to "len" variable, was defined only + for __MINGW32__ but used under any !HAVE_UNSETENV (such as solaris). + Move it to where it's used. Reported by Hugh Sasse. + + * regex-posix.c (scm_regexp_exec): Remove SCM_CRITICAL_SECTION_START + and SCM_CRITICAL_SECTION_END, believe not needed. Their placement + meant #\nul in the input (detected by scm_to_locale_string) and a bad + flags arg (detected by scm_to_int) would throw from a critical + section, causing an abort(). + + * regex-posix.c (scm_init_regex_posix): Use scm_from_int for + REG_BASIC, REG_EXTENDED, REG_ICASE, REG_NEWLINE, REG_NOTBOL, + REG_NOTEOL; they're all ints not longs (per args to regcomp and + regexec). + 2007-01-10 Han-Wen Nienhuys * throw.c (scm_ithrow): print out key symbol and string arguments @@ -8,12 +38,44 @@ * read.c (s_scm_read_hash_extend): document #f argument to read-hash-extend. +2007-01-04 Kevin Ryde + + * deprecated.h (scm_create_hook), version.h.in (scm_major_version, + scm_minor_version, scm_micro_version, scm_effective_version, + scm_version, scm_init_version): Use SCM_API instead of just extern, + for the benefit of mingw. Reported by Cesar Strauss. + 2007-01-03 Han-Wen Nienhuys * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated too. (gc_update_stats): update scm_gc_cells_allocated_acc too. +2006-12-27 Kevin Ryde + + * threads.c (get_thread_stack_base): In mingw with pthreads we can use + the basic scm_get_stack_base. As advised by Nils Durner. + + * threads.c (get_thread_stack_base): Add a version using + pthread_get_stackaddr_np (when available), for the benefit of MacOS. + As advised by Heikki Lindholm. + + * scmsigs.c (signal_delivery_thread): Restrict scm_i_pthread_sigmask + to HAVE_PTHREAD_SIGMASK, it doesn't exist on mingw. Reported by Nils + Durner. + +2006-12-24 Kevin Ryde + + * posix.c (scm_kill): When only raise() is available, throw an ENOSYS + error if pid is not our own process, instead of silently doing nothing. + + * print.c (scm_write, scm_display, scm_write_char): Disable port close + on EPIPE. This was previously disabled but introduction of HAVE_PIPE + check in configure.in unintentionally enabled it. Believe that + testing errno after scm_prin1 or scm_putc is bogus, a long ago error + can leave errno in that state. popen.test "no duplicates" output test + provoked that. + 2006-12-23 Han-Wen Nienhuys * numbers.c (scm_i_fraction_reduce): move logic into @@ -30,7 +92,35 @@ SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, SCM_FRACTION_REDUCED. - +2006-12-16 Kevin Ryde + + * scmsigs.c (scm_raise): Use raise() rather than kill(), as this is + more direct for a procedure called raise. + (kill): Remove mingw fake fallback. + +2006-12-15 Kevin Ryde + + * scmsigs.c: Conditionalize process.h, add io.h believe needed for + _pipe on mingw. + +2006-12-14 Kevin Ryde + + * threads.c (thread_print): Cope with the case where pthread_t is a + struct, as found on mingw. Can't just cast to size_t for printing. + Reported by Nils Durner. + + * scmsigs.c: Add and needed by mingw. Copy the + fallback pipe() using _pipe() from posix.c. Reported by Nils Durner. + +2006-12-13 Kevin Ryde + + * eval.c (scm_m_define): Set 'name procedure property on any + scm_procedure_p, not just SCM_CLOSUREP. In particular this picks up + procedures with setters as used in srfi-17. + + * posix.c (scm_crypt): Check for NULL return from crypt(), which the + linux man page says is a possibility. + 2006-12-12 Ludovic Courtès * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES @@ -44,6 +134,20 @@ `array-in-bounds?' for arrays with a rank greater than one and with different lower bounds for each dimension. +2006-12-05 Kevin Ryde + + * numbers.c (scm_product): For flonum*inum and complex*inum, return + exact 0 if inum==0. Already done for inum*flonum and inum*complex, + and as per R5RS section "Exactness". + +2006-12-03 Kevin Ryde + + * Makefile.am (.c.doc): Remove the "test -n" apparently attempting to + allow $AWK from the environment to override. It had syntax gremlins, + and the presence of a $(AWK) variable set by AC_PROG_AWK in the + Makefile stopped it having any effect. Use just $(AWK), which can be + overridden with "make AWK=xxx" in the usual way if desired. + 2006-11-29 Ludovic Courtès * libguile/vectors.c (scm_vector_to_list): Fixed list diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 47220ddb6..273f5aa02 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -285,7 +285,7 @@ SUFFIXES = .x .doc .c.x: ./guile-snarf -o $@ $< $(snarfcppopts) .c.doc: - -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) + -$(AWK) -f ./guile-func-name-check $< (./guile-snarf-docs $(snarfcppopts) $< | \ ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index bbd8bc07a..9a0862c3e 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,7 +5,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2003,2004, 2005, 2006, 2007 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 @@ -164,7 +164,7 @@ SCM_API SCM scm_make_gsubr_with_generic (const char *name, SCM (*fcn)(), SCM *gf); -extern SCM scm_create_hook (const char* name, int n_args); +SCM_API SCM scm_create_hook (const char* name, int n_args); #define SCM_LIST0 SCM_EOL #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) diff --git a/libguile/eval.c b/libguile/eval.c index db5c00529..26d90f1f6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1235,7 +1235,7 @@ scm_m_define (SCM expr, SCM env) SCM tmp = value; while (SCM_MACROP (tmp)) tmp = SCM_MACRO_CODE (tmp); - if (SCM_CLOSUREP (tmp) + if (scm_is_true (scm_procedure_p (tmp)) /* Only the first definition determines the name. */ && scm_is_false (scm_procedure_property (tmp, scm_sym_name))) scm_set_procedure_property_x (tmp, scm_sym_name, variable); diff --git a/libguile/feature.c b/libguile/feature.c index 1d44a7790..6cd0e54ab 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 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 @@ -76,6 +76,22 @@ scm_set_program_arguments (int argc, char **argv, char *first) scm_fluid_set_x (progargs_fluid, args); } +SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0, + (SCM lst), + "Set the command line arguments to be returned by\n" + "@code{program-arguments} (and @code{command-line}). @var{lst}\n" + "should be a list of strings, the first of which is the program\n" + "name (either a script name, or just @code{\"guile\"}).\n" + "\n" + "Program arguments are held in a fluid and therefore have a\n" + "separate value in each Guile thread. Neither the list nor the\n" + "strings within it are copied, so should not be modified later.") +#define FUNC_NAME s_scm_set_program_arguments_scm +{ + return scm_fluid_set_x (progargs_fluid, lst); +} +#undef FUNC_NAME + diff --git a/libguile/feature.h b/libguile/feature.h index 58db46422..f12f292ce 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -27,6 +27,7 @@ SCM_API void scm_add_feature (const char* str); SCM_API SCM scm_program_arguments (void); SCM_API void scm_set_program_arguments (int argc, char **argv, char *first); +SCM_API SCM scm_set_program_arguments_scm (SCM lst); SCM_API void scm_init_feature (void); #endif /* SCM_FEATURE_H */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 72b45e92a..1798bb698 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1681,65 +1681,65 @@ scm_init_filesys () scm_dot_string = scm_permanent_object (scm_from_locale_string (".")); #ifdef O_RDONLY - scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY)); #endif #ifdef O_WRONLY - scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY)); #endif #ifdef O_RDWR - scm_c_define ("O_RDWR", scm_from_long (O_RDWR)); + scm_c_define ("O_RDWR", scm_from_int (O_RDWR)); #endif #ifdef O_CREAT - scm_c_define ("O_CREAT", scm_from_long (O_CREAT)); + scm_c_define ("O_CREAT", scm_from_int (O_CREAT)); #endif #ifdef O_EXCL - scm_c_define ("O_EXCL", scm_from_long (O_EXCL)); + scm_c_define ("O_EXCL", scm_from_int (O_EXCL)); #endif #ifdef O_NOCTTY - scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY)); #endif #ifdef O_TRUNC - scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC)); #endif #ifdef O_APPEND - scm_c_define ("O_APPEND", scm_from_long (O_APPEND)); + scm_c_define ("O_APPEND", scm_from_int (O_APPEND)); #endif #ifdef O_NONBLOCK - scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK)); #endif #ifdef O_NDELAY - scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY)); #endif #ifdef O_SYNC - scm_c_define ("O_SYNC", scm_from_long (O_SYNC)); + scm_c_define ("O_SYNC", scm_from_int (O_SYNC)); #endif #ifdef O_LARGEFILE - scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE)); + scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE)); #endif #ifdef F_DUPFD - scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD)); #endif #ifdef F_GETFD - scm_c_define ("F_GETFD", scm_from_long (F_GETFD)); + scm_c_define ("F_GETFD", scm_from_int (F_GETFD)); #endif #ifdef F_SETFD - scm_c_define ("F_SETFD", scm_from_long (F_SETFD)); + scm_c_define ("F_SETFD", scm_from_int (F_SETFD)); #endif #ifdef F_GETFL - scm_c_define ("F_GETFL", scm_from_long (F_GETFL)); + scm_c_define ("F_GETFL", scm_from_int (F_GETFL)); #endif #ifdef F_SETFL - scm_c_define ("F_SETFL", scm_from_long (F_SETFL)); + scm_c_define ("F_SETFL", scm_from_int (F_SETFL)); #endif #ifdef F_GETOWN - scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN)); #endif #ifdef F_SETOWN - scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN)); #endif #ifdef FD_CLOEXEC - scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC)); #endif #include "libguile/filesys.x" diff --git a/libguile/numbers.c b/libguile/numbers.c index 2a833c83c..a0ef29cdd 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4481,7 +4481,12 @@ scm_product (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + { + /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ + if (scm_is_eq (y, SCM_INUM0)) + return y; + return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + } else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); @@ -4501,8 +4506,13 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + { + /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ + if (scm_is_eq (y, SCM_INUM0)) + return y; + return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), + SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + } else if (SCM_BIGP (y)) { double z = mpz_get_d (SCM_I_BIG_MPZ (y)); diff --git a/libguile/posix.c b/libguile/posix.c index 8129c6413..dda20e8e1 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -491,11 +491,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, /* Signal values are interned in scm_init_posix(). */ #ifdef HAVE_KILL if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) + SCM_SYSERROR; #else + /* Mingw has raise(), but not kill(). (Other raw DOS environments might + be similar.) Use raise() when the requested pid is our own process, + otherwise bomb. */ if (scm_to_int (pid) == getpid ()) - if (raise (scm_to_int (sig)) != 0) + { + if (raise (scm_to_int (sig)) != 0) + { + err: + SCM_SYSERROR; + } + else + { + errno = ENOSYS; + goto err; + } + } #endif - SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1316,9 +1330,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, { int rv; char *c_str = scm_to_locale_string (str); -#ifdef __MINGW32__ - size_t len = strlen (c_str); -#endif if (strchr (c_str, '=') == NULL) { @@ -1333,6 +1344,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, /* On e.g. Win32 hosts putenv() called with 'name=' removes the environment variable 'name'. */ int e; + size_t len = strlen (c_str); char *ptr = scm_malloc (len + 2); strcpy (ptr, c_str); strcpy (ptr+len, "="); @@ -1352,26 +1364,29 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, by getenv. It's not enough just to modify the string we set, because MINGW putenv copies it. */ - if (c_str[len-1] == '=') - { - char *ptr = scm_malloc (len+2); - strcpy (ptr, c_str); - strcpy (ptr+len, " "); - rv = putenv (ptr); - if (rv < 0) - { - int eno = errno; - free (c_str); - errno = eno; - SCM_SYSERROR; - } - /* truncate to just the name */ - c_str[len-1] = '\0'; - ptr = getenv (c_str); - if (ptr) - ptr[0] = '\0'; - return SCM_UNSPECIFIED; - } + { + size_t len = strlen (c_str); + if (c_str[len-1] == '=') + { + char *ptr = scm_malloc (len+2); + strcpy (ptr, c_str); + strcpy (ptr+len, " "); + rv = putenv (ptr); + if (rv < 0) + { + int eno = errno; + free (c_str); + errno = eno; + SCM_SYSERROR; + } + /* truncate to just the name */ + c_str[len-1] = '\0'; + ptr = getenv (c_str); + if (ptr) + ptr[0] = '\0'; + return SCM_UNSPECIFIED; + } + } #endif /* __MINGW32__ */ /* Leave c_str in the environment. */ @@ -1565,7 +1580,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, #define FUNC_NAME s_scm_crypt { SCM ret; - char *c_key, *c_salt; + char *c_key, *c_salt, *c_ret; scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); @@ -1575,8 +1590,14 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, c_salt = scm_to_locale_string (salt); scm_dynwind_free (c_salt); - ret = scm_from_locale_string (crypt (c_key, c_salt)); + /* The Linux crypt(3) man page says crypt will return NULL and set errno + on error. (Eg. ENOSYS if legal restrictions mean it cannot be + implemented). */ + c_ret = crypt (c_key, c_salt); + if (c_ret == NULL) + SCM_SYSERROR; + ret = scm_from_locale_string (c_ret); scm_dynwind_end (); return ret; } diff --git a/libguile/print.c b/libguile/print.c index efd51ce06..8bed72297 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -926,11 +926,13 @@ scm_write (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); scm_prin1 (obj, port, 1); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } @@ -947,11 +949,13 @@ scm_display (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); scm_prin1 (obj, port, 0); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } @@ -1084,11 +1088,13 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, SCM_VALIDATE_OPORT_VALUE (2, port); scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port)); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index fcef50006..d280c82b6 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 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 @@ -218,6 +218,17 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, "@end table") #define FUNC_NAME s_scm_regexp_exec { + /* We used to have an SCM_DEFER_INTS, and then later an + SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite + remember what defer ints was for, but a critical section would only be + wanted now if we think regexec() is not thread-safe. The posix spec + + http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html + + reads like regexec is meant to be both thread safe and reentrant + (mentioning simultaneous use in threads, and in signal handlers). So + for now believe no protection needed. */ + int status, nmatches, offset; regmatch_t *matches; char *c_str; @@ -245,7 +256,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, whole regexp, so add 1 to nmatches. */ nmatches = SCM_RGX(rx)->re_nsub + 1; - SCM_CRITICAL_SECTION_START; matches = scm_malloc (sizeof (regmatch_t) * nmatches); c_str = scm_to_locale_string (substr); status = regexec (SCM_RGX (rx), c_str, nmatches, matches, @@ -269,7 +279,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, scm_from_long (matches[i].rm_eo + offset))); } free (matches); - SCM_CRITICAL_SECTION_END; if (status != 0 && status != REG_NOMATCH) scm_error_scm (scm_regexp_error_key, @@ -287,14 +296,14 @@ scm_init_regex_posix () scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ - scm_c_define ("regexp/basic", scm_from_long (REG_BASIC)); - scm_c_define ("regexp/extended", scm_from_long (REG_EXTENDED)); - scm_c_define ("regexp/icase", scm_from_long (REG_ICASE)); - scm_c_define ("regexp/newline", scm_from_long (REG_NEWLINE)); + scm_c_define ("regexp/basic", scm_from_int (REG_BASIC)); + scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED)); + scm_c_define ("regexp/icase", scm_from_int (REG_ICASE)); + scm_c_define ("regexp/newline", scm_from_int (REG_NEWLINE)); /* Execution flags. */ - scm_c_define ("regexp/notbol", scm_from_long (REG_NOTBOL)); - scm_c_define ("regexp/noteol", scm_from_long (REG_NOTEOL)); + scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL)); + scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL)); #include "libguile/regex-posix.x" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 3452f911c..9b1c96d42 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -22,6 +22,7 @@ # include #endif +#include /* for mingw */ #include #include #include @@ -36,6 +37,14 @@ #include "libguile/validate.h" #include "libguile/scmsigs.h" +#ifdef HAVE_IO_H +#include /* for mingw _pipe() */ +#endif + +#ifdef HAVE_PROCESS_H +#include /* for mingw */ +#endif + #ifdef HAVE_UNISTD_H #include #endif @@ -50,7 +59,7 @@ /* This weird comma expression is because Sleep is void under Windows. */ #define sleep(sec) (Sleep ((sec) * 1000), 0) #define usleep(usec) (Sleep ((usec) / 1000), 0) -#define kill(pid, sig) raise (sig) +#define pipe(fd) _pipe (fd, 256, O_BINARY) #endif @@ -106,6 +115,12 @@ close_1 (SCM proc, SCM arg) } #if SCM_USE_PTHREAD_THREADS +/* On mingw there's no notion of inter-process signals, only a raise() + within the process itself which apparently invokes the registered handler + immediately. Not sure how well the following code will cope in this + case. It builds but it may not offer quite the same scheme-level + semantics as on a proper system. If you're relying on much in the way of + signal handling on mingw you probably lose anyway. */ static int signal_pipe[2]; @@ -149,12 +164,13 @@ read_without_guile (int fd, char *buf, size_t n) static SCM signal_delivery_thread (void *data) { - sigset_t all_sigs; int n, sig; char sigbyte; - +#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */ + sigset_t all_sigs; sigfillset (&all_sigs); scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL); +#endif while (1) { @@ -616,7 +632,7 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0, "@var{sig} is as described for the kill procedure.") #define FUNC_NAME s_scm_raise { - if (kill (getpid (), scm_to_int (sig)) != 0) + if (raise (scm_to_int (sig)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } diff --git a/libguile/threads.c b/libguile/threads.c index 6e2bce9c7..7e1bfde7f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -141,9 +141,32 @@ thread_mark (SCM obj) static int thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { + /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a + struct. A cast like "(unsigned long) t->pthread" is a syntax error in + the struct case, hence we go via a union, and extract according to the + size of pthread_t. */ + union { + scm_i_pthread_t p; + unsigned short us; + unsigned int ui; + unsigned long ul; + scm_t_uintmax um; + } u; scm_i_thread *t = SCM_I_THREAD_DATA (exp); + scm_i_pthread_t p = t->pthread; + scm_t_uintmax id; + u.p = p; + if (sizeof (p) == sizeof (unsigned short)) + id = u.us; + else if (sizeof (p) == sizeof (unsigned int)) + id = u.ui; + else if (sizeof (p) == sizeof (unsigned long)) + id = u.ul; + else + id = u.um; + scm_puts ("#pthread, 10, port); + scm_uintprint (id, 10, port); scm_puts (" (", port); scm_uintprint ((scm_t_bits)t, 16, port); scm_puts (")>", port); @@ -571,9 +594,11 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } #if SCM_USE_PTHREAD_THREADS -/* pthread_getattr_np not available on MacOS X and Solaris 10. */ -#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP +#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP +/* This method for GNU/Linux and perhaps some other systems. + It's not for MacOS X or Solaris 10, since pthread_getattr_np is not + available on them. */ #define HAVE_GET_THREAD_STACK_BASE static SCM_STACKITEM * @@ -606,7 +631,30 @@ get_thread_stack_base () } } -#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */ +#elif HAVE_PTHREAD_GET_STACKADDR_NP +/* This method for MacOS X. + It'd be nice if there was some documentation on pthread_get_stackaddr_np, + but as of 2006 there's nothing obvious at apple.com. */ +#define HAVE_GET_THREAD_STACK_BASE +static SCM_STACKITEM * +get_thread_stack_base () +{ + return pthread_get_stackaddr_np (pthread_self ()); +} + +#elif defined (__MINGW32__) +/* This method for mingw. In mingw the basic scm_get_stack_base can be used + in any thread. We don't like hard-coding the name of a system, but there + doesn't seem to be a cleaner way of knowing scm_get_stack_base can + work. */ +#define HAVE_GET_THREAD_STACK_BASE +static SCM_STACKITEM * +get_thread_stack_base () +{ + return scm_get_stack_base (); +} + +#endif /* pthread methods of get_thread_stack_base */ #else /* !SCM_USE_PTHREAD_THREADS */ diff --git a/libguile/version.h.in b/libguile/version.h.in index 691898cd5..1d8f27750 100644 --- a/libguile/version.h.in +++ b/libguile/version.h.in @@ -30,12 +30,12 @@ #define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@ #define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@ -extern SCM scm_major_version (void); -extern SCM scm_minor_version (void); -extern SCM scm_micro_version (void); -extern SCM scm_effective_version (void); -extern SCM scm_version (void); -extern void scm_init_version (void); +SCM_API SCM scm_major_version (void); +SCM_API SCM scm_minor_version (void); +SCM_API SCM scm_micro_version (void); +SCM_API SCM scm_effective_version (void); +SCM_API SCM scm_version (void); +SCM_API void scm_init_version (void); #endif /* SCM_VERSION_H */ diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 1d77d7747..e662163fb 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2006-12-02 Kevin Ryde + + * srfi-60.c (scm_srfi60_copy_bit): Should be long not int for fixnum + bitshift, fixes 64-bit systems setting a bit between 32 and 63. + Reported by Aaron M. Ucko, Debian bug 396119. + 2006-05-28 Kevin Ryde * srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!): diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c index 257b1387f..f631c6447 100644 --- a/srfi/srfi-60.c +++ b/srfi/srfi-60.c @@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, if (ii < SCM_LONG_BIT-1) { nn &= ~(1L << ii); /* zap bit at index */ - nn |= (bb << ii); /* insert desired bit */ + nn |= ((long) bb << ii); /* insert desired bit */ return scm_from_long (nn); } else diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 11018c308..c49acb15f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,15 +1,48 @@ +2007-01-16 Kevin Ryde + + * tests/regexp.test (regexp-exec): Further tests, in particular #\nul + in input and bad flags args which had been provoking abort()s. + 2006-12-24 Han-Wen Nienhuys * tests/numbers.test ("equal?"): add case for reduction of rational numbers. -2006-12-12 Ludovic Courtès +2006-12-13 Kevin Ryde + + * tests/eval.test: Exercise top-level define setting procedure-name. + * tests/srfi-17.test (car): Check procedure-name property. + + * tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0. + +2006-12-12 Ludovic Courts * tests/unif.test (syntax): New test prefix. Check syntax for negative lower bounds and negative lengths (reported by Gyula Szavai) as well as `array-in-bounds?'. -2006-11-29 Ludovic Courtès +2006-12-09 Kevin Ryde + + * standalone/test-use-srfi: New test. + * standalone/Makefile.am (TESTS): Add it. + +2006-12-03 Kevin Ryde + + * standalone/Makefile.am (.x): Change from %.c %.x style to .c.x style + since the former is a GNU make extension. (Rule now as per + libguile/Makefile.am.) + + * standalone/Makefile.am (test_cflags): Change from := to plain =, as + the former is not portable (according to automake). + +2006-12-02 Kevin Ryde + + * tests/numbers.test (min, max): Correction to big/real and real/big + tests, `big*5' will round on a 64-bit system. And use `eqv?' to + ensure intended exact vs inexact is checked. Reported by Aaron + M. Ucko, Debian bug 396119. + +2006-11-29 Ludovic Courts * test-suite/tests/vectors.test: Use `define-module'. (vector->list): New test prefix. "Shared array" test contributed @@ -29,7 +62,7 @@ * tests/environments.test: Comment out all tests in this file. -2006-10-26 Ludovic Courtès +2006-10-26 Ludovic Courts * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a typo: `thrown' instead of `throw'. diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index ec6481029..b95fdd0f9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -29,7 +29,7 @@ BUILT_SOURCES = TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" -test_cflags := \ +test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ -I$(top_srcdir) \ -I$(top_srcdir)/libguile-ltdl $(EXTRA_DEFS) $(GUILE_CFLAGS) @@ -38,7 +38,8 @@ AM_LDFLAGS = $(GUILE_CFLAGS) snarfcppopts = \ $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir) -%.x: %.c +SUFFIXES = .x +.c.x: ${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts) CLEANFILES = *.x @@ -102,6 +103,9 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la check_PROGRAMS += test-conversion TESTS += test-conversion +# test-use-srfi +TESTS += test-use-srfi + all-local: cd ${srcdir} && chmod u+x ${check_SCRIPTS} diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 4adf0312f..99beca418 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -201,6 +201,33 @@ (map + '(1 2) '(3))) ))) +;;; +;;; define with procedure-name +;;; + +(define old-procnames-flag (memq 'procnames (debug-options))) +(debug-enable 'procnames) + +;; names are only set on top-level procedures (currently), so these can't be +;; hidden in a let +;; +(define foo-closure (lambda () "hello")) +(define bar-closure foo-closure) +(define foo-pws (make-procedure-with-setter car set-car!)) +(define bar-pws foo-pws) + +(with-test-prefix "define set procedure-name" + + (pass-if "closure" + (eq? 'foo-closure (procedure-name bar-closure))) + + (pass-if "procedure-with-setter" + (eq? 'foo-pws (pk (procedure-name bar-pws))))) + +(if old-procnames-flag + (debug-enable 'procnames) + (debug-disable 'procnames)) + ;;; ;;; promises ;;; diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index fd1ced2d2..b28b4ef97 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2243,19 +2243,17 @@ (with-test-prefix "big / real" (pass-if (nan? (max big*5 +nan.0))) - (pass-if (= big*5 (max big*5 -inf.0))) - (pass-if (= +inf.0 (max big*5 +inf.0))) - (pass-if (= 1.0 (max (- big*5) 1.0))) - (pass-if (inexact? (max big*5 1.0))) - (pass-if (= (exact->inexact big*5) (max big*5 1.0)))) + (pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0))) + (pass-if (eqv? (exact->inexact big*5) (max big*5 1.0))) + (pass-if (eqv? +inf.0 (max big*5 +inf.0))) + (pass-if (eqv? 1.0 (max (- big*5) 1.0)))) (with-test-prefix "real / big" (pass-if (nan? (max +nan.0 big*5))) - (pass-if (= +inf.0 (max +inf.0 big*5))) - (pass-if (= big*5 (max -inf.0 big*5))) - (pass-if (= 1.0 (max 1.0 (- big*5)))) - (pass-if (inexact? (max 1.0 big*5))) - (pass-if (= (exact->inexact big*5) (max 1.0 big*5)))) + (pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5))) + (pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5))) + (pass-if (eqv? +inf.0 (max +inf.0 big*5))) + (pass-if (eqv? 1.0 (max 1.0 (- big*5))))) (with-test-prefix "frac / frac" (pass-if (= 2/3 (max 1/2 2/3))) @@ -2370,19 +2368,17 @@ (with-test-prefix "big / real" (pass-if (nan? (min big*5 +nan.0))) - (pass-if (= big*5 (min big*5 +inf.0))) - (pass-if (= -inf.0 (min big*5 -inf.0))) - (pass-if (= 1.0 (min big*5 1.0))) - (pass-if (inexact? (min (- big*5) 1.0))) - (pass-if (= (exact->inexact (- big*5)) (min (- big*5) 1.0)))) + (pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0))) + (pass-if (eqv? -inf.0 (min big*5 -inf.0))) + (pass-if (eqv? 1.0 (min big*5 1.0))) + (pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0)))) (with-test-prefix "real / big" (pass-if (nan? (min +nan.0 big*5))) - (pass-if (= big*5 (min +inf.0 big*5))) - (pass-if (= -inf.0 (min -inf.0 big*5))) - (pass-if (= 1.0 (min 1.0 big*5))) - (pass-if (inexact? (min 1.0 (- big*5)))) - (pass-if (= (exact->inexact (- big*5)) (min 1.0 (- big*5))))) + (pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5))) + (pass-if (eqv? -inf.0 (min -inf.0 big*5))) + (pass-if (eqv? 1.0 (min 1.0 big*5))) + (pass-if (eqv? (exact->inexact (- big*5)) (min 1.0 (- big*5))))) (with-test-prefix "frac / frac" (pass-if (= 1/2 (min 1/2 2/3))) @@ -2463,10 +2459,52 @@ (with-test-prefix "*" + (with-test-prefix "inum * bignum" + + (pass-if "0 * 2^256 = 0" + (eqv? 0 (* 0 (ash 1 256))))) + + (with-test-prefix "inum * flonum" + + (pass-if "0 * 1.0 = 0" + (eqv? 0 (* 0 1.0)))) + + (with-test-prefix "inum * complex" + + (pass-if "0 * 1+1i = 0" + (eqv? 0 (* 0 1+1i)))) + + (with-test-prefix "inum * frac" + + (pass-if "0 * 2/3 = 0" + (eqv? 0 (* 0 2/3)))) + + (with-test-prefix "bignum * inum" + + (pass-if "2^256 * 0 = 0" + (eqv? 0 (* (ash 1 256) 0)))) + + (with-test-prefix "flonum * inum" + + ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 + (pass-if "1.0 * 0 = 0" + (eqv? 0 (* 1.0 0)))) + + (with-test-prefix "complex * inum" + + ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 + (pass-if "1+1i * 0 = 0" + (eqv? 0 (* 1+1i 0)))) + (pass-if "complex * bignum" (let ((big (ash 1 90))) (= (make-rectangular big big) - (* 1+1i big))))) + (* 1+1i big)))) + + (with-test-prefix "frac * inum" + + (pass-if "2/3 * 0 = 0" + (eqv? 0 (* 2/3 0))))) ;;; ;;; / From de6eff7190b343e71baa282f0700dec60289ed8f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:42:46 +0000 Subject: [PATCH 085/116] copyright year --- libguile/feature.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/feature.h b/libguile/feature.h index f12f292ce..9c61f8ce8 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -3,7 +3,7 @@ #ifndef SCM_FEATURE_H #define SCM_FEATURE_H -/* Copyright (C) 1995,1996,1999,2000,2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007 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 From 8e1973d9abd8a1706d5014e316c0a0fdec6f75da Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:49:04 +0000 Subject: [PATCH 086/116] merge from 1.8 --- doc/ref/api-procedures.texi | 82 ++++++++++++++++++++++------- libguile/ChangeLog | 1 - test-suite/standalone/test-use-srfi | 67 +++++++++++++++++++++++ test-suite/tests/regexp.test | 34 +++++++++++- test-suite/tests/srfi-17.test | 7 +++ 5 files changed, 169 insertions(+), 22 deletions(-) create mode 100755 test-suite/standalone/test-use-srfi diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e6d520ddf..7fd0f4fa4 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -198,30 +198,72 @@ evaluated in order. @node let-keywords Reference @subsubsection let-keywords Reference -@c FIXME::martin: Review me! +@code{let-keywords} and @code{let-keywords*} extract values from +keyword style argument lists, binding local variables to those values +or to defaults. -@code{let-keywords} and @code{let-keywords*} are used for extracting -values from argument lists which use keywords instead of argument -position for binding local variables to argument values. +@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{} +@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{} +@var{args} is evaluated and should give a list of the form +@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The +@var{binding}s are variables and default expressions, with the +variables to be set (by name) from the keyword values. The @var{body} +forms are then evaluated and the last is the result. An example will +make the syntax clearest, -@code{let-keywords} binds all variables simultaneously, while -@code{let-keywords*} binds them sequentially, consistent with @code{let} -and @code{let*} (@pxref{Local Bindings}). +@example +(define args '(#:xyzzy "hello" #:foo "world")) -@deffn {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -@deffnx {library syntax} let-keywords* rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -These macros pick out keyword arguments from @var{rest-arg}, but do not -modify it. This is consistent at least with Common Lisp, which -duplicates keyword arguments in the rest argument. More explanation of what -keyword arguments in a lambda list look like can be found below in -the documentation for @code{lambda*} - (@pxref{lambda* Reference}). @var{binding}s can have the same form as -for @code{let-optional}. If @var{allow-other-keys?} is false, an error -will be thrown if anything that looks like a keyword argument but does -not match a known keyword parameter will result in an error. +(let-keywords args #t + ((foo "default for foo") + (bar (string-append "default" "for" "bar"))) + (display foo) + (display ", ") + (display bar)) +@print{} world, defaultforbar +@end example -After binding the variables, the expressions @var{expr} @dots{} are -evaluated in order. +The binding for @code{foo} comes from the @code{#:foo} keyword in +@code{args}. But the binding for @code{bar} is the default in the +@code{let-keywords}, since there's no @code{#:bar} in the args. + +@var{allow-other-keys?} is evaluated and controls whether unknown +keywords are allowed in the @var{args} list. When true other keys are +ignored (such as @code{#:xyzzy} in the example), when @code{#f} an +error is thrown for anything unknown. + +@code{let-keywords} is like @code{let} (@pxref{Local Bindings}) in +that all bindings are made at once, the defaults expressions are +evaluated (if needed) outside the scope of the @code{let-keywords}. + +@code{let-keywords*} is like @code{let*}, each binding is made +successively, and the default expressions see the bindings previously +made. This is the style used by @code{lambda*} keywords +(@pxref{lambda* Reference}). For example, + +@example +(define args '(#:foo 3)) + +(let-keywords* args #f + ((foo 99) + (bar (+ foo 6))) + (display bar)) +@print{} 9 +@end example + +The expression for each default is only evaluated if it's needed, +ie. if the keyword doesn't appear in @var{args}. So one way to make a +keyword mandatory is to throw an error of some sort as the default. + +@example +(define args '(#:start 7 #:finish 13)) + +(let-keywords* args #t + ((start 0) + (stop (error "missing #:stop argument"))) + ...) +@result{} ERROR: missing #:stop argument +@end example @end deffn diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fed459b90..8d2555da1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,3 @@ -<<<<<<< ChangeLog 2007-01-16 Kevin Ryde * feature.c, feature.h (scm_set_program_arguments_scm): New function, diff --git a/test-suite/standalone/test-use-srfi b/test-suite/standalone/test-use-srfi new file mode 100755 index 000000000..309b3bda7 --- /dev/null +++ b/test-suite/standalone/test-use-srfi @@ -0,0 +1,67 @@ +#!/bin/sh + +# Copyright (C) 2006 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 2.1 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 + + +# Test that two srfi numbers on the command line work. +# +guile --use-srfi=1,10 >/dev/null </dev/null </dev/null < --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -70,6 +70,38 @@ (pass-if "foo offset 1" (string=? "foo" (match:string (string-match ".*" "foo" 1))))) +;;; +;;; regexp-exec +;;; + +(with-test-prefix "regexp-exec" + + (pass-if-exception "non-integer offset" exception:wrong-type-arg + (let ((re (make-regexp "ab+"))) + (regexp-exec re "aaaabbbb" 1.5 'bogus-flags-arg))) + + (pass-if-exception "non-string input" exception:wrong-type-arg + (let ((re (make-regexp "ab+"))) + (regexp-exec re 'not-a-string))) + + (pass-if-exception "non-string input, with offset" exception:wrong-type-arg + (let ((re (make-regexp "ab+"))) + (regexp-exec re 'not-a-string 5))) + + ;; in guile 1.8.1 and earlier, a #\nul character in the input string was + ;; only detected in a critical section, and the resulting error throw + ;; abort()ed the program + (pass-if-exception "nul in input" exception:string-contains-nul + (let ((re (make-regexp "ab+"))) + (regexp-exec re (string #\a #\b (integer->char 0))))) + + ;; in guile 1.8.1 and earlier, a bogus flags argument was only detected + ;; inside a critical section, and the resulting error throw abort()ed the + ;; program + (pass-if-exception "non-integer flags" exception:wrong-type-arg + (let ((re (make-regexp "ab+"))) + (regexp-exec re "aaaabbbb" 0 'bogus-flags-arg)))) + ;;; ;;; regexp-quote ;;; diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index 806b420a6..0a0b42541 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -32,6 +32,13 @@ (with-test-prefix "car" + ;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define' + ;; didn't set a name on a procedure-with-setter + (pass-if "procedure-name" + (if (memq 'procnames (debug-options)) ;; enabled by default + (eq? 'car (procedure-name car)) + (throw 'unsupported))) + (pass-if "set! (car x)" (let ((lst (list 1))) (set! (car lst) 2) From 6d6a3fe26083e37760d5de28198a67903d083d3e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 17 Jan 2007 13:38:17 +0000 Subject: [PATCH 087/116] (gds-display-results): Add another binding for gds-show-last-stack (RET). (scheme-mode-map): And another: C-h S. (scheme-mode-map): And an alternative C-h G binding for gds-apropos, as we probably should not be using C-h C-g. --- emacs/ChangeLog | 8 ++++++++ emacs/gds-scheme.el | 3 +++ 2 files changed, 11 insertions(+) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 21c354c7b..fabe42310 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,11 @@ +2007-01-17 Neil Jerram + + * gds-scheme.el (gds-display-results): Add another binding for + gds-show-last-stack (RET). + (scheme-mode-map): And another: C-h S. + (scheme-mode-map): And an alternative C-h G binding for + gds-apropos, as we probably should not be using C-h C-g. + 2006-11-02 Neil Jerram * gds-scheme.el (gds-choose-client): Change assq to memq, so that diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index 134e80592..29a54a574 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -404,6 +404,7 @@ region's code." (let ((beg (point)) (map (make-sparse-keymap))) (define-key map [mouse-1] 'gds-show-last-stack) + (define-key map "\C-m" 'gds-show-last-stack) (insert "[click here to show error stack]") (add-text-properties beg (point) (list 'keymap map @@ -1007,6 +1008,8 @@ return the one that they chose." (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) (define-key scheme-mode-map "\C-hg" 'gds-help-symbol) (define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) +(define-key scheme-mode-map "\C-hG" 'gds-apropos) +(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack) (define-key scheme-mode-map "\e\t" 'gds-complete-symbol) (define-key scheme-mode-map "\C-x " 'gds-set-breakpoint) From 937038e823f18eb4d375890cd0737e8b79667a41 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Thu, 18 Jan 2007 12:34:24 +0000 Subject: [PATCH 088/116] (scm_ithrow): more refined error message: print symbols too. --- libguile/ChangeLog | 5 +++++ libguile/throw.c | 13 ++++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8d2555da1..cec0dda84 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2007-01-18 Han-Wen Nienhuys + + * throw.c (scm_ithrow): more refined error message: print symbols + too. + 2007-01-16 Kevin Ryde * feature.c, feature.h (scm_set_program_arguments_scm): New function, diff --git a/libguile/throw.c b/libguile/throw.c index 86e4d1fa7..9bffda770 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -711,9 +711,16 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) for (; scm_is_pair (s); s = scm_cdr (s), i++) - if (scm_is_string (scm_car (s))) - fprintf (stderr, "argument %d: %s\n", i, scm_i_string_chars (scm_car (s))); - + { + char const *str = NULL; + if (scm_is_string (scm_car (s))) + str = scm_i_string_chars (scm_car (s)); + else if (scm_is_symbol (scm_car (s))) + str = scm_i_symbol_chars (scm_car (s)); + + if (str != NULL) + fprintf (stderr, "argument %d: %s\n", i, str); + } abort (); } From 970aac161bd7a18ea6018a7a4aad1f5b6cdb063a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 18 Jan 2007 23:10:13 +0000 Subject: [PATCH 089/116] (exception:string-contains-nul): New exception pattern. --- test-suite/lib.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 818a9b06d..111d470e1 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,5 +1,5 @@ ;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -30,6 +30,7 @@ exception:numerical-overflow exception:struct-set!-denied exception:miscellaneous-error + exception:string-contains-nul ;; Reporting passes and failures. run-test @@ -259,6 +260,11 @@ (define exception:miscellaneous-error (cons 'misc-error "^.*")) +;; as per throw in scm_to_locale_stringn() +(define exception:string-contains-nul + (cons 'misc-error "^string contains #\\\\nul character")) + + ;;; Display all parameters to the default output port, followed by a newline. (define (display-line . objs) (for-each display objs) From e5467c4d74348e81060ec81cff8f4d7a342adff0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 18 Jan 2007 23:10:46 +0000 Subject: [PATCH 090/116] *** empty log message *** --- test-suite/ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c49acb15f..be650b424 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -2,6 +2,7 @@ * tests/regexp.test (regexp-exec): Further tests, in particular #\nul in input and bad flags args which had been provoking abort()s. + * lib.scm (exception:string-contains-nul): New exception pattern. 2006-12-24 Han-Wen Nienhuys From 42ddb3cb8b30a2bba45c4ef9bf29d3ab04c6cc45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jan 2007 08:53:33 +0000 Subject: [PATCH 091/116] Changes from arch/CVS synchronization --- libguile/ChangeLog | 11 +++++++++-- libguile/struct.c | 9 +++++++-- test-suite/ChangeLog | 8 ++++++++ test-suite/tests/eval.test | 17 ++++++++++++++++- test-suite/tests/structs.test | 25 +++++++++++++++++++------ 5 files changed, 59 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cec0dda84..f62f11a74 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2007-01-19 Ludovic Courtès + + * struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1 + is equal to S1 and FIELD2 is equal to S2. This avoids infinite + recursion when comparing `s' fields, as the REQUIRED_VTABLE_FIELDS + added by `make-vtable-vtable'. Reported by Marco Maggi. + 2007-01-18 Han-Wen Nienhuys * throw.c (scm_ithrow): more refined error message: print symbols @@ -128,10 +135,10 @@ 2006-12-12 Ludovic Courtès * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES - instead of RES (reported by Gyula Szavai). This allows the use of + instead of RES (reported by Szavai Gyula). This allows the use of negative lower bounds. (scm_i_read_array): Make sure LEN is non-negative (reported by - Gyula Szavai). + Szavai Gyula). (scm_array_in_bounds_p): Iterate over S instead of always comparing indices with the bounds of S[0]. This fixes diff --git a/libguile/struct.c b/libguile/struct.c index de8667d45..69ec7e634 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -564,10 +564,15 @@ scm_i_struct_equalp (SCM s1, SCM s2) field1 = scm_struct_ref (s1, s_field_num); field2 = scm_struct_ref (s2, s_field_num); - if (scm_is_false (scm_equal_p (field1, field2))) - return SCM_BOOL_F; + /* Self-referencing fields (type `s') must be skipped to avoid infinite + recursion. */ + if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2)))) + if (scm_is_false (scm_equal_p (field1, field2))) + return SCM_BOOL_F; } + /* FIXME: Tail elements should be tested for equality. */ + return SCM_BOOL_T; } #undef FUNC_NAME diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index be650b424..4688477fc 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2007-01-19 Ludovic Courtès + + * tests/eval.test (values): New test prefix. Values are structs, + and `equal?' on structs with `s' fields used to yield infinite + recursion. + * tests/structs.test (equal?): New test prefix. Added tests that + used to show the infinite recursion problem. + 2007-01-16 Kevin Ryde * tests/regexp.test (regexp-exec): Further tests, in particular #\nul diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 99beca418..519e2c0a1 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2007 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 @@ -315,5 +315,20 @@ '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))) +;;; +;;; values +;;; + +(with-test-prefix "values" + + (pass-if "single value" + (equal? 1 (values 1))) + + (pass-if "call-with-values" + (equal? (call-with-values (lambda () (values 1 2 3 4)) list) + '(1 2 3 4))) + + (pass-if "equal?" + (equal? (values 1 2 3 4) (values 1 2 3 4)))) ;;; eval.test ends here diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 050eb4224..5df4665a3 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -1,7 +1,7 @@ ;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*- ;;;; Ludovic Courts , 2006-06-12. ;;;; -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -18,7 +18,8 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (test-suite lib)) +(define-module (test-suite test-structs) + :use-module (test-suite lib)) @@ -80,15 +81,27 @@ (pass-if "struct-set!" (let ((ball (make-ball green "Bob"))) (set-owner! ball "Bill") - (string=? (owner ball) "Bill"))) + (string=? (owner ball) "Bill")))) - (pass-if "equal?" + +(with-test-prefix "equal?" + + (pass-if "simple structs" + (let* ((vtable (make-vtable-vtable "pr" 0)) + (s1 (make-struct vtable 0 "hello")) + (s2 (make-struct vtable 0 "hello"))) + (equal? s1 s2))) + + (pass-if "more complex structs" (let ((first (make-ball red (string-copy "Bob"))) - (second (make-ball red (string-copy "Bob")))) + (second (make-ball red (string-copy "Bob")))) (equal? first second))) (pass-if "not-equal?" - (not (or (equal? (make-ball red "Bob") (make-ball green "Bill")) + (not (or (equal? (make-ball red "Bob") (make-ball green "Bob")) (equal? (make-ball red "Bob") (make-ball red "Bill")))))) +;;; Local Variables: +;;; coding: latin-1 +;;; End: From 62560650136f8c1a321a754e5081e323009b812a Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 19:26:36 +0000 Subject: [PATCH 092/116] * readline.c: terminate option list with NULL. * read.c: idem. * print.c: idem. * eval.c: terminate option lists with 0. * options.c: remove n (for length) from scm_option_X functions. Detect option list length by looking for NULL name. --- NEWS | 5 ++++- guile-readline/ChangeLog | 4 ++++ guile-readline/readline.c | 3 ++- libguile/ChangeLog | 11 ++++++++++ libguile/debug.c | 6 +++--- libguile/eval.c | 24 ++++++++++++---------- libguile/eval.h | 9 ++++----- libguile/options.c | 42 ++++++++++++++++++++++++--------------- libguile/options.h | 4 ++-- libguile/print.c | 7 ++++--- libguile/read.c | 9 ++++----- 11 files changed, 77 insertions(+), 47 deletions(-) diff --git a/NEWS b/NEWS index a68cff011..9da8def36 100644 --- a/NEWS +++ b/NEWS @@ -19,7 +19,10 @@ Changes in 1.9.XXXXXXXX: * Changes to the distribution * Changes to the stand-alone interpreter * Changes to Scheme functions and syntax -* Changes to the C interface +* Changes to the C interface + +** Functions for handling scm_option now no longer require an argument + indicating length of the scm_t_option array. Changes in 1.8.2 (since 1.8.1): diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index b7bddd59f..e3569b284 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2007-01-19 Han-Wen Nienhuys + + * readline.c: terminate option list with NULL. + 2006-10-06 Neil Jerram * ice-9/readline.scm (new-input-prompt): Renamed from "prompt". diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 4eab67582..4a87ae2dc 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -52,7 +52,8 @@ scm_t_option scm_readline_opts[] = { { SCM_OPTION_INTEGER, "history-length", 200, "History length." }, { SCM_OPTION_INTEGER, "bounce-parens", 500, - "Time (ms) to show matching opening parenthesis (0 = off)."} + "Time (ms) to show matching opening parenthesis (0 = off)."}, + { 0 } }; extern void stifle_history (int max); diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f62f11a74..2107ea3f7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2007-01-19 Han-Wen Nienhuys + + * read.c: idem. + + * print.c: idem. + + * eval.c: terminate option lists with 0. + + * options.c: remove n (for length) from scm_option_X + functions. Detect option list length by looking for NULL name. + 2007-01-19 Ludovic Courtès * struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1 diff --git a/libguile/debug.c b/libguile/debug.c index b546b6cae..01b8204d1 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -59,10 +59,10 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, scm_dynwind_begin (0); scm_dynwind_critical_section (SCM_BOOL_F); - ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); + ans = scm_options (setting, scm_debug_opts, FUNC_NAME); if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) { - scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); + scm_options (ans, scm_debug_opts, FUNC_NAME); SCM_OUT_OF_RANGE (1, setting); } SCM_RESET_DEBUG_MODE; @@ -526,7 +526,7 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, void scm_init_debug () { - scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); + scm_init_opts (scm_debug_options, scm_debug_opts); scm_tc16_memoized = scm_make_smob_type ("memoized", 0); scm_set_smob_mark (scm_tc16_memoized, scm_markcdr); diff --git a/libguile/eval.c b/libguile/eval.c index 26d90f1f6..f667fa653 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3065,7 +3065,8 @@ int scm_check_exit_p; long scm_eval_stack; scm_t_option scm_eval_opts[] = { - { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } + { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }, + { 0 } }; scm_t_option scm_debug_opts[] = { @@ -3088,17 +3089,21 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}, - { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." } + { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }, + { 0 }, }; + + scm_t_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, - { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, - { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }, { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." }, + { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." }, - { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." } + { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }, + { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }, + { 0 } }; SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, @@ -3114,7 +3119,6 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_dynwind_critical_section (SCM_BOOL_F); ans = scm_options (setting, scm_eval_opts, - SCM_N_EVAL_OPTIONS, FUNC_NAME); scm_eval_stack = SCM_EVAL_STACK * sizeof (void *); scm_dynwind_end (); @@ -3133,7 +3137,6 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, SCM_CRITICAL_SECTION_START; ans = scm_options (setting, scm_evaluator_trap_table, - SCM_N_EVALUATOR_TRAPS, FUNC_NAME); /* njrev: same again. */ SCM_RESET_DEBUG_MODE; @@ -6025,11 +6028,9 @@ scm_init_eval () scm_i_pthread_mutexattr_recursive); scm_init_opts (scm_evaluator_traps, - scm_evaluator_trap_table, - SCM_N_EVALUATOR_TRAPS); + scm_evaluator_trap_table); scm_init_opts (scm_eval_options_interface, - scm_eval_opts, - SCM_N_EVAL_OPTIONS); + scm_eval_opts); scm_tc16_promise = scm_make_smob_type ("promise", 0); scm_set_smob_mark (scm_tc16_promise, promise_mark); @@ -6057,3 +6058,4 @@ scm_init_eval () c-file-style: "gnu" End: */ + diff --git a/libguile/eval.h b/libguile/eval.h index 7d856a00b..cc6f8e180 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -45,12 +45,11 @@ SCM_API SCM scm_eval_options_interface (SCM setting); #define SCM_TRAPS_P scm_evaluator_trap_table[0].val #define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val -#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val -#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val -#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) -#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val)) +#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[2].val)) +#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[3].val +#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) +#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[5].val #define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val)) -#define SCM_N_EVALUATOR_TRAPS 7 diff --git a/libguile/options.c b/libguile/options.c index 47cf60a91..412192fb9 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -95,11 +95,11 @@ static SCM protected_objects = SCM_EOL; /* Return a list of the current option setting. The format of an * option setting is described in the above documentation. */ static SCM -get_option_setting (const scm_t_option options[], unsigned int n) +get_option_setting (const scm_t_option options[]) { unsigned int i; SCM ls = SCM_EOL; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { switch (options[i].type) { @@ -123,12 +123,12 @@ get_option_setting (const scm_t_option options[], unsigned int n) /* Return a list of sublists, where each sublist contains option name, value * and documentation string. */ static SCM -get_documented_option_setting (const scm_t_option options[], unsigned int n) +get_documented_option_setting (const scm_t_option options[]) { SCM ans = SCM_EOL; unsigned int i; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL); switch (options[i].type) @@ -149,6 +149,16 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n) } +static int +options_length (scm_t_option options[]) +{ + unsigned int i = 0; + for (; options[i].name != NULL; ++i) + ; + + return i; +} + /* Alters options according to the given option setting 'args'. The value of * args is known to be a list, but it is not known whether the list is a well * formed option setting, i. e. if for every non-boolean option a value is @@ -156,14 +166,14 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n) * original setting in memory. Only if 'args' was successfully processed, * the new setting will overwrite the old one. */ static void -change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s) +change_option_setting (SCM args, scm_t_option options[], const char *s) { unsigned int i; SCM locally_protected_args = args; - SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits)); + SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits)); scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj); - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { if (options[i].type == SCM_OPTION_BOOLEAN) flags[i] = 0; @@ -176,7 +186,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c SCM name = SCM_CAR (args); int found = 0; - for (i = 0; i != n && !found; ++i) + for (i = 0; options[i].name && !found; ++i) { if (scm_is_eq (name, SCM_PACK (options[i].name))) { @@ -204,7 +214,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c args = SCM_CDR (args); } - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { if (options[i].type == SCM_OPTION_SCM) { @@ -223,32 +233,32 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c SCM -scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s) +scm_options (SCM args, scm_t_option options[], const char *s) { if (SCM_UNBNDP (args)) - return get_option_setting (options, n); + return get_option_setting (options); else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args)) /* Dirk:FIXME:: This criterion should be improved. IMO it is better to * demand that args is #t if documentation should be shown than to say * that every argument except a list will print out documentation. */ - return get_documented_option_setting (options, n); + return get_documented_option_setting (options); else { SCM old_setting; SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s); - old_setting = get_option_setting (options, n); - change_option_setting (args, options, n, s); + old_setting = get_option_setting (options); + change_option_setting (args, options, s); return old_setting; } } void -scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n) +scm_init_opts (SCM (*func) (SCM), scm_t_option options[]) { unsigned int i; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { SCM name = scm_from_locale_symbol (options[i].name); options[i].name = (char *) SCM_UNPACK (name); diff --git a/libguile/options.h b/libguile/options.h index 650081cd2..71761245e 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -40,8 +40,8 @@ typedef struct scm_t_option #define SCM_OPTION_SCM 2 -SCM_API SCM scm_options (SCM, scm_t_option [], unsigned int, const char*); -SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n); +SCM_API SCM scm_options (SCM, scm_t_option [], const char*); +SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []); SCM_API void scm_init_options (void); #endif /* SCM_OPTIONS_H */ diff --git a/libguile/print.c b/libguile/print.c index 8bed72297..fa6ea8c1a 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -83,7 +83,9 @@ scm_t_option scm_print_opts[] = { "How to print symbols that have a colon as their first or last character. " "The value '#f' does not quote the colons; '#t' quotes them; " "'reader' quotes them when the reader option 'keywords' is not '#f'." - } + }, + { 0 }, + }; SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, @@ -96,7 +98,6 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_print_opts, - SCM_N_PRINT_OPTIONS, FUNC_NAME); return ans; } @@ -1165,7 +1166,7 @@ scm_init_print () { SCM vtable, layout, type; - scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); + scm_init_opts (scm_print_options, scm_print_opts); scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"), scm_from_locale_string ("{"), diff --git a/libguile/read.c b/libguile/read.c index 53283ad62..d0c4a876f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -52,14 +52,14 @@ scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "case-insensitive", 0, "Convert symbols to lower case."}, { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F), - "Style of keyword recognition: #f or 'prefix."} + "Style of keyword recognition: #f or 'prefix."}, #if SCM_ENABLE_ELISP - , { SCM_OPTION_BOOLEAN, "elisp-vectors", 0, "Support Elisp vector syntax, namely `[...]'."}, { SCM_OPTION_BOOLEAN, "elisp-strings", 0, - "Support `\\(' and `\\)' in strings."} + "Support `\\(' and `\\)' in strings."}, #endif + { 0, }, }; /* @@ -112,7 +112,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_read_opts, - SCM_N_READ_OPTIONS, FUNC_NAME); if (SCM_COPY_SOURCE_P) SCM_RECORD_POSITIONS_P = 1; @@ -979,7 +978,7 @@ scm_init_read () scm_read_hash_procedures = SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL)); - scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); + scm_init_opts (scm_read_options, scm_read_opts); #include "libguile/read.x" } From 07109436196d11e42e5c3fe856c6625e94505be5 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 19:28:55 +0000 Subject: [PATCH 093/116] terminate option list with NULL. (scm_init_readline): fix CVS mess-up. --- guile-readline/ChangeLog | 1 + guile-readline/readline.c | 4 +--- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e3569b284..51979c783 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,6 +1,7 @@ 2007-01-19 Han-Wen Nienhuys * readline.c: terminate option list with NULL. + (scm_init_readline): fix CVS mess-up. 2006-10-06 Neil Jerram diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 4a87ae2dc..4d2be7302 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -65,7 +65,6 @@ SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_readline_opts, - SCM_N_READLINE_OPTIONS, FUNC_NAME); stifle_history (SCM_HISTORY_LENGTH); return ans; @@ -574,8 +573,7 @@ scm_init_readline () reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ()); scm_init_opts (scm_readline_options, - scm_readline_opts, - SCM_N_READLINE_OPTIONS); + scm_readline_opts); init_bouncing_parens(); scm_add_feature ("readline"); #endif /* HAVE_RL_GETC_FUNCTION */ From b0763985c406ea86dde87854cfaabc175c293eb1 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 19:33:10 +0000 Subject: [PATCH 094/116] * srcprop.c: use double cell for storing source-properties. Put filename in the plist, and share between srcprops if possible. Remove specialized storage. * srcprop.h: remove macros without SCM_ prefix from interface. Remove specialized storage/type definitions. * eval.c: terminate option lists with 0. --- libguile/ChangeLog | 7 +++ libguile/eval.c | 2 +- libguile/srcprop.c | 136 +++++++++++++++++++++++---------------------- libguile/srcprop.h | 40 +------------ 4 files changed, 79 insertions(+), 106 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2107ea3f7..c323294ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,12 @@ 2007-01-19 Han-Wen Nienhuys + * srcprop.c: use double cell for storing source-properties. Put + filename in the plist, and share between srcprops if possible. + Remove specialized storage. + + * srcprop.h: remove macros without SCM_ prefix from + interface. Remove specialized storage/type definitions. + * read.c: idem. * print.c: idem. diff --git a/libguile/eval.c b/libguile/eval.c index f667fa653..9c587564c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3024,7 +3024,7 @@ scm_eval_body (SCM code, SCM env) do { \ SCM_SET_ARGSREADY (debug);\ if (scm_check_apply_p && SCM_TRAPS_P)\ - if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\ + if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\ {\ SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ SCM_SET_TRACED_FRAME (debug); \ diff --git a/libguile/srcprop.c b/libguile/srcprop.c index e1b86738c..16c023bc2 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -37,7 +37,7 @@ /* {Source Properties} * * Properties of source list expressions. - * Five of these have special meaning and optimized storage: + * Five of these have special meaning: * * filename string The name of the source file. * copy list A copy of the list expression. @@ -55,29 +55,46 @@ SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); -scm_t_bits scm_tc16_srcprops; -static scm_t_srcprops_chunk *srcprops_chunklist = 0; -static scm_t_srcprops *srcprops_freelist = 0; +/* + layout: + + car = tag + cbr = pos + ccr = copy + cdr = plist +*/ + +#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) +#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK) +#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1)) +#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) +#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) +#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2)) +#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p)) +#define SETSRCPROPBRK(p) \ + (SCM_SET_SMOB_FLAGS ((p), \ + SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK)) +#define CLEARSRCPROPBRK(p) \ + (SCM_SET_SMOB_FLAGS ((p), \ + SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK)) +#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c)) +#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c))) +#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) +#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) + + + +scm_t_bits scm_tc16_srcprops; + static SCM srcprops_mark (SCM obj) { - scm_gc_mark (SRCPROPFNAME (obj)); scm_gc_mark (SRCPROPCOPY (obj)); return SRCPROPPLIST (obj); } - -static size_t -srcprops_free (SCM obj) -{ - *((scm_t_srcprops **) SCM_SMOB_DATA (obj)) = srcprops_freelist; - srcprops_freelist = (scm_t_srcprops *) SCM_SMOB_DATA (obj); - return 0; /* srcprops_chunks are not freed until leaving guile */ -} - - static int srcprops_print (SCM obj, SCM port, scm_print_state *pstate) { @@ -99,38 +116,44 @@ scm_c_source_property_breakpoint_p (SCM form) } +/* + A protected cells whose cdr contains the last plist + used if plist contains only the filename. + + This works because scm_set_source_property_x does + not use assoc-set! for modifying the plist. + */ +static SCM scm_last_plist_filename; + SCM scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) { - register scm_t_srcprops *ptr; - SCM_CRITICAL_SECTION_START; - if ((ptr = srcprops_freelist) != NULL) - srcprops_freelist = *(scm_t_srcprops **)ptr; - else + if (!SCM_UNBNDP (filename)) { - size_t i; - scm_t_srcprops_chunk *mem; - size_t n = sizeof (scm_t_srcprops_chunk) - + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) scm_malloc (n)); - if (mem == NULL) - scm_memory_error ("srcprops"); - scm_gc_register_collectable_memory (mem, n, "srcprops"); - - mem->next = srcprops_chunklist; - srcprops_chunklist = mem; - ptr = &mem->srcprops[0]; - for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) - *(scm_t_srcprops **)&ptr[i] = &ptr[i + 1]; - *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; - srcprops_freelist = (scm_t_srcprops *) &ptr[1]; + SCM old_plist = plist; + + /* + have to extract the acons, and operate on that, for + thread safety. + */ + SCM last_acons = SCM_CDR (scm_last_plist_filename); + if (old_plist == SCM_EOL + && SCM_CDAR (last_acons) == filename) + { + plist = last_acons; + } + else + { + plist = scm_acons (scm_sym_filename, filename, plist); + if (old_plist == SCM_EOL) + SCM_SETCDR (scm_last_plist_filename, plist); + } } - ptr->pos = SRCPROPMAKPOS (line, col); - ptr->fname = filename; - ptr->copy = copy; - ptr->plist = plist; - SCM_CRITICAL_SECTION_END; - SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); + + SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, + SRCPROPMAKPOS (line, col), + copy, + plist); } @@ -140,8 +163,6 @@ scm_srcprops_to_plist (SCM obj) SCM plist = SRCPROPPLIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); - if (!SCM_UNBNDP (SRCPROPFNAME (obj))) - plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist); plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist); plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist); @@ -206,7 +227,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); - else if (scm_is_eq (scm_sym_filename, key)) p = SRCPROPFNAME (p); else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p); else { @@ -277,13 +297,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, scm_make_srcprops (0, scm_to_int (datum), SCM_UNDEFINED, SCM_UNDEFINED, p)); } - else if (scm_is_eq (scm_sym_filename, key)) - { - if (SRCPROPSP (p)) - SRCPROPFNAME (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); - } else if (scm_is_eq (scm_sym_copy, key)) { if (SRCPROPSP (p)) @@ -308,29 +321,18 @@ scm_init_srcprop () { scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark); - scm_set_smob_free (scm_tc16_srcprops, srcprops_free); scm_set_smob_print (scm_tc16_srcprops, srcprops_print); scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047)); scm_c_define ("source-whash", scm_source_whash); + scm_last_plist_filename + = scm_permanent_object (scm_cons (SCM_EOL, + scm_acons (SCM_EOL, SCM_EOL, SCM_EOL))); + #include "libguile/srcprop.x" } -void -scm_finish_srcprop () -{ - register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next; - size_t n= sizeof (scm_t_srcprops_chunk) - + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - while (ptr) - { - next = ptr->next; - scm_gc_unregister_collectable_memory (ptr, n, "srcprops"); - free ((char *) ptr); - ptr = next; - } -} /* Local Variables: diff --git a/libguile/srcprop.h b/libguile/srcprop.h index c0e42778e..87e5fde0f 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -49,46 +49,10 @@ do { \ /* {Source properties} */ - -SCM_API scm_t_bits scm_tc16_srcprops; - -typedef struct scm_t_srcprops -{ - unsigned long pos; - SCM fname; - SCM copy; - SCM plist; -} scm_t_srcprops; - -#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */ -typedef struct scm_t_srcprops_chunk -{ - struct scm_t_srcprops_chunk *next; - scm_t_srcprops srcprops[1]; -} scm_t_srcprops_chunk; - +#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace))) #define SCM_SOURCE_PROPERTY_FLAG_BREAK 1 -#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) -#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK) -#define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->pos -#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) -#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->fname -#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->copy -#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->plist -#define SETSRCPROPBRK(p) \ - (SCM_SET_SMOB_FLAGS ((p), \ - SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK)) -#define CLEARSRCPROPBRK(p) \ - (SCM_SET_SMOB_FLAGS ((p), \ - SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK)) -#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c)) -#define SETSRCPROPPOS(p, l, c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c)) -#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) -#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) - -#define PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace))) +SCM_API scm_t_bits scm_tc16_srcprops; SCM_API SCM scm_sym_filename; SCM_API SCM scm_sym_copy; From 03347a975b726f4b645339660156f62aba1f27ec Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 19:35:36 +0000 Subject: [PATCH 095/116] * options.c (scm_options_try): new function. This allows error reporting before changing options in a critical section. * options.c: remove n (for length) from scm_option_X functions. Detect option list length by looking for NULL name. --- libguile/ChangeLog | 3 +++ libguile/options.c | 21 ++++++++++++++++++--- libguile/options.h | 1 + 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c323294ff..58f662cf1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2007-01-19 Han-Wen Nienhuys + * options.c (scm_options_try): new function. This allows error + reporting before changing options in a critical section. + * srcprop.c: use double cell for storing source-properties. Put filename in the plist, and share between srcprops if possible. Remove specialized storage. diff --git a/libguile/options.c b/libguile/options.c index 412192fb9..ae75e1318 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -164,9 +164,14 @@ options_length (scm_t_option options[]) * formed option setting, i. e. if for every non-boolean option a value is * given. For this reason, the function applies all changes to a copy of the * original setting in memory. Only if 'args' was successfully processed, - * the new setting will overwrite the old one. */ + * the new setting will overwrite the old one. + * + * If DRY_RUN is set, don't change anything. This is useful for trying out an option + * before entering a critical section. + */ static void -change_option_setting (SCM args, scm_t_option options[], const char *s) +change_option_setting (SCM args, scm_t_option options[], const char *s, + int dry_run) { unsigned int i; SCM locally_protected_args = args; @@ -214,6 +219,9 @@ change_option_setting (SCM args, scm_t_option options[], const char *s) args = SCM_CDR (args); } + if (dry_run) + return; + for (i = 0; options[i].name; ++i) { if (options[i].type == SCM_OPTION_SCM) @@ -234,6 +242,13 @@ change_option_setting (SCM args, scm_t_option options[], const char *s) SCM scm_options (SCM args, scm_t_option options[], const char *s) +{ + return scm_options_try (args, options, s, 0); +} + +SCM +scm_options_try (SCM args, scm_t_option options[], const char *s, + int dry_run) { if (SCM_UNBNDP (args)) return get_option_setting (options); @@ -247,7 +262,7 @@ scm_options (SCM args, scm_t_option options[], const char *s) SCM old_setting; SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s); old_setting = get_option_setting (options); - change_option_setting (args, options, s); + change_option_setting (args, options, s, dry_run); return old_setting; } } diff --git a/libguile/options.h b/libguile/options.h index 71761245e..5b9664958 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -40,6 +40,7 @@ typedef struct scm_t_option #define SCM_OPTION_SCM 2 +SCM_API SCM scm_options_try (SCM args, scm_t_option options[], const char *s, int dry_run); SCM_API SCM scm_options (SCM, scm_t_option [], const char*); SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []); SCM_API void scm_init_options (void); From 72f19c26469dc95fbb6bf42e9443ac4d3379fd69 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 20:05:05 +0000 Subject: [PATCH 096/116] * debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if memoize-symbol is set. * eval.h (SCM_MEMOIZE_HDLR): add macros for memoize symbol trap. * eval.c (CEVAL): add memoize_symbol trap. * read.c: idem. * eval.c: terminate option lists with 0. --- libguile/ChangeLog | 7 +++++++ libguile/debug.h | 5 ++++- libguile/eval.c | 43 ++++++++++++++++++++++++++++++++++++++----- libguile/eval.h | 13 ++++++++----- 4 files changed, 57 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 58f662cf1..da886baf9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,12 @@ 2007-01-19 Han-Wen Nienhuys + * debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if + memoize-symbol is set. + + * eval.h (SCM_MEMOIZE_HDLR): add macros for memoize symbol trap. + + * eval.c (CEVAL): add memoize_symbol trap. + * options.c (scm_options_try): new function. This allows error reporting before changing options in a critical section. diff --git a/libguile/debug.h b/libguile/debug.h index c292004a3..ce7dcfe20 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -64,6 +64,7 @@ SCM_API int scm_debug_mode_p; SCM_API int scm_check_entry_p; SCM_API int scm_check_apply_p; SCM_API int scm_check_exit_p; +SCM_API int scm_check_memoize_p; #define SCM_RESET_DEBUG_MODE \ do {\ @@ -73,8 +74,10 @@ do {\ && scm_is_true (SCM_APPLY_FRAME_HDLR);\ scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\ && scm_is_true (SCM_EXIT_FRAME_HDLR);\ + scm_check_memoize_p = (SCM_MEMOIZE_P)\ + && scm_is_true (SCM_MEMOIZE_HDLR);\ scm_debug_mode_p = SCM_DEVAL_P\ - || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\ + || scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\ } while (0) /* {Evaluator} diff --git a/libguile/eval.c b/libguile/eval.c index 9c587564c..cfbf5f3f8 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -99,6 +99,7 @@ static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check); static SCM unmemoize_builtin_macro (SCM expr, SCM env); static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); + /* {Syntax Errors} @@ -2555,6 +2556,7 @@ scm_unmemocar (SCM form, SCM env) SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol, "memoize-symbol"); SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); SCM_SYMBOL (sym_instead, "instead"); @@ -3061,6 +3063,7 @@ int scm_debug_mode_p; int scm_check_entry_p; int scm_check_apply_p; int scm_check_exit_p; +int scm_check_memoize_p; long scm_eval_stack; @@ -3094,18 +3097,24 @@ scm_t_option scm_debug_opts[] = { }; - +/* + this ordering is awkward and illogical, but we maintain it for + compatibility. --hwn +*/ scm_t_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, - { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." }, { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, - { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." }, { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }, + { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." }, + { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." }, { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }, + { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." }, + { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." }, { 0 } }; + SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), "Option interface for the evaluation options. Instead of using\n" @@ -3134,10 +3143,16 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, #define FUNC_NAME s_scm_evaluator_traps { SCM ans; + + + scm_options_try (setting, + scm_evaluator_trap_table, + FUNC_NAME, 1); SCM_CRITICAL_SECTION_START; ans = scm_options (setting, scm_evaluator_trap_table, FUNC_NAME); + /* njrev: same again. */ SCM_RESET_DEBUG_MODE; SCM_CRITICAL_SECTION_END; @@ -3404,7 +3419,7 @@ dispatch: else if (SCM_VARIABLEP (last_form)) RETURN (SCM_VARIABLE_REF (last_form)); else if (scm_is_symbol (last_form)) - RETURN (*scm_lookupcar (x, env, 1)); + RETURN (*scm_lookupcar (x, env, 1)); else RETURN (last_form); } @@ -4034,6 +4049,23 @@ dispatch: goto dispatch; } proc = *location; +#ifdef DEVAL + if (scm_check_memoize_p && SCM_TRAPS_P) + { + SCM_CLEAR_TRACED_FRAME (debug); + SCM arg1 = scm_make_debugobj (&debug); + SCM retval = SCM_BOOL_T; + SCM_TRAPS_P = 0; + retval = scm_call_4 (SCM_MEMOIZE_HDLR, + scm_sym_memoize_symbol, + arg1, x, env); + + /* + do something with retval? + */ + SCM_TRAPS_P = 1; + } +#endif } if (SCM_MACROP (proc)) @@ -4098,7 +4130,7 @@ dispatch: } } else - proc = SCM_CAR (x); + proc = SCM_CAR (x); if (SCM_MACROP (proc)) goto handle_a_macro; @@ -4114,6 +4146,7 @@ dispatch: * level. If the number of arguments does not match the number of arguments * that are allowed to be passed to proc, also an error on the scheme level * will be signalled. */ + PREP_APPLY (proc, SCM_EOL); if (scm_is_null (SCM_CDR (x))) { ENTER_APPLY; diff --git a/libguile/eval.h b/libguile/eval.h index cc6f8e180..dec9983c7 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -43,13 +43,16 @@ SCM_API scm_t_option scm_evaluator_trap_table[]; SCM_API SCM scm_eval_options_interface (SCM setting); -#define SCM_TRAPS_P scm_evaluator_trap_table[0].val + +#define SCM_TRAPS_P scm_evaluator_trap_table[0].val #define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val -#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[2].val)) -#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[3].val -#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) -#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[5].val +#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val +#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val +#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) +#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val)) #define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val)) +#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val +#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val)) From 19ab431ea1900cc66120637c0f4abec0636555b7 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 20:05:18 +0000 Subject: [PATCH 097/116] * api-options.texi (Evaluator trap options): document memoize-symbol-handler * api-evaluation.texi (Evaluator Behaviour): link to the Evaluator trap options node in trap-enable/trap-set! doco. --- doc/ref/ChangeLog | 8 ++++++++ doc/ref/api-debug.texi | 23 +++++++++++++++-------- doc/ref/api-evaluation.texi | 3 +++ doc/ref/api-options.texi | 15 +++++++++++++++ 4 files changed, 41 insertions(+), 8 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 9ffa06b25..880772f17 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,11 @@ +2007-01-19 Han-Wen Nienhuys + + * api-options.texi (Evaluator trap options): document + memoize-symbol-handler + + * api-evaluation.texi (Evaluator Behaviour): link to the Evaluator + trap options node in trap-enable/trap-set! doco. + 2007-01-16 Kevin Ryde * api-data.texi (Mapping Folding and Unfolding): In string-unfold, diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 5f816dc46..68c202266 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -615,14 +615,21 @@ Invoke the Guile debugger to explore the context of the last error. @cindex Low level trap calls @cindex Evaluator trap calls -Guile's evaluator can be configured to call three user-specified -procedures at various points in its operation: an -@dfn{apply-frame-handler} procedure, an @dfn{enter-frame-handler} -procedure, and an @dfn{exit-frame-handler} procedure. These procedures, -and the circumstances under which the evaluator calls them, are -configured by the ``evaluator trap options'' interface (@pxref{Evaluator -trap options}), and by the @code{trace} and @code{breakpoints} fields of -the ``debug options'' interface (@pxref{Debugger options}). +Guile's evaluator can be configured to call the following four user-specified +procedures at various points in its operation. + +@table @dfn +@item apply-frame-handler +@item enter-frame-handler +@item exit-frame-handler +@item memoize-symbol-handler +@end table + +These procedures, and the circumstances under which the evaluator +calls them, are configured by the ``evaluator trap options'' interface +(@pxref{Evaluator trap options}), and by the @code{trace} and +@code{breakpoints} fields of the ``debug options'' interface +(@pxref{Debugger options}). It is not necessary to understand the fine details of these low level calls, and of the options which configure them, in order to use the diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 1da13de43..6fd363df2 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -629,6 +629,9 @@ Like @code{help}, but also print programmer options. Modify the evaluator options. @code{trap-enable} should be used with boolean options and switches them on, @code{trap-disable} switches them off. @code{trap-set!} can be used to set an option to a specific value. + +See @ref{Evaluator trap options} for more information on the available +trap handlers. @end deffn @deffn {Scheme Procedure} evaluator-traps-interface [setting] diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index 6dbc37062..493e2385d 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -554,6 +554,7 @@ Here is the list of evaluator trap options generated by typing exit-frame no Trap when exiting eval or apply. apply-frame no Trap when entering apply. enter-frame no Trap when eval enters new frame. +memoize-symbol no Trap when eval memoizes a symbol's value traps yes Enable evaluator traps. @end smallexample @@ -612,6 +613,20 @@ way. @var{retval} is the return value. @end deffn + +@deffn memoize-symbol-handler key cont expression env +Called when the evaluator memoizes the value of a procedure symbol + +@var{cont} is a ``debug object'', which means that it can be passed to +@code{make-stack} to discover the stack at the point of the trap. The +exit frame handler's code can capture a restartable continuation if it +wants to by using @code{call-with-current-continuation} in the usual +way. + +@var{retval} is the return value. +@end deffn + + @node Debugger options @subsubsection Debugger options From 8a9faebcbf8b629926a5b235da3f46407d71569a Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Fri, 19 Jan 2007 20:05:30 +0000 Subject: [PATCH 098/116] idem. --- NEWS | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 9da8def36..9ea9cc7aa 100644 --- a/NEWS +++ b/NEWS @@ -19,10 +19,14 @@ Changes in 1.9.XXXXXXXX: * Changes to the distribution * Changes to the stand-alone interpreter * Changes to Scheme functions and syntax + +** A new 'memoize-symbol evaluator trap has been added. This trap can +be used for efficiently implementing a Scheme code coverage. + * Changes to the C interface ** Functions for handling scm_option now no longer require an argument - indicating length of the scm_t_option array. +indicating length of the scm_t_option array. Changes in 1.8.2 (since 1.8.1): From 924e80084f8f57a2f1240ba4379ab4803efe5ee7 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:10:40 +0000 Subject: [PATCH 099/116] new file. Make using git easier. --- .gitignore | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ ChangeLog | 4 ++++ 2 files changed, 69 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..62660e298 --- /dev/null +++ b/.gitignore @@ -0,0 +1,65 @@ +*.o +*.info +*.info-[0-9]* +version.texi +Makefile +Makefile.in +.deps +.libs +autom4te.cache +config.sub +config.guess +config.status +config.log +config.h +guile-readline-config.h +*.doc +*.x +*.lo +*.la +aclocal.m4 +libtool +ltmain.sh +configure +depcomp +elisp-comp +missing +mdate-sh +install-sh +texinfo.tex +*~ +BUGS +Makefile +Makefile.in +aclocal.m4 +autom4te.cache +benchmark-guile +check-guile +check-guile.log +compile +confdefs.h +config.build-subdirs +config.cache +config.guess +config.h +config.h.in +config.log +config.status +config.sub +configure +conftest +conftest.c +depcomp +elisp-comp +guile-*.tar.gz +guile-tools +install-sh +libtool +ltconfig +ltmain.sh +mdate-sh +missing +mkinstalldirs +pre-inst-guile +pre-inst-guile-env +stamp-h1 diff --git a/ChangeLog b/ChangeLog index c42959184..b64d3cc60 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2007-01-22 Han-Wen Nienhuys + + * .gitignore: new file. Make using git easier. + 2007-01-03 Han-Wen Nienhuys * autogen.sh (Module): only try to run render-bugs if it exists. From cb90e2cbe7cc0ea11c4f3f7310ee9f07f59ecd4a Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:11:30 +0000 Subject: [PATCH 100/116] add FSF header. --- libguile/ChangeLog | 4 ++++ libguile/private-gc.h | 21 ++++++++++++++++++--- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index da886baf9..588927814 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2007-01-22 Han-Wen Nienhuys + + * private-gc.h: add FSF header. + 2007-01-19 Han-Wen Nienhuys * debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if diff --git a/libguile/private-gc.h b/libguile/private-gc.h index 7c0fd883b..34d789b30 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -1,7 +1,22 @@ /* - (c) FSF 2002. -*/ - + * private-gc.h - private declarations for garbage collection. + * + * Copyright (C) 2002, 03, 04, 05, 06, 07 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 2.1 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 + */ #ifndef PRIVATE_GC #define PRIVATE_GC From 22fc179acda911108e697446921306b5c9eb644b Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:14:40 +0000 Subject: [PATCH 101/116] * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, read.h, stacks.c, symbols.c, throw.c: use private-options.h * private-options.h: new file: contain hardcoded option definitions. --- libguile/ChangeLog | 7 +++ libguile/backtrace.c | 1 + libguile/debug.c | 5 +- libguile/debug.h | 16 ------ libguile/deprecation.c | 3 ++ libguile/eq.c | 3 ++ libguile/eval.h | 21 -------- libguile/gsubr.c | 2 + libguile/init.c | 1 + libguile/macros.c | 2 + libguile/print.c | 3 ++ libguile/print.h | 9 ---- libguile/private-options.h | 103 +++++++++++++++++++++++++++++++++++++ libguile/read.c | 2 + libguile/read.h | 12 ----- libguile/stacks.c | 2 + libguile/symbols.c | 3 ++ libguile/throw.c | 3 ++ 18 files changed, 139 insertions(+), 59 deletions(-) create mode 100644 libguile/private-options.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 588927814..6c268575b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,12 @@ 2007-01-22 Han-Wen Nienhuys + * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c + eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, + read.h, stacks.c, symbols.c, throw.c: use private-options.h + + * private-options.h: new file: contain hardcoded option + definitions. + * private-gc.h: add FSF header. 2007-01-19 Han-Wen Nienhuys diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 38d7a8382..a8bc12059 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -47,6 +47,7 @@ #include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" +#include "libguile/private-options.h" /* {Error reporting and backtraces} * diff --git a/libguile/debug.c b/libguile/debug.c index 01b8204d1..08793f3ff 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -42,8 +42,11 @@ #include "libguile/validate.h" #include "libguile/debug.h" + +#include "libguile/private-options.h" + /* {Run time control of the debugging evaluator} */ @@ -74,6 +77,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, } #undef FUNC_NAME + static void with_traps_before (void *data) { @@ -112,7 +116,6 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, #undef FUNC_NAME - SCM_SYMBOL (scm_sym_procname, "procname"); SCM_SYMBOL (scm_sym_dots, "..."); SCM_SYMBOL (scm_sym_source, "source"); diff --git a/libguile/debug.h b/libguile/debug.h index ce7dcfe20..79afa4d53 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -42,23 +42,7 @@ /* scm_debug_opts is defined in eval.c. */ -SCM_API scm_t_option scm_debug_opts[]; -#define SCM_BREAKPOINTS_P scm_debug_opts[1].val -#define SCM_TRACE_P scm_debug_opts[2].val -#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val -#define SCM_BACKWARDS_P scm_debug_opts[4].val -#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val -#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val -#define SCM_N_FRAMES scm_debug_opts[7].val -#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val -#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val -#define SCM_BACKTRACE_P scm_debug_opts[10].val -#define SCM_DEVAL_P scm_debug_opts[11].val -#define SCM_STACK_LIMIT scm_debug_opts[12].val -#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val -#define SCM_WARN_DEPRECATED scm_debug_opts[14].val -#define SCM_N_DEBUG_OPTIONS 15 SCM_API int scm_debug_mode_p; SCM_API int scm_check_entry_p; diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 6e314ddd9..22073033e 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -31,6 +31,9 @@ #include "libguile/strings.h" #include "libguile/ports.h" +#include "libguile/private-options.h" + + /* Windows defines. */ #ifdef __MINGW32__ #define vsnprintf _vsnprintf diff --git a/libguile/eq.c b/libguile/eq.c index 7c7e76d0e..ebc91c93b 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -36,6 +36,9 @@ #include "libguile/validate.h" #include "libguile/eq.h" + +#include "libguile/private-options.h" + #ifdef HAVE_STRING_H diff --git a/libguile/eval.h b/libguile/eval.h index dec9983c7..247cf164e 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -32,27 +32,6 @@ /* {Options} */ -SCM_API scm_t_option scm_eval_opts[]; - -#define SCM_EVAL_STACK scm_eval_opts[0].val -#define SCM_N_EVAL_OPTIONS 1 - -SCM_API long scm_eval_stack; - -SCM_API scm_t_option scm_evaluator_trap_table[]; - -SCM_API SCM scm_eval_options_interface (SCM setting); - - -#define SCM_TRAPS_P scm_evaluator_trap_table[0].val -#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val -#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val -#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val -#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) -#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val)) -#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val)) -#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val -#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val)) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index c0bdd841e..356d771e8 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -24,6 +24,8 @@ #include "libguile/gsubr.h" #include "libguile/deprecation.h" + +#include "libguile/private-options.h" /* * gsubr.c diff --git a/libguile/init.c b/libguile/init.c index 219ef620d..ff69ab9d1 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -127,6 +127,7 @@ #include "libguile/deprecated.h" #include "libguile/init.h" +#include "libguile/private-options.h" #ifdef HAVE_STRING_H #include diff --git a/libguile/macros.c b/libguile/macros.c index ede875154..db279ec7e 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -30,6 +30,8 @@ #include "libguile/validate.h" #include "libguile/macros.h" +#include "libguile/private-options.h" + scm_t_bits scm_tc16_macro; diff --git a/libguile/print.c b/libguile/print.c index fa6ea8c1a..fb9a74ef2 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -43,6 +43,9 @@ #include "libguile/validate.h" #include "libguile/print.h" + +#include "libguile/private-options.h" + /* {Names of immediate symbols} diff --git a/libguile/print.h b/libguile/print.h index 7e59ba8b3..740aa281f 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -26,15 +26,6 @@ #include "libguile/options.h" -SCM_API scm_t_option scm_print_opts[]; - -#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val)) -#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) -#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val)) -#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val)) -#define SCM_PRINT_KEYWORD_STYLE_I 4 -#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val)) -#define SCM_N_PRINT_OPTIONS 5 /* State information passed around during printing. */ diff --git a/libguile/private-options.h b/libguile/private-options.h new file mode 100644 index 000000000..6ec83538c --- /dev/null +++ b/libguile/private-options.h @@ -0,0 +1,103 @@ +/* + * private-options.h - private declarations for option handling + * + * We put this in a private header, since layout of data structures + * is an implementation detail that we want to hide. + * + * Copyright (C) 2002, 03, 04, 05, 06, 07 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 2.1 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 + */ + +#ifndef PRIVATE_OPTIONS +#define PRIVATE_OPTIONS + +/* + evaluator + */ +SCM_API scm_t_option scm_eval_opts[]; + +SCM_API long scm_eval_stack; + +SCM_API scm_t_option scm_evaluator_trap_table[]; + +SCM_API SCM scm_eval_options_interface (SCM setting); + +#define SCM_EVAL_STACK scm_eval_opts[0].val + +#define SCM_TRAPS_P scm_evaluator_trap_table[0].val +#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val +#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val +#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val +#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val)) +#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val)) +#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val)) +#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val +#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val)) + +/* + debugging. + */ +SCM_API scm_t_option scm_debug_opts[]; + +#define SCM_BREAKPOINTS_P scm_debug_opts[1].val +#define SCM_TRACE_P scm_debug_opts[2].val +#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val +#define SCM_BACKWARDS_P scm_debug_opts[4].val +#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val +#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val +#define SCM_N_FRAMES scm_debug_opts[7].val +#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val +#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val +#define SCM_BACKTRACE_P scm_debug_opts[10].val +#define SCM_DEVAL_P scm_debug_opts[11].val +#define SCM_STACK_LIMIT scm_debug_opts[12].val +#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val +#define SCM_WARN_DEPRECATED scm_debug_opts[14].val +#define SCM_N_DEBUG_OPTIONS 15 + + +/* + printing +*/ +SCM_API scm_t_option scm_print_opts[]; + +#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val)) +#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) +#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val)) +#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val)) +#define SCM_PRINT_KEYWORD_STYLE_I 4 +#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val)) +#define SCM_N_PRINT_OPTIONS 5 + + +/* + read + */ +SCM_API scm_t_option scm_read_opts[]; + +#define SCM_COPY_SOURCE_P scm_read_opts[0].val +#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val +#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val +#define SCM_KEYWORD_STYLE scm_read_opts[3].val +#if SCM_ENABLE_ELISP +#define SCM_ELISP_VECTORS_P scm_read_opts[4].val +#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val +#define SCM_N_READ_OPTIONS 6 +#else +#define SCM_N_READ_OPTIONS 4 +#endif + +#endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index d0c4a876f..de2e87bed 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -38,6 +38,8 @@ #include "libguile/srfi-4.h" #include "libguile/read.h" +#include "libguile/private-options.h" + diff --git a/libguile/read.h b/libguile/read.h index 4bfa59eb0..9ff362603 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -45,19 +45,7 @@ #define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t' -SCM_API scm_t_option scm_read_opts[]; -#define SCM_COPY_SOURCE_P scm_read_opts[0].val -#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val -#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val -#define SCM_KEYWORD_STYLE scm_read_opts[3].val -#if SCM_ENABLE_ELISP -#define SCM_ELISP_VECTORS_P scm_read_opts[4].val -#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val -#define SCM_N_READ_OPTIONS 6 -#else -#define SCM_N_READ_OPTIONS 4 -#endif diff --git a/libguile/stacks.c b/libguile/stacks.c index de85522ca..922c52231 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -32,6 +32,8 @@ #include "libguile/validate.h" #include "libguile/stacks.h" +#include "libguile/private-options.h" + /* {Frames and stacks} diff --git a/libguile/symbols.c b/libguile/symbols.c index c8b901706..d786dd94c 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -40,6 +40,9 @@ #include "libguile/validate.h" #include "libguile/symbols.h" +#include "libguile/private-options.h" + + #ifdef HAVE_STRING_H #include #endif diff --git a/libguile/throw.c b/libguile/throw.c index 9bffda770..02503c36a 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -39,6 +39,9 @@ #include "libguile/init.h" #include "libguile/strings.h" +#include "libguile/private-options.h" + + /* the jump buffer data structure */ static scm_t_bits tc16_jmpbuffer; From 0ee05b85ee23af97afc6c45ca2c66f94d2cba50b Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:16:44 +0000 Subject: [PATCH 102/116] * eval.c: distangle. move duplicate code to eval.i.c and include twice. * eval.i.c: new file. * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, read.h, stacks.c, symbols.c, throw.c: use private-options.h --- libguile/ChangeLog | 5 + libguile/eval.c | 2067 +------------------------------------------- libguile/eval.i.c | 1922 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1963 insertions(+), 2031 deletions(-) create mode 100644 libguile/eval.i.c diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6c268575b..eb5d6e9ad 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2007-01-22 Han-Wen Nienhuys + * eval.c: distangle. move duplicate code to eval.i.c and include + twice. + + * eval.i.c: new file. + * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, read.h, stacks.c, symbols.c, throw.c: use private-options.h diff --git a/libguile/eval.c b/libguile/eval.c index cfbf5f3f8..fba9f4a65 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -20,12 +20,6 @@ #define _GNU_SOURCE -/* This file is read twice in order to produce debugging versions of ceval and - * scm_apply. These functions, deval and scm_dapply, are produced when we - * define the preprocessor macro DEVAL. The file is divided into sections - * which are treated differently with respect to DEVAL. The heads of these - * sections are marked with the string "SECTION:". */ - /* SECTION: This code is compiled once. */ @@ -35,8 +29,6 @@ #include "libguile/__scm.h" -#ifndef DEVAL - /* This blob per the Autoconf manual (under "Particular Functions"). */ #if HAVE_ALLOCA_H # include @@ -90,15 +82,18 @@ void *alloca (size_t); #include "libguile/vectors.h" #include "libguile/eval.h" +#include "libguile/private-options.h" + static SCM unmemoize_exprs (SCM expr, SCM env); static SCM canonicalize_define (SCM expr); static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check); static SCM unmemoize_builtin_macro (SCM expr, SCM env); -static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); - +static void ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); +static SCM ceval (SCM x, SCM env); +static SCM deval (SCM x, SCM env); @@ -2583,46 +2578,27 @@ scm_badargsp (SCM formals, SCM args) -/* The evaluator contains a plethora of EVAL symbols. This is an attempt at - * explanation. +/* The evaluator contains a plethora of EVAL symbols. * - * The following macros should be used in code which is read twice (where the - * choice of evaluator is hard soldered): * - * CEVAL is the symbol used within one evaluator to call itself. - * Originally, it is defined to ceval, but is redefined to deval during the - * second pass. - * * SCM_I_EVALIM is used when it is known that the expression is an * immediate. (This macro never calls an evaluator.) * - * EVAL evaluates an expression that is expected to have its symbols already + * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already * memoized. Expressions that are not of the form '(
...)' are * evaluated inline without calling an evaluator. * - * EVALCAR evaluates the car of an expression 'X:(Y: ...)', + * This macro uses ceval or deval depending on its 3rd argument. + * + * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y: ...)', * potentially replacing a symbol at the position Y: by its memoized * variable. If Y: is not of the form '( ...)', the * evaluation is performed inline without calling an evaluator. * - * The following macros should be used in code which is read once - * (where the choice of evaluator is dynamic): + * This macro uses ceval or deval depending on its 3rd argument. * - * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the - * debugging mode. - * - * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending - * on the debugging mode. - * - * The main motivation for keeping this plethora is efficiency - * together with maintainability (=> locality of code). */ -static SCM ceval (SCM x, SCM env); -static SCM deval (SCM x, SCM env); -#define CEVAL ceval - - #define SCM_I_EVALIM2(x) \ ((scm_is_eq ((x), SCM_EOL) \ ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \ @@ -2633,50 +2609,30 @@ static SCM deval (SCM x, SCM env); ? *scm_ilookup ((x), (env)) \ : SCM_I_EVALIM2(x)) -#define SCM_I_XEVAL(x, env) \ +#define SCM_I_XEVAL(x, env, debug_p) \ (SCM_IMP (x) \ ? SCM_I_EVALIM2 (x) \ : (SCM_VARIABLEP (x) \ ? SCM_VARIABLE_REF (x) \ : (scm_is_pair (x) \ - ? (scm_debug_mode_p \ + ? (debug_p \ ? deval ((x), (env)) \ : ceval ((x), (env))) \ : (x)))) -#define SCM_I_XEVALCAR(x, env) \ +#define SCM_I_XEVALCAR(x, env, debug_p) \ (SCM_IMP (SCM_CAR (x)) \ ? SCM_I_EVALIM (SCM_CAR (x), (env)) \ : (SCM_VARIABLEP (SCM_CAR (x)) \ ? SCM_VARIABLE_REF (SCM_CAR (x)) \ : (scm_is_pair (SCM_CAR (x)) \ - ? (scm_debug_mode_p \ + ? (debug_p \ ? deval (SCM_CAR (x), (env)) \ : ceval (SCM_CAR (x), (env))) \ : (!scm_is_symbol (SCM_CAR (x)) \ ? SCM_CAR (x) \ : *scm_lookupcar ((x), (env), 1))))) -#define EVAL(x, env) \ - (SCM_IMP (x) \ - ? SCM_I_EVALIM ((x), (env)) \ - : (SCM_VARIABLEP (x) \ - ? SCM_VARIABLE_REF (x) \ - : (scm_is_pair (x) \ - ? CEVAL ((x), (env)) \ - : (x)))) - -#define EVALCAR(x, env) \ - (SCM_IMP (SCM_CAR (x)) \ - ? SCM_I_EVALIM (SCM_CAR (x), (env)) \ - : (SCM_VARIABLEP (SCM_CAR (x)) \ - ? SCM_VARIABLE_REF (SCM_CAR (x)) \ - : (scm_is_pair (SCM_CAR (x)) \ - ? CEVAL (SCM_CAR (x), (env)) \ - : (!scm_is_symbol (SCM_CAR (x)) \ - ? SCM_CAR (x) \ - : *scm_lookupcar ((x), (env), 1))))) - scm_i_pthread_mutex_t source_mutex; @@ -2937,25 +2893,7 @@ lazy_memoize_variable (const SCM symbol, const SCM environment) SCM scm_eval_car (SCM pair, SCM env) { - return SCM_I_XEVALCAR (pair, env); -} - - -SCM -scm_eval_args (SCM l, SCM env, SCM proc) -{ - SCM results = SCM_EOL, *lloc = &results, res; - while (scm_is_pair (l)) - { - res = EVALCAR (l, env); - - *lloc = scm_list_1 (res); - lloc = SCM_CDRLOC (*lloc); - l = SCM_CDR (l); - } - if (!scm_is_null (l)) - scm_wrong_num_args (proc); - return results; + return SCM_I_XEVALCAR (pair, env, scm_debug_mode_p); } @@ -2982,70 +2920,13 @@ scm_eval_body (SCM code, SCM env) } } else - SCM_I_XEVAL (SCM_CAR (code), env); + SCM_I_XEVAL (SCM_CAR (code), env, scm_debug_mode_p); code = next; next = SCM_CDR (code); } - return SCM_I_XEVALCAR (code, env); + return SCM_I_XEVALCAR (code, env, scm_debug_mode_p); } -#endif /* !DEVAL */ - - -/* SECTION: This code is specific for the debugging support. One - * branch is read when DEVAL isn't defined, the other when DEVAL is - * defined. - */ - -#ifndef DEVAL - -#define SCM_APPLY scm_apply -#define PREP_APPLY(proc, args) -#define ENTER_APPLY -#define RETURN(x) do { return x; } while (0) -#ifdef STACK_CHECKING -#ifndef NO_CEVAL_STACK_CHECKING -#define EVAL_STACK_CHECKING -#endif -#endif - -#else /* !DEVAL */ - -#undef CEVAL -#define CEVAL deval /* Substitute all uses of ceval */ - -#undef SCM_APPLY -#define SCM_APPLY scm_dapply - -#undef PREP_APPLY -#define PREP_APPLY(p, l) \ -{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } - -#undef ENTER_APPLY -#define ENTER_APPLY \ -do { \ - SCM_SET_ARGSREADY (debug);\ - if (scm_check_apply_p && SCM_TRAPS_P)\ - if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\ - {\ - SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ - SCM_SET_TRACED_FRAME (debug); \ - SCM_TRAPS_P = 0;\ - tmp = scm_make_debugobj (&debug);\ - scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ - SCM_TRAPS_P = 1;\ - }\ -} while (0) - -#undef RETURN -#define RETURN(e) do { proc = (e); goto exit; } while (0) - -#ifdef STACK_CHECKING -#ifndef EVAL_STACK_CHECKING -#define EVAL_STACK_CHECKING -#endif -#endif - /* scm_last_debug_frame contains a pointer to the last debugging information * stack frame. It is accessed very often from the debugging evaluator, so it @@ -3090,7 +2971,12 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." }, { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, - { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, + + + /* + FIXME. + */ + { SCM_OPTION_INTEGER, "stack", 0, "Stack size limit (measured in words; 0 = no check)." }, { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}, { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }, { 0 }, @@ -3098,9 +2984,9 @@ scm_t_option scm_debug_opts[] = { /* - this ordering is awkward and illogical, but we maintain it for - compatibility. --hwn -*/ + * this ordering is awkward and illogical, but we maintain it for + * compatibility. --hwn + */ scm_t_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, @@ -3161,1520 +3047,6 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, #undef FUNC_NAME -static SCM -deval_args (SCM l, SCM env, SCM proc, SCM *lloc) -{ - SCM *results = lloc; - while (scm_is_pair (l)) - { - const SCM res = EVALCAR (l, env); - - *lloc = scm_list_1 (res); - lloc = SCM_CDRLOC (*lloc); - l = SCM_CDR (l); - } - if (!scm_is_null (l)) - scm_wrong_num_args (proc); - return *results; -} - -static void -eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol) -{ - SCM argv[10]; - int i = 0, imax = sizeof (argv) / sizeof (SCM); - - while (!scm_is_null (init_forms)) - { - if (imax == i) - { - eval_letrec_inits (env, init_forms, init_values_eol); - break; - } - argv[i++] = EVALCAR (init_forms, env); - init_forms = SCM_CDR (init_forms); - } - - for (i--; i >= 0; i--) - { - **init_values_eol = scm_list_1 (argv[i]); - *init_values_eol = SCM_CDRLOC (**init_values_eol); - } -} - -#endif /* !DEVAL */ - - -/* SECTION: This code is compiled twice. - */ - - -/* Update the toplevel environment frame ENV so that it refers to the - * current module. */ -#define UPDATE_TOPLEVEL_ENV(env) \ - do { \ - SCM p = scm_current_module_lookup_closure (); \ - if (p != SCM_CAR (env)) \ - env = scm_top_level_env (p); \ - } while (0) - - -#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) - - -/* This is the evaluator. Like any real monster, it has three heads: - * - * ceval is the non-debugging evaluator, deval is the debugging version. Both - * are implemented using a common code base, using the following mechanism: - * CEVAL is a macro, which is either defined to ceval or deval. Thus, there - * is no function CEVAL, but the code for CEVAL actually compiles to either - * ceval or deval. When CEVAL is defined to ceval, it is known that the macro - * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL - * is known to be defined. Thus, in CEVAL parts for the debugging evaluator - * are enclosed within #ifdef DEVAL ... #endif. - * - * All three (ceval, deval and their common implementation CEVAL) take two - * input parameters, x and env: x is a single expression to be evalutated. - * env is the environment in which bindings are searched. - * - * x is known to be a pair. Since x is a single expression, it is necessarily - * in a tail position. If x is just a call to another function like in the - * expression (foo exp1 exp2 ...), the realization of that call therefore - * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc., - * however, may do so). This is realized by making extensive use of 'goto' - * statements within the evaluator: The gotos replace recursive calls to - * CEVAL, thus re-using the same stack frame that CEVAL was already using. - * If, however, x represents some form that requires to evaluate a sequence of - * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are - * performed for all but the last expression of that sequence. */ - -static SCM -CEVAL (SCM x, SCM env) -{ - SCM proc, arg1; -#ifdef DEVAL - scm_t_debug_frame debug; - scm_t_debug_info *debug_info_end; - debug.prev = scm_i_last_debug_frame (); - debug.status = 0; - /* - * The debug.vect contains twice as much scm_t_debug_info frames as the - * user has specified with (debug-set! frames ). - * - * Even frames are eval frames, odd frames are apply frames. - */ - debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size - * sizeof (scm_t_debug_info)); - debug.info = debug.vect; - debug_info_end = debug.vect + scm_debug_eframe_size; - scm_i_set_last_debug_frame (&debug); -#endif -#ifdef EVAL_STACK_CHECKING - if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) - { -#ifdef DEVAL - debug.info->e.exp = x; - debug.info->e.env = env; -#endif - scm_report_stack_overflow (); - } -#endif - -#ifdef DEVAL - goto start; -#endif - -loop: -#ifdef DEVAL - SCM_CLEAR_ARGSREADY (debug); - if (SCM_OVERFLOWP (debug)) - --debug.info; - /* - * In theory, this should be the only place where it is necessary to - * check for space in debug.vect since both eval frames and - * available space are even. - * - * For this to be the case, however, it is necessary that primitive - * special forms which jump back to `loop', `begin' or some similar - * label call PREP_APPLY. - */ - else if (++debug.info >= debug_info_end) - { - SCM_SET_OVERFLOW (debug); - debug.info -= 2; - } - -start: - debug.info->e.exp = x; - debug.info->e.env = env; - if (scm_check_entry_p && SCM_TRAPS_P) - { - if (SCM_ENTER_FRAME_P - || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) - { - SCM stackrep; - SCM tail = scm_from_bool (SCM_TAILRECP (debug)); - SCM_SET_TAILREC (debug); - stackrep = scm_make_debugobj (&debug); - SCM_TRAPS_P = 0; - stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR, - scm_sym_enter_frame, - stackrep, - tail, - unmemoize_expression (x, env)); - SCM_TRAPS_P = 1; - if (scm_is_pair (stackrep) && - scm_is_eq (SCM_CAR (stackrep), sym_instead)) - { - /* This gives the possibility for the debugger to modify - the source expression before evaluation. */ - x = SCM_CDR (stackrep); - if (SCM_IMP (x)) - RETURN (x); - } - } - } -#endif -dispatch: - SCM_TICK; - if (SCM_ISYMP (SCM_CAR (x))) - { - switch (ISYMNUM (SCM_CAR (x))) - { - case (ISYMNUM (SCM_IM_AND)): - x = SCM_CDR (x); - while (!scm_is_null (SCM_CDR (x))) - { - SCM test_result = EVALCAR (x, env); - if (scm_is_false (test_result) || SCM_NILP (test_result)) - RETURN (SCM_BOOL_F); - else - x = SCM_CDR (x); - } - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - - case (ISYMNUM (SCM_IM_BEGIN)): - x = SCM_CDR (x); - if (scm_is_null (x)) - RETURN (SCM_UNSPECIFIED); - - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - - begin: - /* If we are on toplevel with a lookup closure, we need to sync - with the current module. */ - if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env))) - { - UPDATE_TOPLEVEL_ENV (env); - while (!scm_is_null (SCM_CDR (x))) - { - EVALCAR (x, env); - UPDATE_TOPLEVEL_ENV (env); - x = SCM_CDR (x); - } - goto carloop; - } - else - goto nontoplevel_begin; - - nontoplevel_begin: - while (!scm_is_null (SCM_CDR (x))) - { - const SCM form = SCM_CAR (x); - if (SCM_IMP (form)) - { - if (SCM_ISYMP (form)) - { - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&source_mutex); - /* check for race condition */ - if (SCM_ISYMP (SCM_CAR (x))) - m_expand_body (x, env); - scm_dynwind_end (); - goto nontoplevel_begin; - } - else - SCM_VALIDATE_NON_EMPTY_COMBINATION (form); - } - else - (void) EVAL (form, env); - x = SCM_CDR (x); - } - - carloop: - { - /* scm_eval last form in list */ - const SCM last_form = SCM_CAR (x); - - if (scm_is_pair (last_form)) - { - /* This is by far the most frequent case. */ - x = last_form; - goto loop; /* tail recurse */ - } - else if (SCM_IMP (last_form)) - RETURN (SCM_I_EVALIM (last_form, env)); - else if (SCM_VARIABLEP (last_form)) - RETURN (SCM_VARIABLE_REF (last_form)); - else if (scm_is_symbol (last_form)) - RETURN (*scm_lookupcar (x, env, 1)); - else - RETURN (last_form); - } - - - case (ISYMNUM (SCM_IM_CASE)): - x = SCM_CDR (x); - { - const SCM key = EVALCAR (x, env); - x = SCM_CDR (x); - while (!scm_is_null (x)) - { - const SCM clause = SCM_CAR (x); - SCM labels = SCM_CAR (clause); - if (scm_is_eq (labels, SCM_IM_ELSE)) - { - x = SCM_CDR (clause); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - while (!scm_is_null (labels)) - { - const SCM label = SCM_CAR (labels); - if (scm_is_eq (label, key) - || scm_is_true (scm_eqv_p (label, key))) - { - x = SCM_CDR (clause); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - labels = SCM_CDR (labels); - } - x = SCM_CDR (x); - } - } - RETURN (SCM_UNSPECIFIED); - - - case (ISYMNUM (SCM_IM_COND)): - x = SCM_CDR (x); - while (!scm_is_null (x)) - { - const SCM clause = SCM_CAR (x); - if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) - { - x = SCM_CDR (clause); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - else - { - arg1 = EVALCAR (clause, env); - /* SRFI 61 extended cond */ - if (!scm_is_null (SCM_CDR (clause)) - && !scm_is_null (SCM_CDDR (clause)) - && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW)) - { - SCM xx, guard_result; - if (SCM_VALUESP (arg1)) - arg1 = scm_struct_ref (arg1, SCM_INUM0); - else - arg1 = scm_list_1 (arg1); - xx = SCM_CDR (clause); - proc = EVALCAR (xx, env); - guard_result = SCM_APPLY (proc, arg1, SCM_EOL); - if (scm_is_true (guard_result) - && !SCM_NILP (guard_result)) - { - proc = SCM_CDDR (xx); - proc = EVALCAR (proc, env); - PREP_APPLY (proc, arg1); - goto apply_proc; - } - } - else if (scm_is_true (arg1) && !SCM_NILP (arg1)) - { - x = SCM_CDR (clause); - if (scm_is_null (x)) - RETURN (arg1); - else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) - { - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - else - { - proc = SCM_CDR (x); - proc = EVALCAR (proc, env); - PREP_APPLY (proc, scm_list_1 (arg1)); - ENTER_APPLY; - goto evap1; - } - } - x = SCM_CDR (x); - } - } - RETURN (SCM_UNSPECIFIED); - - - case (ISYMNUM (SCM_IM_DO)): - x = SCM_CDR (x); - { - /* Compute the initialization values and the initial environment. */ - SCM init_forms = SCM_CAR (x); - SCM init_values = SCM_EOL; - while (!scm_is_null (init_forms)) - { - init_values = scm_cons (EVALCAR (init_forms, env), init_values); - init_forms = SCM_CDR (init_forms); - } - x = SCM_CDR (x); - env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); - } - x = SCM_CDR (x); - { - SCM test_form = SCM_CAR (x); - SCM body_forms = SCM_CADR (x); - SCM step_forms = SCM_CDDR (x); - - SCM test_result = EVALCAR (test_form, env); - - while (scm_is_false (test_result) || SCM_NILP (test_result)) - { - { - /* Evaluate body forms. */ - SCM temp_forms; - for (temp_forms = body_forms; - !scm_is_null (temp_forms); - temp_forms = SCM_CDR (temp_forms)) - { - SCM form = SCM_CAR (temp_forms); - /* Dirk:FIXME: We only need to eval forms that may have - * a side effect here. This is only true for forms that - * start with a pair. All others are just constants. - * Since with the current memoizer 'form' may hold a - * constant, we call EVAL here to handle the constant - * cases. In the long run it would make sense to have - * the macro transformer of 'do' eliminate all forms - * that have no sideeffect. Then instead of EVAL we - * could call CEVAL directly here. */ - (void) EVAL (form, env); - } - } - - { - /* Evaluate the step expressions. */ - SCM temp_forms; - SCM step_values = SCM_EOL; - for (temp_forms = step_forms; - !scm_is_null (temp_forms); - temp_forms = SCM_CDR (temp_forms)) - { - const SCM value = EVALCAR (temp_forms, env); - step_values = scm_cons (value, step_values); - } - env = SCM_EXTEND_ENV (SCM_CAAR (env), - step_values, - SCM_CDR (env)); - } - - test_result = EVALCAR (test_form, env); - } - } - x = SCM_CDAR (x); - if (scm_is_null (x)) - RETURN (SCM_UNSPECIFIED); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto nontoplevel_begin; - - - case (ISYMNUM (SCM_IM_IF)): - x = SCM_CDR (x); - { - SCM test_result = EVALCAR (x, env); - x = SCM_CDR (x); /* then expression */ - if (scm_is_false (test_result) || SCM_NILP (test_result)) - { - x = SCM_CDR (x); /* else expression */ - if (scm_is_null (x)) - RETURN (SCM_UNSPECIFIED); - } - } - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - - - case (ISYMNUM (SCM_IM_LET)): - x = SCM_CDR (x); - { - SCM init_forms = SCM_CADR (x); - SCM init_values = SCM_EOL; - do - { - init_values = scm_cons (EVALCAR (init_forms, env), init_values); - init_forms = SCM_CDR (init_forms); - } - while (!scm_is_null (init_forms)); - env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); - } - x = SCM_CDDR (x); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto nontoplevel_begin; - - - case (ISYMNUM (SCM_IM_LETREC)): - x = SCM_CDR (x); - env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env); - x = SCM_CDR (x); - { - SCM init_forms = SCM_CAR (x); - SCM init_values = scm_list_1 (SCM_BOOL_T); - SCM *init_values_eol = SCM_CDRLOC (init_values); - eval_letrec_inits (env, init_forms, &init_values_eol); - SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values)); - } - x = SCM_CDR (x); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto nontoplevel_begin; - - - case (ISYMNUM (SCM_IM_LETSTAR)): - x = SCM_CDR (x); - { - SCM bindings = SCM_CAR (x); - if (!scm_is_null (bindings)) - { - do - { - SCM name = SCM_CAR (bindings); - SCM init = SCM_CDR (bindings); - env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); - bindings = SCM_CDR (init); - } - while (!scm_is_null (bindings)); - } - } - x = SCM_CDR (x); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto nontoplevel_begin; - - - case (ISYMNUM (SCM_IM_OR)): - x = SCM_CDR (x); - while (!scm_is_null (SCM_CDR (x))) - { - SCM val = EVALCAR (x, env); - if (scm_is_true (val) && !SCM_NILP (val)) - RETURN (val); - else - x = SCM_CDR (x); - } - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - - - case (ISYMNUM (SCM_IM_LAMBDA)): - RETURN (scm_closure (SCM_CDR (x), env)); - - - case (ISYMNUM (SCM_IM_QUOTE)): - RETURN (SCM_CDR (x)); - - - case (ISYMNUM (SCM_IM_SET_X)): - x = SCM_CDR (x); - { - SCM *location; - SCM variable = SCM_CAR (x); - if (SCM_ILOCP (variable)) - location = scm_ilookup (variable, env); - else if (SCM_VARIABLEP (variable)) - location = SCM_VARIABLE_LOC (variable); - else - { - /* (scm_is_symbol (variable)) is known to be true */ - variable = lazy_memoize_variable (variable, env); - SCM_SETCAR (x, variable); - location = SCM_VARIABLE_LOC (variable); - } - x = SCM_CDR (x); - *location = EVALCAR (x, env); - } - RETURN (SCM_UNSPECIFIED); - - - case (ISYMNUM (SCM_IM_APPLY)): - /* Evaluate the procedure to be applied. */ - x = SCM_CDR (x); - proc = EVALCAR (x, env); - PREP_APPLY (proc, SCM_EOL); - - /* Evaluate the argument holding the list of arguments */ - x = SCM_CDR (x); - arg1 = EVALCAR (x, env); - - apply_proc: - /* Go here to tail-apply a procedure. PROC is the procedure and - * ARG1 is the list of arguments. PREP_APPLY must have been called - * before jumping to apply_proc. */ - if (SCM_CLOSUREP (proc)) - { - SCM formals = SCM_CLOSURE_FORMALS (proc); -#ifdef DEVAL - debug.info->a.args = arg1; -#endif - if (scm_badargsp (formals, arg1)) - scm_wrong_num_args (proc); - ENTER_APPLY; - /* Copy argument list */ - if (SCM_NULL_OR_NIL_P (arg1)) - env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); - else - { - SCM args = scm_list_1 (SCM_CAR (arg1)); - SCM tail = args; - arg1 = SCM_CDR (arg1); - while (!SCM_NULL_OR_NIL_P (arg1)) - { - SCM new_tail = scm_list_1 (SCM_CAR (arg1)); - SCM_SETCDR (tail, new_tail); - tail = new_tail; - arg1 = SCM_CDR (arg1); - } - env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc)); - } - - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } - else - { - ENTER_APPLY; - RETURN (SCM_APPLY (proc, arg1, SCM_EOL)); - } - - - case (ISYMNUM (SCM_IM_CONT)): - { - int first; - SCM val = scm_make_continuation (&first); - - if (!first) - RETURN (val); - else - { - arg1 = val; - proc = SCM_CDR (x); - proc = EVALCAR (proc, env); - PREP_APPLY (proc, scm_list_1 (arg1)); - ENTER_APPLY; - goto evap1; - } - } - - - case (ISYMNUM (SCM_IM_DELAY)): - RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); - -#if 0 - /* See futures.h for a comment why futures are not enabled. - */ - case (ISYMNUM (SCM_IM_FUTURE)): - RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); -#endif - - /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following - code (type_dispatch) is intended to be the tail of the case - clause for the internal macro SCM_IM_DISPATCH. Please don't - remove it from this location without discussing it with Mikael - */ - - /* The type dispatch code is duplicated below - * (c.f. objects.c:scm_mcache_compute_cmethod) since that - * cuts down execution time for type dispatch to 50%. */ - type_dispatch: /* inputs: x, arg1 */ - /* Type dispatch means to determine from the types of the function - * arguments (i. e. the 'signature' of the call), which method from - * a generic function is to be called. This process of selecting - * the right method takes some time. To speed it up, guile uses - * caching: Together with the macro call to dispatch the signatures - * of some previous calls to that generic function from the same - * place are stored (in the code!) in a cache that we call the - * 'method cache'. This is done since it is likely, that - * consecutive calls to dispatch from that position in the code will - * have the same signature. Thus, the type dispatch works as - * follows: First, determine a hash value from the signature of the - * actual arguments. Second, use this hash value as an index to - * find that same signature in the method cache stored at this - * position in the code. If found, you have also found the - * corresponding method that belongs to that signature. If the - * signature is not found in the method cache, you have to perform a - * full search over all signatures stored with the generic - * function. */ - { - unsigned long int specializers; - unsigned long int hash_value; - unsigned long int cache_end_pos; - unsigned long int mask; - SCM method_cache; - - { - SCM z = SCM_CDDR (x); - SCM tmp = SCM_CADR (z); - specializers = scm_to_ulong (SCM_CAR (z)); - - /* Compute a hash value for searching the method cache. There - * are two variants for computing the hash value, a (rather) - * complicated one, and a simple one. For the complicated one - * explained below, tmp holds a number that is used in the - * computation. */ - if (scm_is_simple_vector (tmp)) - { - /* This method of determining the hash value is much - * simpler: Set the hash value to zero and just perform a - * linear search through the method cache. */ - method_cache = tmp; - mask = (unsigned long int) ((long) -1); - hash_value = 0; - cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache); - } - else - { - /* Use the signature of the actual arguments to determine - * the hash value. This is done as follows: Each class has - * an array of random numbers, that are determined when the - * class is created. The integer 'hashset' is an index into - * that array of random numbers. Now, from all classes that - * are part of the signature of the actual arguments, the - * random numbers at index 'hashset' are taken and summed - * up, giving the hash value. The value of 'hashset' is - * stored at the call to dispatch. This allows to have - * different 'formulas' for calculating the hash value at - * different places where dispatch is called. This allows - * to optimize the hash formula at every individual place - * where dispatch is called, such that hopefully the hash - * value that is computed will directly point to the right - * method in the method cache. */ - unsigned long int hashset = scm_to_ulong (tmp); - unsigned long int counter = specializers + 1; - SCM tmp_arg = arg1; - hash_value = 0; - while (!scm_is_null (tmp_arg) && counter != 0) - { - SCM class = scm_class_of (SCM_CAR (tmp_arg)); - hash_value += SCM_INSTANCE_HASH (class, hashset); - tmp_arg = SCM_CDR (tmp_arg); - counter--; - } - z = SCM_CDDR (z); - method_cache = SCM_CADR (z); - mask = scm_to_ulong (SCM_CAR (z)); - hash_value &= mask; - cache_end_pos = hash_value; - } - } - - { - /* Search the method cache for a method with a matching - * signature. Start the search at position 'hash_value'. The - * hashing implementation uses linear probing for conflict - * resolution, that is, if the signature in question is not - * found at the starting index in the hash table, the next table - * entry is tried, and so on, until in the worst case the whole - * cache has been searched, but still the signature has not been - * found. */ - SCM z; - do - { - SCM args = arg1; /* list of arguments */ - z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value); - while (!scm_is_null (args)) - { - /* More arguments than specifiers => CLASS != ENV */ - SCM class_of_arg = scm_class_of (SCM_CAR (args)); - if (!scm_is_eq (class_of_arg, SCM_CAR (z))) - goto next_method; - args = SCM_CDR (args); - z = SCM_CDR (z); - } - /* Fewer arguments than specifiers => CAR != ENV */ - if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) - goto apply_cmethod; - next_method: - hash_value = (hash_value + 1) & mask; - } while (hash_value != cache_end_pos); - - /* No appropriate method was found in the cache. */ - z = scm_memoize_method (x, arg1); - - apply_cmethod: /* inputs: z, arg1 */ - { - SCM formals = SCM_CMETHOD_FORMALS (z); - env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); - x = SCM_CMETHOD_BODY (z); - goto nontoplevel_begin; - } - } - } - - - case (ISYMNUM (SCM_IM_SLOT_REF)): - x = SCM_CDR (x); - { - SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); - RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); - } - - - case (ISYMNUM (SCM_IM_SLOT_SET_X)): - x = SCM_CDR (x); - { - SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_I_INUM (SCM_CADR (x)); - SCM value = EVALCAR (SCM_CDDR (x), env); - SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); - RETURN (SCM_UNSPECIFIED); - } - - -#if SCM_ENABLE_ELISP - - case (ISYMNUM (SCM_IM_NIL_COND)): - { - SCM test_form = SCM_CDR (x); - x = SCM_CDR (test_form); - while (!SCM_NULL_OR_NIL_P (x)) - { - SCM test_result = EVALCAR (test_form, env); - if (!(scm_is_false (test_result) - || SCM_NULL_OR_NIL_P (test_result))) - { - if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) - RETURN (test_result); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - } - else - { - test_form = SCM_CDR (x); - x = SCM_CDR (test_form); - } - } - x = test_form; - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - } - -#endif /* SCM_ENABLE_ELISP */ - - case (ISYMNUM (SCM_IM_BIND)): - { - SCM vars, exps, vals; - - x = SCM_CDR (x); - vars = SCM_CAAR (x); - exps = SCM_CDAR (x); - vals = SCM_EOL; - while (!scm_is_null (exps)) - { - vals = scm_cons (EVALCAR (exps, env), vals); - exps = SCM_CDR (exps); - } - - scm_swap_bindings (vars, vals); - scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ())); - - /* Ignore all but the last evaluation result. */ - for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x)) - { - if (scm_is_pair (SCM_CAR (x))) - CEVAL (SCM_CAR (x), env); - } - proc = EVALCAR (x, env); - - scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); - scm_swap_bindings (vars, vals); - - RETURN (proc); - } - - - case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): - { - SCM producer; - - x = SCM_CDR (x); - producer = EVALCAR (x, env); - x = SCM_CDR (x); - proc = EVALCAR (x, env); /* proc is the consumer. */ - arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); - if (SCM_VALUESP (arg1)) - { - /* The list of arguments is not copied. Rather, it is assumed - * that this has been done by the 'values' procedure. */ - arg1 = scm_struct_ref (arg1, SCM_INUM0); - } - else - { - arg1 = scm_list_1 (arg1); - } - PREP_APPLY (proc, arg1); - goto apply_proc; - } - - - default: - break; - } - } - else - { - if (SCM_VARIABLEP (SCM_CAR (x))) - proc = SCM_VARIABLE_REF (SCM_CAR (x)); - else if (SCM_ILOCP (SCM_CAR (x))) - proc = *scm_ilookup (SCM_CAR (x), env); - else if (scm_is_pair (SCM_CAR (x))) - proc = CEVAL (SCM_CAR (x), env); - else if (scm_is_symbol (SCM_CAR (x))) - { - SCM orig_sym = SCM_CAR (x); - { - SCM *location = scm_lookupcar1 (x, env, 1); - if (location == NULL) - { - /* we have lost the race, start again. */ - goto dispatch; - } - proc = *location; -#ifdef DEVAL - if (scm_check_memoize_p && SCM_TRAPS_P) - { - SCM_CLEAR_TRACED_FRAME (debug); - SCM arg1 = scm_make_debugobj (&debug); - SCM retval = SCM_BOOL_T; - SCM_TRAPS_P = 0; - retval = scm_call_4 (SCM_MEMOIZE_HDLR, - scm_sym_memoize_symbol, - arg1, x, env); - - /* - do something with retval? - */ - SCM_TRAPS_P = 1; - } -#endif - } - - if (SCM_MACROP (proc)) - { - SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of - lookupcar */ - handle_a_macro: /* inputs: x, env, proc */ -#ifdef DEVAL - /* Set a flag during macro expansion so that macro - application frames can be deleted from the backtrace. */ - SCM_SET_MACROEXP (debug); -#endif - arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, - scm_cons (env, scm_listofnull)); -#ifdef DEVAL - SCM_CLEAR_MACROEXP (debug); -#endif - switch (SCM_MACRO_TYPE (proc)) - { - case 3: - case 2: - if (!scm_is_pair (arg1)) - arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); - - assert (!scm_is_eq (x, SCM_CAR (arg1)) - && !scm_is_eq (x, SCM_CDR (arg1))); - -#ifdef DEVAL - if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) - { - SCM_CRITICAL_SECTION_START; - SCM_SETCAR (x, SCM_CAR (arg1)); - SCM_SETCDR (x, SCM_CDR (arg1)); - SCM_CRITICAL_SECTION_END; - goto dispatch; - } - /* Prevent memoizing of debug info expression. */ - debug.info->e.exp = scm_cons_source (debug.info->e.exp, - SCM_CAR (x), - SCM_CDR (x)); -#endif - SCM_CRITICAL_SECTION_START; - SCM_SETCAR (x, SCM_CAR (arg1)); - SCM_SETCDR (x, SCM_CDR (arg1)); - SCM_CRITICAL_SECTION_END; - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto loop; -#if SCM_ENABLE_DEPRECATED == 1 - case 1: - x = arg1; - if (SCM_NIMP (x)) - { - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto loop; - } - else - RETURN (arg1); -#endif - case 0: - RETURN (arg1); - } - } - } - else - proc = SCM_CAR (x); - - if (SCM_MACROP (proc)) - goto handle_a_macro; - } - - - /* When reaching this part of the code, the following is granted: Variable x - * holds the first pair of an expression of the form ( arg ...). - * Variable proc holds the object that resulted from the evaluation of - * . In the following, the arguments (if any) will be evaluated, - * and proc will be applied to them. If proc does not really hold a - * function object, this will be signalled as an error on the scheme - * level. If the number of arguments does not match the number of arguments - * that are allowed to be passed to proc, also an error on the scheme level - * will be signalled. */ - - PREP_APPLY (proc, SCM_EOL); - if (scm_is_null (SCM_CDR (x))) { - ENTER_APPLY; - evap0: - SCM_ASRTGO (!SCM_IMP (proc), badfun); - switch (SCM_TYP7 (proc)) - { /* no arguments given */ - case scm_tc7_subr_0: - RETURN (SCM_SUBRF (proc) ()); - case scm_tc7_subr_1o: - RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (SCM_EOL)); - case scm_tc7_rpsubr: - RETURN (SCM_BOOL_T); - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_0 (proc)); - case scm_tc7_cclo: - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); -#ifdef DEVAL - debug.info->a.proc = proc; - debug.info->a.args = scm_list_1 (arg1); -#endif - goto evap1; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); -#ifdef DEVAL - debug.info->a.proc = proc; -#endif - if (!SCM_CLOSUREP (proc)) - goto evap0; - /* fallthrough */ - case scm_tcs_closures: - { - const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (scm_is_pair (formals)) - goto wrongnumargs; - x = SCM_CLOSURE_BODY (proc); - env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); - goto nontoplevel_begin; - } - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); - arg1 = SCM_EOL; - goto type_dispatch; - } - else if (SCM_I_OPERATORP (proc)) - { - arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); -#ifdef DEVAL - debug.info->a.proc = proc; - debug.info->a.args = scm_list_1 (arg1); -#endif - goto evap1; - } - else - goto badfun; - case scm_tc7_subr_1: - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - case scm_tc7_dsubr: - case scm_tc7_cxr: - case scm_tc7_subr_3: - case scm_tc7_lsubr_2: - wrongnumargs: - scm_wrong_num_args (proc); - default: - badfun: - scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); - } - } - - /* must handle macros by here */ - x = SCM_CDR (x); - if (scm_is_pair (x)) - arg1 = EVALCAR (x, env); - else - scm_wrong_num_args (proc); -#ifdef DEVAL - debug.info->a.args = scm_list_1 (arg1); -#endif - x = SCM_CDR (x); - { - SCM arg2; - if (scm_is_null (x)) - { - ENTER_APPLY; - evap1: /* inputs: proc, arg1 */ - SCM_ASRTGO (!SCM_IMP (proc), badfun); - switch (SCM_TYP7 (proc)) - { /* have one argument in arg1 */ - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); - case scm_tc7_subr_1: - case scm_tc7_subr_1o: - RETURN (SCM_SUBRF (proc) (arg1)); - case scm_tc7_dsubr: - if (SCM_I_INUMP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); - } - else if (SCM_REALP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); - } - else if (SCM_BIGP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); - } - else if (SCM_FRACTIONP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); - } - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, - scm_i_symbol_chars (SCM_SNAME (proc))); - case scm_tc7_cxr: - RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); - case scm_tc7_rpsubr: - RETURN (SCM_BOOL_T); - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); - case scm_tc7_lsubr: -#ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); -#else - RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); -#endif - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); - case scm_tc7_cclo: - arg2 = arg1; - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); -#ifdef DEVAL - debug.info->a.args = scm_cons (arg1, debug.info->a.args); - debug.info->a.proc = proc; -#endif - goto evap2; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); -#ifdef DEVAL - debug.info->a.proc = proc; -#endif - if (!SCM_CLOSUREP (proc)) - goto evap1; - /* fallthrough */ - case scm_tcs_closures: - { - /* clos1: */ - const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (scm_is_null (formals) - || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals)))) - goto wrongnumargs; - x = SCM_CLOSURE_BODY (proc); -#ifdef DEVAL - env = SCM_EXTEND_ENV (formals, - debug.info->a.args, - SCM_ENV (proc)); -#else - env = SCM_EXTEND_ENV (formals, - scm_list_1 (arg1), - SCM_ENV (proc)); -#endif - goto nontoplevel_begin; - } - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); -#ifdef DEVAL - arg1 = debug.info->a.args; -#else - arg1 = scm_list_1 (arg1); -#endif - goto type_dispatch; - } - else if (SCM_I_OPERATORP (proc)) - { - arg2 = arg1; - arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); -#ifdef DEVAL - debug.info->a.args = scm_cons (arg1, debug.info->a.args); - debug.info->a.proc = proc; -#endif - goto evap2; - } - else - goto badfun; - case scm_tc7_subr_2: - case scm_tc7_subr_0: - case scm_tc7_subr_3: - case scm_tc7_lsubr_2: - scm_wrong_num_args (proc); - default: - goto badfun; - } - } - if (scm_is_pair (x)) - arg2 = EVALCAR (x, env); - else - scm_wrong_num_args (proc); - - { /* have two or more arguments */ -#ifdef DEVAL - debug.info->a.args = scm_list_2 (arg1, arg2); -#endif - x = SCM_CDR (x); - if (scm_is_null (x)) { - ENTER_APPLY; - evap2: - SCM_ASRTGO (!SCM_IMP (proc), badfun); - switch (SCM_TYP7 (proc)) - { /* have two arguments */ - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (arg1, arg2)); - case scm_tc7_lsubr: -#ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); -#else - RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); -#endif - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); - case scm_tc7_rpsubr: - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (arg1, arg2)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); - cclon: - case scm_tc7_cclo: -#ifdef DEVAL - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons (proc, debug.info->a.args), - SCM_EOL)); -#else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_eval_args (x, - env, - proc))), - SCM_EOL)); -#endif - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); -#ifdef DEVAL - arg1 = debug.info->a.args; -#else - arg1 = scm_list_2 (arg1, arg2); -#endif - goto type_dispatch; - } - else if (SCM_I_OPERATORP (proc)) - { - operatorn: -#ifdef DEVAL - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), - scm_cons (proc, debug.info->a.args), - SCM_EOL)); -#else - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_eval_args (x, - env, - proc))), - SCM_EOL)); -#endif - } - else - goto badfun; - case scm_tc7_subr_0: - case scm_tc7_dsubr: - case scm_tc7_cxr: - case scm_tc7_subr_1o: - case scm_tc7_subr_1: - case scm_tc7_subr_3: - scm_wrong_num_args (proc); - default: - goto badfun; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); -#ifdef DEVAL - debug.info->a.proc = proc; -#endif - if (!SCM_CLOSUREP (proc)) - goto evap2; - /* fallthrough */ - case scm_tcs_closures: - { - /* clos2: */ - const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (scm_is_null (formals) - || (scm_is_pair (formals) - && (scm_is_null (SCM_CDR (formals)) - || (scm_is_pair (SCM_CDR (formals)) - && scm_is_pair (SCM_CDDR (formals)))))) - goto wrongnumargs; -#ifdef DEVAL - env = SCM_EXTEND_ENV (formals, - debug.info->a.args, - SCM_ENV (proc)); -#else - env = SCM_EXTEND_ENV (formals, - scm_list_2 (arg1, arg2), - SCM_ENV (proc)); -#endif - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } - } - } - if (!scm_is_pair (x)) - scm_wrong_num_args (proc); -#ifdef DEVAL - debug.info->a.args = scm_cons2 (arg1, arg2, - deval_args (x, env, proc, - SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); -#endif - ENTER_APPLY; - evap3: - SCM_ASRTGO (!SCM_IMP (proc), badfun); - switch (SCM_TYP7 (proc)) - { /* have 3 or more arguments */ -#ifdef DEVAL - case scm_tc7_subr_3: - if (!scm_is_null (SCM_CDR (x))) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1, arg2, - SCM_CADDR (debug.info->a.args))); - case scm_tc7_asubr: - arg1 = SCM_SUBRF(proc)(arg1, arg2); - arg2 = SCM_CDDR (debug.info->a.args); - do - { - arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); - arg2 = SCM_CDR (arg2); - } - while (SCM_NIMP (arg2)); - RETURN (arg1); - case scm_tc7_rpsubr: - if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) - RETURN (SCM_BOOL_F); - arg1 = SCM_CDDR (debug.info->a.args); - do - { - if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) - RETURN (SCM_BOOL_F); - arg2 = SCM_CAR (arg1); - arg1 = SCM_CDR (arg1); - } - while (SCM_NIMP (arg1)); - RETURN (SCM_BOOL_T); - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, - SCM_CDDR (debug.info->a.args))); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, - SCM_CDDR (debug.info->a.args))); - case scm_tc7_cclo: - goto cclon; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - debug.info->a.proc = proc; - if (!SCM_CLOSUREP (proc)) - goto evap3; - /* fallthrough */ - case scm_tcs_closures: - { - const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (scm_is_null (formals) - || (scm_is_pair (formals) - && (scm_is_null (SCM_CDR (formals)) - || (scm_is_pair (SCM_CDR (formals)) - && scm_badargsp (SCM_CDDR (formals), x))))) - goto wrongnumargs; - SCM_SET_ARGSREADY (debug); - env = SCM_EXTEND_ENV (formals, - debug.info->a.args, - SCM_ENV (proc)); - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } -#else /* DEVAL */ - case scm_tc7_subr_3: - if (!scm_is_null (SCM_CDR (x))) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); - case scm_tc7_asubr: - arg1 = SCM_SUBRF (proc) (arg1, arg2); - do - { - arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); - x = SCM_CDR(x); - } - while (!scm_is_null (x)); - RETURN (arg1); - case scm_tc7_rpsubr: - if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) - RETURN (SCM_BOOL_F); - do - { - arg1 = EVALCAR (x, env); - if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1))) - RETURN (SCM_BOOL_F); - arg2 = arg1; - x = SCM_CDR (x); - } - while (!scm_is_null (x)); - RETURN (SCM_BOOL_T); - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, - arg2, - scm_eval_args (x, env, proc)))); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, - scm_eval_args (x, env, proc))); - case scm_tc7_cclo: - goto cclon; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - if (!SCM_CLOSUREP (proc)) - goto evap3; - /* fallthrough */ - case scm_tcs_closures: - { - const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (scm_is_null (formals) - || (scm_is_pair (formals) - && (scm_is_null (SCM_CDR (formals)) - || (scm_is_pair (SCM_CDR (formals)) - && scm_badargsp (SCM_CDDR (formals), x))))) - goto wrongnumargs; - env = SCM_EXTEND_ENV (formals, - scm_cons2 (arg1, - arg2, - scm_eval_args (x, env, proc)), - SCM_ENV (proc)); - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } -#endif /* DEVAL */ - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { -#ifdef DEVAL - arg1 = debug.info->a.args; -#else - arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); -#endif - x = SCM_ENTITY_PROCEDURE (proc); - goto type_dispatch; - } - else if (SCM_I_OPERATORP (proc)) - goto operatorn; - else - goto badfun; - case scm_tc7_subr_2: - case scm_tc7_subr_1o: - case scm_tc7_subr_2o: - case scm_tc7_subr_0: - case scm_tc7_dsubr: - case scm_tc7_cxr: - case scm_tc7_subr_1: - scm_wrong_num_args (proc); - default: - goto badfun; - } - } - } -#ifdef DEVAL -exit: - if (scm_check_exit_p && SCM_TRAPS_P) - if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) - { - SCM_CLEAR_TRACED_FRAME (debug); - arg1 = scm_make_debugobj (&debug); - SCM_TRAPS_P = 0; - arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); - SCM_TRAPS_P = 1; - if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) - proc = SCM_CDR (arg1); - } - scm_i_set_last_debug_frame (debug.prev); - return proc; -#endif -} - - -/* SECTION: This code is compiled once. - */ - -#ifndef DEVAL @@ -4785,336 +3157,6 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, } #undef FUNC_NAME -#endif /* !DEVAL */ - - -/* SECTION: When DEVAL is defined this code yields scm_dapply. - * It is compiled twice. - */ - -#if 0 -SCM -scm_apply (SCM proc, SCM arg1, SCM args) -{} -#endif - -#if 0 -SCM -scm_dapply (SCM proc, SCM arg1, SCM args) -{} -#endif - - -/* Apply a function to a list of arguments. - - This function is exported to the Scheme level as taking two - required arguments and a tail argument, as if it were: - (lambda (proc arg1 . args) ...) - Thus, if you just have a list of arguments to pass to a procedure, - pass the list as ARG1, and '() for ARGS. If you have some fixed - args, pass the first as ARG1, then cons any remaining fixed args - onto the front of your argument list, and pass that as ARGS. */ - -SCM -SCM_APPLY (SCM proc, SCM arg1, SCM args) -{ -#ifdef DEVAL - scm_t_debug_frame debug; - scm_t_debug_info debug_vect_body; - debug.prev = scm_i_last_debug_frame (); - debug.status = SCM_APPLYFRAME; - debug.vect = &debug_vect_body; - debug.vect[0].a.proc = proc; - debug.vect[0].a.args = SCM_EOL; - scm_i_set_last_debug_frame (&debug); -#else - if (scm_debug_mode_p) - return scm_dapply (proc, arg1, args); -#endif - - SCM_ASRTGO (SCM_NIMP (proc), badproc); - - /* If ARGS is the empty list, then we're calling apply with only two - arguments --- ARG1 is the list of arguments for PROC. Whatever - the case, futz with things so that ARG1 is the first argument to - give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the - rest. - - Setting the debug apply frame args this way is pretty messy. - Perhaps we should store arg1 and args directly in the frame as - received, and let scm_frame_arguments unpack them, because that's - a relatively rare operation. This works for now; if the Guile - developer archives are still around, see Mikael's post of - 11-Apr-97. */ - if (scm_is_null (args)) - { - if (scm_is_null (arg1)) - { - arg1 = SCM_UNDEFINED; -#ifdef DEVAL - debug.vect[0].a.args = SCM_EOL; -#endif - } - else - { -#ifdef DEVAL - debug.vect[0].a.args = arg1; -#endif - args = SCM_CDR (arg1); - arg1 = SCM_CAR (arg1); - } - } - else - { - args = scm_nconc2last (args); -#ifdef DEVAL - debug.vect[0].a.args = scm_cons (arg1, args); -#endif - } -#ifdef DEVAL - if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) - { - SCM tmp = scm_make_debugobj (&debug); - SCM_TRAPS_P = 0; - scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp); - SCM_TRAPS_P = 1; - } - ENTER_APPLY; -#endif -tail: - switch (SCM_TYP7 (proc)) - { - case scm_tc7_subr_2o: - if (SCM_UNBNDP (arg1)) - scm_wrong_num_args (proc); - if (scm_is_null (args)) - args = SCM_UNDEFINED; - else - { - if (! scm_is_null (SCM_CDR (args))) - scm_wrong_num_args (proc); - args = SCM_CAR (args); - } - RETURN (SCM_SUBRF (proc) (arg1, args)); - case scm_tc7_subr_2: - if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) - scm_wrong_num_args (proc); - args = SCM_CAR (args); - RETURN (SCM_SUBRF (proc) (arg1, args)); - case scm_tc7_subr_0: - if (!SCM_UNBNDP (arg1)) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) ()); - case scm_tc7_subr_1: - if (SCM_UNBNDP (arg1)) - scm_wrong_num_args (proc); - case scm_tc7_subr_1o: - if (!scm_is_null (args)) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1)); - case scm_tc7_dsubr: - if (SCM_UNBNDP (arg1) || !scm_is_null (args)) - scm_wrong_num_args (proc); - if (SCM_I_INUMP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); - } - else if (SCM_REALP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); - } - else if (SCM_BIGP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); - } - else if (SCM_FRACTIONP (arg1)) - { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); - } - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); - case scm_tc7_cxr: - if (SCM_UNBNDP (arg1) || !scm_is_null (args)) - scm_wrong_num_args (proc); - RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); - case scm_tc7_subr_3: - if (scm_is_null (args) - || scm_is_null (SCM_CDR (args)) - || !scm_is_null (SCM_CDDR (args))) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); - case scm_tc7_lsubr: -#ifdef DEVAL - RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); -#else - RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); -#endif - case scm_tc7_lsubr_2: - if (!scm_is_pair (args)) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); - case scm_tc7_asubr: - if (scm_is_null (args)) - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); - while (SCM_NIMP (args)) - { - SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); - arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); - args = SCM_CDR (args); - } - RETURN (arg1); - case scm_tc7_rpsubr: - if (scm_is_null (args)) - RETURN (SCM_BOOL_T); - while (SCM_NIMP (args)) - { - SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); - if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) - RETURN (SCM_BOOL_F); - arg1 = SCM_CAR (args); - args = SCM_CDR (args); - } - RETURN (SCM_BOOL_T); - case scm_tcs_closures: -#ifdef DEVAL - arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args); -#else - arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); -#endif - if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)) - scm_wrong_num_args (proc); - - /* Copy argument list */ - if (SCM_IMP (arg1)) - args = arg1; - else - { - SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); - for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1)) - { - SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); - tl = SCM_CDR (tl); - } - SCM_SETCDR (tl, arg1); - } - - args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - args, - SCM_ENV (proc)); - proc = SCM_CLOSURE_BODY (proc); - again: - arg1 = SCM_CDR (proc); - while (!scm_is_null (arg1)) - { - if (SCM_IMP (SCM_CAR (proc))) - { - if (SCM_ISYMP (SCM_CAR (proc))) - { - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&source_mutex); - /* check for race condition */ - if (SCM_ISYMP (SCM_CAR (proc))) - m_expand_body (proc, args); - scm_dynwind_end (); - goto again; - } - else - SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc)); - } - else - (void) EVAL (SCM_CAR (proc), args); - proc = arg1; - arg1 = SCM_CDR (proc); - } - RETURN (EVALCAR (proc, args)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badproc; - if (SCM_UNBNDP (arg1)) - RETURN (SCM_SMOB_APPLY_0 (proc)); - else if (scm_is_null (args)) - RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); - else if (scm_is_null (SCM_CDR (args))) - RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); - else - RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); - case scm_tc7_cclo: -#ifdef DEVAL - args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); - debug.vect[0].a.proc = proc; - debug.vect[0].a.args = scm_cons (arg1, args); -#else - args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); -#endif - goto tail; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); -#ifdef DEVAL - debug.vect[0].a.proc = proc; -#endif - goto tail; - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { -#ifdef DEVAL - args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); -#else - args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); -#endif - RETURN (scm_apply_generic (proc, args)); - } - else if (SCM_I_OPERATORP (proc)) - { - /* operator */ -#ifdef DEVAL - args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); -#else - args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); -#endif - arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); -#ifdef DEVAL - debug.vect[0].a.proc = proc; - debug.vect[0].a.args = scm_cons (arg1, args); -#endif - if (SCM_NIMP (proc)) - goto tail; - else - goto badproc; - } - else - goto badproc; - default: - badproc: - scm_wrong_type_arg ("apply", SCM_ARG1, proc); - } -#ifdef DEVAL -exit: - if (scm_check_exit_p && SCM_TRAPS_P) - if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) - { - SCM_CLEAR_TRACED_FRAME (debug); - arg1 = scm_make_debugobj (&debug); - SCM_TRAPS_P = 0; - arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); - SCM_TRAPS_P = 1; - if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) - proc = SCM_CDR (arg1); - } - scm_i_set_last_debug_frame (debug.prev); - return proc; -#endif -} /* SECTION: The rest of this file is only read once. @@ -5249,19 +3291,19 @@ call_dsubr_1 (SCM proc, SCM arg1) { if (SCM_I_INUMP (arg1)) { - RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); + return (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { - RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + return (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + return (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { - RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); @@ -5918,7 +3960,7 @@ scm_i_eval_x (SCM exp, SCM env) if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else - return SCM_I_XEVAL (exp, env); + return SCM_I_XEVAL (exp, env, scm_debug_mode_p); } SCM @@ -5928,7 +3970,7 @@ scm_i_eval (SCM exp, SCM env) if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else - return SCM_I_XEVAL (exp, env); + return SCM_I_XEVAL (exp, env, scm_debug_mode_p); } SCM @@ -6012,46 +4054,9 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, */ #define DEVAL -#include "eval.c" - - -#if (SCM_ENABLE_DEPRECATED == 1) - -/* Deprecated in guile 1.7.0 on 2004-03-29. */ -SCM scm_ceval (SCM x, SCM env) -{ - if (scm_is_pair (x)) - return ceval (x, env); - else if (scm_is_symbol (x)) - return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); - else - return SCM_I_XEVAL (x, env); -} - -/* Deprecated in guile 1.7.0 on 2004-03-29. */ -SCM scm_deval (SCM x, SCM env) -{ - if (scm_is_pair (x)) - return deval (x, env); - else if (scm_is_symbol (x)) - return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); - else - return SCM_I_XEVAL (x, env); -} - -static SCM -dispatching_eval (SCM x, SCM env) -{ - if (scm_debug_mode_p) - return scm_deval (x, env); - else - return scm_ceval (x, env); -} - -/* Deprecated in guile 1.7.0 on 2004-03-29. */ -SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval; - -#endif +#include "eval.i.c" +#undef DEVAL +#include "eval.i.c" void diff --git a/libguile/eval.i.c b/libguile/eval.i.c new file mode 100644 index 000000000..898cca5ec --- /dev/null +++ b/libguile/eval.i.c @@ -0,0 +1,1922 @@ +#undef RETURN +#undef ENTER_APPLY +#undef PREP_APPLY +#undef CEVAL +#undef SCM_APPLY +#undef EVAL_DEBUGGING_P + + +#ifdef DEVAL + +/* + This code is specific for the debugging support. + */ + +#define EVAL_DEBUGGING_P 1 +#define CEVAL deval /* Substitute all uses of ceval */ +#define SCM_APPLY scm_dapply +#define PREP_APPLY(p, l) \ +{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } + +#define ENTER_APPLY \ +do { \ + SCM_SET_ARGSREADY (debug);\ + if (scm_check_apply_p && SCM_TRAPS_P)\ + if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\ + {\ + SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ + SCM_SET_TRACED_FRAME (debug); \ + SCM_TRAPS_P = 0;\ + tmp = scm_make_debugobj (&debug);\ + scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ + SCM_TRAPS_P = 1;\ + }\ +} while (0) + +#define RETURN(e) do { proc = (e); goto exit; } while (0) + +#ifdef STACK_CHECKING +# ifndef EVAL_STACK_CHECKING +# define EVAL_STACK_CHECKING +# endif /* EVAL_STACK_CHECKING */ +#endif /* STACK_CHECKING */ + + + + +static SCM +deval_args (SCM l, SCM env, SCM proc, SCM *lloc) +{ + SCM *results = lloc; + while (scm_is_pair (l)) + { + const SCM res = SCM_I_XEVALCAR (l, env, 1); + + *lloc = scm_list_1 (res); + lloc = SCM_CDRLOC (*lloc); + l = SCM_CDR (l); + } + if (!scm_is_null (l)) + scm_wrong_num_args (proc); + return *results; +} + + +#else /* DEVAL */ + +/* + Code is specific to debugging-less support. + */ + + +#define CEVAL ceval +#define SCM_APPLY scm_apply +#define PREP_APPLY(proc, args) +#define ENTER_APPLY +#define RETURN(x) do { return x; } while (0) +#define EVAL_DEBUGGING_P 0 + +#ifdef STACK_CHECKING +# ifndef NO_CEVAL_STACK_CHECKING +# define EVAL_STACK_CHECKING +# endif +#endif + + + + +static void +ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol) +{ + SCM argv[10]; + int i = 0, imax = sizeof (argv) / sizeof (SCM); + + while (!scm_is_null (init_forms)) + { + if (imax == i) + { + ceval_letrec_inits (env, init_forms, init_values_eol); + break; + } + argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0); + init_forms = SCM_CDR (init_forms); + } + + for (i--; i >= 0; i--) + { + **init_values_eol = scm_list_1 (argv[i]); + *init_values_eol = SCM_CDRLOC (**init_values_eol); + } +} + +static SCM +scm_ceval_args (SCM l, SCM env, SCM proc) +{ + SCM results = SCM_EOL, *lloc = &results, res; + while (scm_is_pair (l)) + { + res = EVALCAR (l, env); + + *lloc = scm_list_1 (res); + lloc = SCM_CDRLOC (*lloc); + l = SCM_CDR (l); + } + if (!scm_is_null (l)) + scm_wrong_num_args (proc); + return results; +} + + +SCM +scm_eval_args (SCM l, SCM env, SCM proc) +{ + return scm_ceval_args (l, env, proc); +} + + + +#endif + + + + +#define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P) +#define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P) + + + +/* Update the toplevel environment frame ENV so that it refers to the + * current module. */ +#define UPDATE_TOPLEVEL_ENV(env) \ + do { \ + SCM p = scm_current_module_lookup_closure (); \ + if (p != SCM_CAR (env)) \ + env = scm_top_level_env (p); \ + } while (0) + + +#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ + ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) + + +/* This is the evaluator. Like any real monster, it has three heads: + * + * ceval is the non-debugging evaluator, deval is the debugging version. Both + * are implemented using a common code base, using the following mechanism: + * CEVAL is a macro, which is either defined to ceval or deval. Thus, there + * is no function CEVAL, but the code for CEVAL actually compiles to either + * ceval or deval. When CEVAL is defined to ceval, it is known that the macro + * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL + * is known to be defined. Thus, in CEVAL parts for the debugging evaluator + * are enclosed within #ifdef DEVAL ... #endif. + * + * All three (ceval, deval and their common implementation CEVAL) take two + * input parameters, x and env: x is a single expression to be evalutated. + * env is the environment in which bindings are searched. + * + * x is known to be a pair. Since x is a single expression, it is necessarily + * in a tail position. If x is just a call to another function like in the + * expression (foo exp1 exp2 ...), the realization of that call therefore + * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc., + * however, may do so). This is realized by making extensive use of 'goto' + * statements within the evaluator: The gotos replace recursive calls to + * CEVAL, thus re-using the same stack frame that CEVAL was already using. + * If, however, x represents some form that requires to evaluate a sequence of + * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are + * performed for all but the last expression of that sequence. */ + +static SCM +CEVAL (SCM x, SCM env) +{ + SCM proc, arg1; +#ifdef DEVAL + scm_t_debug_frame debug; + scm_t_debug_info *debug_info_end; + debug.prev = scm_i_last_debug_frame (); + debug.status = 0; + /* + * The debug.vect contains twice as much scm_t_debug_info frames as the + * user has specified with (debug-set! frames ). + * + * Even frames are eval frames, odd frames are apply frames. + */ + debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size + * sizeof (scm_t_debug_info)); + debug.info = debug.vect; + debug_info_end = debug.vect + scm_debug_eframe_size; + scm_i_set_last_debug_frame (&debug); +#endif +#ifdef EVAL_STACK_CHECKING + if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) + { +#ifdef DEVAL + debug.info->e.exp = x; + debug.info->e.env = env; +#endif + scm_report_stack_overflow (); + } +#endif + +#ifdef DEVAL + goto start; +#endif + +loop: +#ifdef DEVAL + SCM_CLEAR_ARGSREADY (debug); + if (SCM_OVERFLOWP (debug)) + --debug.info; + /* + * In theory, this should be the only place where it is necessary to + * check for space in debug.vect since both eval frames and + * available space are even. + * + * For this to be the case, however, it is necessary that primitive + * special forms which jump back to `loop', `begin' or some similar + * label call PREP_APPLY. + */ + else if (++debug.info >= debug_info_end) + { + SCM_SET_OVERFLOW (debug); + debug.info -= 2; + } + +start: + debug.info->e.exp = x; + debug.info->e.env = env; + if (scm_check_entry_p && SCM_TRAPS_P) + { + if (SCM_ENTER_FRAME_P + || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) + { + SCM stackrep; + SCM tail = scm_from_bool (SCM_TAILRECP (debug)); + SCM_SET_TAILREC (debug); + stackrep = scm_make_debugobj (&debug); + SCM_TRAPS_P = 0; + stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR, + scm_sym_enter_frame, + stackrep, + tail, + unmemoize_expression (x, env)); + SCM_TRAPS_P = 1; + if (scm_is_pair (stackrep) && + scm_is_eq (SCM_CAR (stackrep), sym_instead)) + { + /* This gives the possibility for the debugger to modify + the source expression before evaluation. */ + x = SCM_CDR (stackrep); + if (SCM_IMP (x)) + RETURN (x); + } + } + } +#endif +dispatch: + SCM_TICK; + if (SCM_ISYMP (SCM_CAR (x))) + { + switch (ISYMNUM (SCM_CAR (x))) + { + case (ISYMNUM (SCM_IM_AND)): + x = SCM_CDR (x); + while (!scm_is_null (SCM_CDR (x))) + { + SCM test_result = EVALCAR (x, env); + if (scm_is_false (test_result) || SCM_NILP (test_result)) + RETURN (SCM_BOOL_F); + else + x = SCM_CDR (x); + } + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + + case (ISYMNUM (SCM_IM_BEGIN)): + x = SCM_CDR (x); + if (scm_is_null (x)) + RETURN (SCM_UNSPECIFIED); + + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + + begin: + /* If we are on toplevel with a lookup closure, we need to sync + with the current module. */ + if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env))) + { + UPDATE_TOPLEVEL_ENV (env); + while (!scm_is_null (SCM_CDR (x))) + { + EVALCAR (x, env); + UPDATE_TOPLEVEL_ENV (env); + x = SCM_CDR (x); + } + goto carloop; + } + else + goto nontoplevel_begin; + + nontoplevel_begin: + while (!scm_is_null (SCM_CDR (x))) + { + const SCM form = SCM_CAR (x); + if (SCM_IMP (form)) + { + if (SCM_ISYMP (form)) + { + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (x))) + m_expand_body (x, env); + scm_dynwind_end (); + goto nontoplevel_begin; + } + else + SCM_VALIDATE_NON_EMPTY_COMBINATION (form); + } + else + (void) EVAL (form, env); + x = SCM_CDR (x); + } + + carloop: + { + /* scm_eval last form in list */ + const SCM last_form = SCM_CAR (x); + + if (scm_is_pair (last_form)) + { + /* This is by far the most frequent case. */ + x = last_form; + goto loop; /* tail recurse */ + } + else if (SCM_IMP (last_form)) + RETURN (SCM_I_EVALIM (last_form, env)); + else if (SCM_VARIABLEP (last_form)) + RETURN (SCM_VARIABLE_REF (last_form)); + else if (scm_is_symbol (last_form)) + RETURN (*scm_lookupcar (x, env, 1)); + else + RETURN (last_form); + } + + + case (ISYMNUM (SCM_IM_CASE)): + x = SCM_CDR (x); + { + const SCM key = EVALCAR (x, env); + x = SCM_CDR (x); + while (!scm_is_null (x)) + { + const SCM clause = SCM_CAR (x); + SCM labels = SCM_CAR (clause); + if (scm_is_eq (labels, SCM_IM_ELSE)) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + while (!scm_is_null (labels)) + { + const SCM label = SCM_CAR (labels); + if (scm_is_eq (label, key) + || scm_is_true (scm_eqv_p (label, key))) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + labels = SCM_CDR (labels); + } + x = SCM_CDR (x); + } + } + RETURN (SCM_UNSPECIFIED); + + + case (ISYMNUM (SCM_IM_COND)): + x = SCM_CDR (x); + while (!scm_is_null (x)) + { + const SCM clause = SCM_CAR (x); + if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + else + { + arg1 = EVALCAR (clause, env); + /* SRFI 61 extended cond */ + if (!scm_is_null (SCM_CDR (clause)) + && !scm_is_null (SCM_CDDR (clause)) + && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW)) + { + SCM xx, guard_result; + if (SCM_VALUESP (arg1)) + arg1 = scm_struct_ref (arg1, SCM_INUM0); + else + arg1 = scm_list_1 (arg1); + xx = SCM_CDR (clause); + proc = EVALCAR (xx, env); + guard_result = SCM_APPLY (proc, arg1, SCM_EOL); + if (scm_is_true (guard_result) + && !SCM_NILP (guard_result)) + { + proc = SCM_CDDR (xx); + proc = EVALCAR (proc, env); + PREP_APPLY (proc, arg1); + goto apply_proc; + } + } + else if (scm_is_true (arg1) && !SCM_NILP (arg1)) + { + x = SCM_CDR (clause); + if (scm_is_null (x)) + RETURN (arg1); + else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + else + { + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + PREP_APPLY (proc, scm_list_1 (arg1)); + ENTER_APPLY; + goto evap1; + } + } + x = SCM_CDR (x); + } + } + RETURN (SCM_UNSPECIFIED); + + + case (ISYMNUM (SCM_IM_DO)): + x = SCM_CDR (x); + { + /* Compute the initialization values and the initial environment. */ + SCM init_forms = SCM_CAR (x); + SCM init_values = SCM_EOL; + while (!scm_is_null (init_forms)) + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + x = SCM_CDR (x); + env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); + } + x = SCM_CDR (x); + { + SCM test_form = SCM_CAR (x); + SCM body_forms = SCM_CADR (x); + SCM step_forms = SCM_CDDR (x); + + SCM test_result = EVALCAR (test_form, env); + + while (scm_is_false (test_result) || SCM_NILP (test_result)) + { + { + /* Evaluate body forms. */ + SCM temp_forms; + for (temp_forms = body_forms; + !scm_is_null (temp_forms); + temp_forms = SCM_CDR (temp_forms)) + { + SCM form = SCM_CAR (temp_forms); + /* Dirk:FIXME: We only need to eval forms that may have + * a side effect here. This is only true for forms that + * start with a pair. All others are just constants. + * Since with the current memoizer 'form' may hold a + * constant, we call EVAL here to handle the constant + * cases. In the long run it would make sense to have + * the macro transformer of 'do' eliminate all forms + * that have no sideeffect. Then instead of EVAL we + * could call CEVAL directly here. */ + (void) EVAL (form, env); + } + } + + { + /* Evaluate the step expressions. */ + SCM temp_forms; + SCM step_values = SCM_EOL; + for (temp_forms = step_forms; + !scm_is_null (temp_forms); + temp_forms = SCM_CDR (temp_forms)) + { + const SCM value = EVALCAR (temp_forms, env); + step_values = scm_cons (value, step_values); + } + env = SCM_EXTEND_ENV (SCM_CAAR (env), + step_values, + SCM_CDR (env)); + } + + test_result = EVALCAR (test_form, env); + } + } + x = SCM_CDAR (x); + if (scm_is_null (x)) + RETURN (SCM_UNSPECIFIED); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; + + + case (ISYMNUM (SCM_IM_IF)): + x = SCM_CDR (x); + { + SCM test_result = EVALCAR (x, env); + x = SCM_CDR (x); /* then expression */ + if (scm_is_false (test_result) || SCM_NILP (test_result)) + { + x = SCM_CDR (x); /* else expression */ + if (scm_is_null (x)) + RETURN (SCM_UNSPECIFIED); + } + } + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + + + case (ISYMNUM (SCM_IM_LET)): + x = SCM_CDR (x); + { + SCM init_forms = SCM_CADR (x); + SCM init_values = SCM_EOL; + do + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + while (!scm_is_null (init_forms)); + env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); + } + x = SCM_CDDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; + + + case (ISYMNUM (SCM_IM_LETREC)): + x = SCM_CDR (x); + env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env); + x = SCM_CDR (x); + { + SCM init_forms = SCM_CAR (x); + SCM init_values = scm_list_1 (SCM_BOOL_T); + SCM *init_values_eol = SCM_CDRLOC (init_values); + ceval_letrec_inits (env, init_forms, &init_values_eol); + SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values)); + } + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; + + + case (ISYMNUM (SCM_IM_LETSTAR)): + x = SCM_CDR (x); + { + SCM bindings = SCM_CAR (x); + if (!scm_is_null (bindings)) + { + do + { + SCM name = SCM_CAR (bindings); + SCM init = SCM_CDR (bindings); + env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); + bindings = SCM_CDR (init); + } + while (!scm_is_null (bindings)); + } + } + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; + + + case (ISYMNUM (SCM_IM_OR)): + x = SCM_CDR (x); + while (!scm_is_null (SCM_CDR (x))) + { + SCM val = EVALCAR (x, env); + if (scm_is_true (val) && !SCM_NILP (val)) + RETURN (val); + else + x = SCM_CDR (x); + } + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + + + case (ISYMNUM (SCM_IM_LAMBDA)): + RETURN (scm_closure (SCM_CDR (x), env)); + + + case (ISYMNUM (SCM_IM_QUOTE)): + RETURN (SCM_CDR (x)); + + + case (ISYMNUM (SCM_IM_SET_X)): + x = SCM_CDR (x); + { + SCM *location; + SCM variable = SCM_CAR (x); + if (SCM_ILOCP (variable)) + location = scm_ilookup (variable, env); + else if (SCM_VARIABLEP (variable)) + location = SCM_VARIABLE_LOC (variable); + else + { + /* (scm_is_symbol (variable)) is known to be true */ + variable = lazy_memoize_variable (variable, env); + SCM_SETCAR (x, variable); + location = SCM_VARIABLE_LOC (variable); + } + x = SCM_CDR (x); + *location = EVALCAR (x, env); + } + RETURN (SCM_UNSPECIFIED); + + + case (ISYMNUM (SCM_IM_APPLY)): + /* Evaluate the procedure to be applied. */ + x = SCM_CDR (x); + proc = EVALCAR (x, env); + PREP_APPLY (proc, SCM_EOL); + + /* Evaluate the argument holding the list of arguments */ + x = SCM_CDR (x); + arg1 = EVALCAR (x, env); + + apply_proc: + /* Go here to tail-apply a procedure. PROC is the procedure and + * ARG1 is the list of arguments. PREP_APPLY must have been called + * before jumping to apply_proc. */ + if (SCM_CLOSUREP (proc)) + { + SCM formals = SCM_CLOSURE_FORMALS (proc); +#ifdef DEVAL + debug.info->a.args = arg1; +#endif + if (scm_badargsp (formals, arg1)) + scm_wrong_num_args (proc); + ENTER_APPLY; + /* Copy argument list */ + if (SCM_NULL_OR_NIL_P (arg1)) + env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + else + { + SCM args = scm_list_1 (SCM_CAR (arg1)); + SCM tail = args; + arg1 = SCM_CDR (arg1); + while (!SCM_NULL_OR_NIL_P (arg1)) + { + SCM new_tail = scm_list_1 (SCM_CAR (arg1)); + SCM_SETCDR (tail, new_tail); + tail = new_tail; + arg1 = SCM_CDR (arg1); + } + env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc)); + } + + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } + else + { + ENTER_APPLY; + RETURN (SCM_APPLY (proc, arg1, SCM_EOL)); + } + + + case (ISYMNUM (SCM_IM_CONT)): + { + int first; + SCM val = scm_make_continuation (&first); + + if (!first) + RETURN (val); + else + { + arg1 = val; + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + PREP_APPLY (proc, scm_list_1 (arg1)); + ENTER_APPLY; + goto evap1; + } + } + + + case (ISYMNUM (SCM_IM_DELAY)): + RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); + +#if 0 + /* See futures.h for a comment why futures are not enabled. + */ + case (ISYMNUM (SCM_IM_FUTURE)): + RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); +#endif + + /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following + code (type_dispatch) is intended to be the tail of the case + clause for the internal macro SCM_IM_DISPATCH. Please don't + remove it from this location without discussing it with Mikael + */ + + /* The type dispatch code is duplicated below + * (c.f. objects.c:scm_mcache_compute_cmethod) since that + * cuts down execution time for type dispatch to 50%. */ + type_dispatch: /* inputs: x, arg1 */ + /* Type dispatch means to determine from the types of the function + * arguments (i. e. the 'signature' of the call), which method from + * a generic function is to be called. This process of selecting + * the right method takes some time. To speed it up, guile uses + * caching: Together with the macro call to dispatch the signatures + * of some previous calls to that generic function from the same + * place are stored (in the code!) in a cache that we call the + * 'method cache'. This is done since it is likely, that + * consecutive calls to dispatch from that position in the code will + * have the same signature. Thus, the type dispatch works as + * follows: First, determine a hash value from the signature of the + * actual arguments. Second, use this hash value as an index to + * find that same signature in the method cache stored at this + * position in the code. If found, you have also found the + * corresponding method that belongs to that signature. If the + * signature is not found in the method cache, you have to perform a + * full search over all signatures stored with the generic + * function. */ + { + unsigned long int specializers; + unsigned long int hash_value; + unsigned long int cache_end_pos; + unsigned long int mask; + SCM method_cache; + + { + SCM z = SCM_CDDR (x); + SCM tmp = SCM_CADR (z); + specializers = scm_to_ulong (SCM_CAR (z)); + + /* Compute a hash value for searching the method cache. There + * are two variants for computing the hash value, a (rather) + * complicated one, and a simple one. For the complicated one + * explained below, tmp holds a number that is used in the + * computation. */ + if (scm_is_simple_vector (tmp)) + { + /* This method of determining the hash value is much + * simpler: Set the hash value to zero and just perform a + * linear search through the method cache. */ + method_cache = tmp; + mask = (unsigned long int) ((long) -1); + hash_value = 0; + cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache); + } + else + { + /* Use the signature of the actual arguments to determine + * the hash value. This is done as follows: Each class has + * an array of random numbers, that are determined when the + * class is created. The integer 'hashset' is an index into + * that array of random numbers. Now, from all classes that + * are part of the signature of the actual arguments, the + * random numbers at index 'hashset' are taken and summed + * up, giving the hash value. The value of 'hashset' is + * stored at the call to dispatch. This allows to have + * different 'formulas' for calculating the hash value at + * different places where dispatch is called. This allows + * to optimize the hash formula at every individual place + * where dispatch is called, such that hopefully the hash + * value that is computed will directly point to the right + * method in the method cache. */ + unsigned long int hashset = scm_to_ulong (tmp); + unsigned long int counter = specializers + 1; + SCM tmp_arg = arg1; + hash_value = 0; + while (!scm_is_null (tmp_arg) && counter != 0) + { + SCM class = scm_class_of (SCM_CAR (tmp_arg)); + hash_value += SCM_INSTANCE_HASH (class, hashset); + tmp_arg = SCM_CDR (tmp_arg); + counter--; + } + z = SCM_CDDR (z); + method_cache = SCM_CADR (z); + mask = scm_to_ulong (SCM_CAR (z)); + hash_value &= mask; + cache_end_pos = hash_value; + } + } + + { + /* Search the method cache for a method with a matching + * signature. Start the search at position 'hash_value'. The + * hashing implementation uses linear probing for conflict + * resolution, that is, if the signature in question is not + * found at the starting index in the hash table, the next table + * entry is tried, and so on, until in the worst case the whole + * cache has been searched, but still the signature has not been + * found. */ + SCM z; + do + { + SCM args = arg1; /* list of arguments */ + z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value); + while (!scm_is_null (args)) + { + /* More arguments than specifiers => CLASS != ENV */ + SCM class_of_arg = scm_class_of (SCM_CAR (args)); + if (!scm_is_eq (class_of_arg, SCM_CAR (z))) + goto next_method; + args = SCM_CDR (args); + z = SCM_CDR (z); + } + /* Fewer arguments than specifiers => CAR != ENV */ + if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) + goto apply_cmethod; + next_method: + hash_value = (hash_value + 1) & mask; + } while (hash_value != cache_end_pos); + + /* No appropriate method was found in the cache. */ + z = scm_memoize_method (x, arg1); + + apply_cmethod: /* inputs: z, arg1 */ + { + SCM formals = SCM_CMETHOD_FORMALS (z); + env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); + x = SCM_CMETHOD_BODY (z); + goto nontoplevel_begin; + } + } + } + + + case (ISYMNUM (SCM_IM_SLOT_REF)): + x = SCM_CDR (x); + { + SCM instance = EVALCAR (x, env); + unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); + RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); + } + + + case (ISYMNUM (SCM_IM_SLOT_SET_X)): + x = SCM_CDR (x); + { + SCM instance = EVALCAR (x, env); + unsigned long int slot = SCM_I_INUM (SCM_CADR (x)); + SCM value = EVALCAR (SCM_CDDR (x), env); + SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); + RETURN (SCM_UNSPECIFIED); + } + + +#if SCM_ENABLE_ELISP + + case (ISYMNUM (SCM_IM_NIL_COND)): + { + SCM test_form = SCM_CDR (x); + x = SCM_CDR (test_form); + while (!SCM_NULL_OR_NIL_P (x)) + { + SCM test_result = EVALCAR (test_form, env); + if (!(scm_is_false (test_result) + || SCM_NULL_OR_NIL_P (test_result))) + { + if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) + RETURN (test_result); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + } + else + { + test_form = SCM_CDR (x); + x = SCM_CDR (test_form); + } + } + x = test_form; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + } + +#endif /* SCM_ENABLE_ELISP */ + + case (ISYMNUM (SCM_IM_BIND)): + { + SCM vars, exps, vals; + + x = SCM_CDR (x); + vars = SCM_CAAR (x); + exps = SCM_CDAR (x); + vals = SCM_EOL; + while (!scm_is_null (exps)) + { + vals = scm_cons (EVALCAR (exps, env), vals); + exps = SCM_CDR (exps); + } + + scm_swap_bindings (vars, vals); + scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ())); + + /* Ignore all but the last evaluation result. */ + for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x)) + { + if (scm_is_pair (SCM_CAR (x))) + CEVAL (SCM_CAR (x), env); + } + proc = EVALCAR (x, env); + + scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); + scm_swap_bindings (vars, vals); + + RETURN (proc); + } + + + case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): + { + SCM producer; + + x = SCM_CDR (x); + producer = EVALCAR (x, env); + x = SCM_CDR (x); + proc = EVALCAR (x, env); /* proc is the consumer. */ + arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); + if (SCM_VALUESP (arg1)) + { + /* The list of arguments is not copied. Rather, it is assumed + * that this has been done by the 'values' procedure. */ + arg1 = scm_struct_ref (arg1, SCM_INUM0); + } + else + { + arg1 = scm_list_1 (arg1); + } + PREP_APPLY (proc, arg1); + goto apply_proc; + } + + + default: + break; + } + } + else + { + if (SCM_VARIABLEP (SCM_CAR (x))) + proc = SCM_VARIABLE_REF (SCM_CAR (x)); + else if (SCM_ILOCP (SCM_CAR (x))) + proc = *scm_ilookup (SCM_CAR (x), env); + else if (scm_is_pair (SCM_CAR (x))) + proc = CEVAL (SCM_CAR (x), env); + else if (scm_is_symbol (SCM_CAR (x))) + { + SCM orig_sym = SCM_CAR (x); + { + SCM *location = scm_lookupcar1 (x, env, 1); + if (location == NULL) + { + /* we have lost the race, start again. */ + goto dispatch; + } + proc = *location; +#ifdef DEVAL + if (scm_check_memoize_p && SCM_TRAPS_P) + { + SCM_CLEAR_TRACED_FRAME (debug); + SCM arg1 = scm_make_debugobj (&debug); + SCM retval = SCM_BOOL_T; + SCM_TRAPS_P = 0; + retval = scm_call_4 (SCM_MEMOIZE_HDLR, + scm_sym_memoize_symbol, + arg1, x, env); + + /* + do something with retval? + */ + SCM_TRAPS_P = 1; + } +#endif + } + + if (SCM_MACROP (proc)) + { + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of + lookupcar */ + handle_a_macro: /* inputs: x, env, proc */ +#ifdef DEVAL + /* Set a flag during macro expansion so that macro + application frames can be deleted from the backtrace. */ + SCM_SET_MACROEXP (debug); +#endif + arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, + scm_cons (env, scm_listofnull)); +#ifdef DEVAL + SCM_CLEAR_MACROEXP (debug); +#endif + switch (SCM_MACRO_TYPE (proc)) + { + case 3: + case 2: + if (!scm_is_pair (arg1)) + arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); + + assert (!scm_is_eq (x, SCM_CAR (arg1)) + && !scm_is_eq (x, SCM_CDR (arg1))); + +#ifdef DEVAL + if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) + { + SCM_CRITICAL_SECTION_START; + SCM_SETCAR (x, SCM_CAR (arg1)); + SCM_SETCDR (x, SCM_CDR (arg1)); + SCM_CRITICAL_SECTION_END; + goto dispatch; + } + /* Prevent memoizing of debug info expression. */ + debug.info->e.exp = scm_cons_source (debug.info->e.exp, + SCM_CAR (x), + SCM_CDR (x)); +#endif + SCM_CRITICAL_SECTION_START; + SCM_SETCAR (x, SCM_CAR (arg1)); + SCM_SETCDR (x, SCM_CDR (arg1)); + SCM_CRITICAL_SECTION_END; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; +#if SCM_ENABLE_DEPRECATED == 1 + case 1: + x = arg1; + if (SCM_NIMP (x)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; + } + else + RETURN (arg1); +#endif + case 0: + RETURN (arg1); + } + } + } + else + proc = SCM_CAR (x); + + if (SCM_MACROP (proc)) + goto handle_a_macro; + } + + + /* When reaching this part of the code, the following is granted: Variable x + * holds the first pair of an expression of the form ( arg ...). + * Variable proc holds the object that resulted from the evaluation of + * . In the following, the arguments (if any) will be evaluated, + * and proc will be applied to them. If proc does not really hold a + * function object, this will be signalled as an error on the scheme + * level. If the number of arguments does not match the number of arguments + * that are allowed to be passed to proc, also an error on the scheme level + * will be signalled. */ + + PREP_APPLY (proc, SCM_EOL); + if (scm_is_null (SCM_CDR (x))) { + ENTER_APPLY; + evap0: + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* no arguments given */ + case scm_tc7_subr_0: + RETURN (SCM_SUBRF (proc) ()); + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (SCM_EOL)); + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_0 (proc)); + case scm_tc7_cclo: + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); +#ifdef DEVAL + debug.info->a.proc = proc; + debug.info->a.args = scm_list_1 (arg1); +#endif + goto evap1; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + if (!SCM_CLOSUREP (proc)) + goto evap0; + /* fallthrough */ + case scm_tcs_closures: + { + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (scm_is_pair (formals)) + goto wrongnumargs; + x = SCM_CLOSURE_BODY (proc); + env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + goto nontoplevel_begin; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); + arg1 = SCM_EOL; + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + { + arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.info->a.proc = proc; + debug.info->a.args = scm_list_1 (arg1); +#endif + goto evap1; + } + else + goto badfun; + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + wrongnumargs: + scm_wrong_num_args (proc); + default: + badfun: + scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); + } + } + + /* must handle macros by here */ + x = SCM_CDR (x); + if (scm_is_pair (x)) + arg1 = EVALCAR (x, env); + else + scm_wrong_num_args (proc); +#ifdef DEVAL + debug.info->a.args = scm_list_1 (arg1); +#endif + x = SCM_CDR (x); + { + SCM arg2; + if (scm_is_null (x)) + { + ENTER_APPLY; + evap1: /* inputs: proc, arg1 */ + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have one argument in arg1 */ + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_dsubr: + if (SCM_I_INUMP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } + else if (SCM_BIGP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } + else if (SCM_FRACTIONP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + } + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, + scm_i_symbol_chars (SCM_SNAME (proc))); + case scm_tc7_cxr: + RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); +#endif + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); + case scm_tc7_cclo: + arg2 = arg1; + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); +#ifdef DEVAL + debug.info->a.args = scm_cons (arg1, debug.info->a.args); + debug.info->a.proc = proc; +#endif + goto evap2; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + if (!SCM_CLOSUREP (proc)) + goto evap1; + /* fallthrough */ + case scm_tcs_closures: + { + /* clos1: */ + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (scm_is_null (formals) + || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals)))) + goto wrongnumargs; + x = SCM_CLOSURE_BODY (proc); +#ifdef DEVAL + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); +#else + env = SCM_EXTEND_ENV (formals, + scm_list_1 (arg1), + SCM_ENV (proc)); +#endif + goto nontoplevel_begin; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg1 = debug.info->a.args; +#else + arg1 = scm_list_1 (arg1); +#endif + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + { + arg2 = arg1; + arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.info->a.args = scm_cons (arg1, debug.info->a.args); + debug.info->a.proc = proc; +#endif + goto evap2; + } + else + goto badfun; + case scm_tc7_subr_2: + case scm_tc7_subr_0: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + scm_wrong_num_args (proc); + default: + goto badfun; + } + } + if (scm_is_pair (x)) + arg2 = EVALCAR (x, env); + else + scm_wrong_num_args (proc); + + { /* have two or more arguments */ +#ifdef DEVAL + debug.info->a.args = scm_list_2 (arg1, arg2); +#endif + x = SCM_CDR (x); + if (scm_is_null (x)) { + ENTER_APPLY; + evap2: + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have two arguments */ + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); +#endif + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); + case scm_tc7_rpsubr: + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); + cclon: + case scm_tc7_cclo: +#ifdef DEVAL + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); +#else + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_ceval_args (x, + env, + proc))), + SCM_EOL)); +#endif + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg1 = debug.info->a.args; +#else + arg1 = scm_list_2 (arg1, arg2); +#endif + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + { + operatorn: +#ifdef DEVAL + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); +#else + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_ceval_args (x, + env, + proc))), + SCM_EOL)); +#endif + } + else + goto badfun; + case scm_tc7_subr_0: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_1o: + case scm_tc7_subr_1: + case scm_tc7_subr_3: + scm_wrong_num_args (proc); + default: + goto badfun; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + if (!SCM_CLOSUREP (proc)) + goto evap2; + /* fallthrough */ + case scm_tcs_closures: + { + /* clos2: */ + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (scm_is_null (formals) + || (scm_is_pair (formals) + && (scm_is_null (SCM_CDR (formals)) + || (scm_is_pair (SCM_CDR (formals)) + && scm_is_pair (SCM_CDDR (formals)))))) + goto wrongnumargs; +#ifdef DEVAL + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); +#else + env = SCM_EXTEND_ENV (formals, + scm_list_2 (arg1, arg2), + SCM_ENV (proc)); +#endif + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } + } + } + if (!scm_is_pair (x)) + scm_wrong_num_args (proc); +#ifdef DEVAL + debug.info->a.args = scm_cons2 (arg1, arg2, + deval_args (x, env, proc, + SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); +#endif + ENTER_APPLY; + evap3: + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have 3 or more arguments */ +#ifdef DEVAL + case scm_tc7_subr_3: + if (!scm_is_null (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CADDR (debug.info->a.args))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF(proc)(arg1, arg2); + arg2 = SCM_CDDR (debug.info->a.args); + do + { + arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); + arg2 = SCM_CDR (arg2); + } + while (SCM_NIMP (arg2)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CDDR (debug.info->a.args); + do + { + if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) + RETURN (SCM_BOOL_F); + arg2 = SCM_CAR (arg1); + arg1 = SCM_CDR (arg1); + } + while (SCM_NIMP (arg1)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CDDR (debug.info->a.args))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, + SCM_CDDR (debug.info->a.args))); + case scm_tc7_cclo: + goto cclon; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + debug.info->a.proc = proc; + if (!SCM_CLOSUREP (proc)) + goto evap3; + /* fallthrough */ + case scm_tcs_closures: + { + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (scm_is_null (formals) + || (scm_is_pair (formals) + && (scm_is_null (SCM_CDR (formals)) + || (scm_is_pair (SCM_CDR (formals)) + && scm_badargsp (SCM_CDDR (formals), x))))) + goto wrongnumargs; + SCM_SET_ARGSREADY (debug); + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } +#else /* DEVAL */ + case scm_tc7_subr_3: + if (!scm_is_null (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF (proc) (arg1, arg2); + do + { + arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + while (!scm_is_null (x)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + do + { + arg1 = EVALCAR (x, env); + if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1))) + RETURN (SCM_BOOL_F); + arg2 = arg1; + x = SCM_CDR (x); + } + while (!scm_is_null (x)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, + arg2, + scm_ceval_args (x, env, proc)))); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, + scm_ceval_args (x, env, proc))); + case scm_tc7_cclo: + goto cclon; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + if (!SCM_CLOSUREP (proc)) + goto evap3; + /* fallthrough */ + case scm_tcs_closures: + { + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (scm_is_null (formals) + || (scm_is_pair (formals) + && (scm_is_null (SCM_CDR (formals)) + || (scm_is_pair (SCM_CDR (formals)) + && scm_badargsp (SCM_CDDR (formals), x))))) + goto wrongnumargs; + env = SCM_EXTEND_ENV (formals, + scm_cons2 (arg1, + arg2, + scm_ceval_args (x, env, proc)), + SCM_ENV (proc)); + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } +#endif /* DEVAL */ + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { +#ifdef DEVAL + arg1 = debug.info->a.args; +#else + arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)); +#endif + x = SCM_ENTITY_PROCEDURE (proc); + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + goto operatorn; + else + goto badfun; + case scm_tc7_subr_2: + case scm_tc7_subr_1o: + case scm_tc7_subr_2o: + case scm_tc7_subr_0: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_1: + scm_wrong_num_args (proc); + default: + goto badfun; + } + } + } +#ifdef DEVAL +exit: + if (scm_check_exit_p && SCM_TRAPS_P) + if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) + { + SCM_CLEAR_TRACED_FRAME (debug); + arg1 = scm_make_debugobj (&debug); + SCM_TRAPS_P = 0; + arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); + SCM_TRAPS_P = 1; + if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) + proc = SCM_CDR (arg1); + } + scm_i_set_last_debug_frame (debug.prev); + return proc; +#endif +} + + + + +/* Apply a function to a list of arguments. + + This function is exported to the Scheme level as taking two + required arguments and a tail argument, as if it were: + (lambda (proc arg1 . args) ...) + Thus, if you just have a list of arguments to pass to a procedure, + pass the list as ARG1, and '() for ARGS. If you have some fixed + args, pass the first as ARG1, then cons any remaining fixed args + onto the front of your argument list, and pass that as ARGS. */ + +SCM +SCM_APPLY (SCM proc, SCM arg1, SCM args) +{ +#ifdef DEVAL + scm_t_debug_frame debug; + scm_t_debug_info debug_vect_body; + debug.prev = scm_i_last_debug_frame (); + debug.status = SCM_APPLYFRAME; + debug.vect = &debug_vect_body; + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = SCM_EOL; + scm_i_set_last_debug_frame (&debug); +#else + if (scm_debug_mode_p) + return scm_dapply (proc, arg1, args); +#endif + + SCM_ASRTGO (SCM_NIMP (proc), badproc); + + /* If ARGS is the empty list, then we're calling apply with only two + arguments --- ARG1 is the list of arguments for PROC. Whatever + the case, futz with things so that ARG1 is the first argument to + give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the + rest. + + Setting the debug apply frame args this way is pretty messy. + Perhaps we should store arg1 and args directly in the frame as + received, and let scm_frame_arguments unpack them, because that's + a relatively rare operation. This works for now; if the Guile + developer archives are still around, see Mikael's post of + 11-Apr-97. */ + if (scm_is_null (args)) + { + if (scm_is_null (arg1)) + { + arg1 = SCM_UNDEFINED; +#ifdef DEVAL + debug.vect[0].a.args = SCM_EOL; +#endif + } + else + { +#ifdef DEVAL + debug.vect[0].a.args = arg1; +#endif + args = SCM_CDR (arg1); + arg1 = SCM_CAR (arg1); + } + } + else + { + args = scm_nconc2last (args); +#ifdef DEVAL + debug.vect[0].a.args = scm_cons (arg1, args); +#endif + } +#ifdef DEVAL + if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) + { + SCM tmp = scm_make_debugobj (&debug); + SCM_TRAPS_P = 0; + scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp); + SCM_TRAPS_P = 1; + } + ENTER_APPLY; +#endif +tail: + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2o: + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + if (scm_is_null (args)) + args = SCM_UNDEFINED; + else + { + if (! scm_is_null (SCM_CDR (args))) + scm_wrong_num_args (proc); + args = SCM_CAR (args); + } + RETURN (SCM_SUBRF (proc) (arg1, args)); + case scm_tc7_subr_2: + if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) + scm_wrong_num_args (proc); + args = SCM_CAR (args); + RETURN (SCM_SUBRF (proc) (arg1, args)); + case scm_tc7_subr_0: + if (!SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) ()); + case scm_tc7_subr_1: + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + case scm_tc7_subr_1o: + if (!scm_is_null (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_dsubr: + if (SCM_UNBNDP (arg1) || !scm_is_null (args)) + scm_wrong_num_args (proc); + if (SCM_I_INUMP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } + else if (SCM_BIGP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } + else if (SCM_FRACTIONP (arg1)) + { + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + } + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); + case scm_tc7_cxr: + if (SCM_UNBNDP (arg1) || !scm_is_null (args)) + scm_wrong_num_args (proc); + RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); + case scm_tc7_subr_3: + if (scm_is_null (args) + || scm_is_null (SCM_CDR (args)) + || !scm_is_null (SCM_CDDR (args))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); +#else + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); +#endif + case scm_tc7_lsubr_2: + if (!scm_is_pair (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); + case scm_tc7_asubr: + if (scm_is_null (args)) + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + while (SCM_NIMP (args)) + { + SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); + arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); + args = SCM_CDR (args); + } + RETURN (arg1); + case scm_tc7_rpsubr: + if (scm_is_null (args)) + RETURN (SCM_BOOL_T); + while (SCM_NIMP (args)) + { + SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); + if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CAR (args); + args = SCM_CDR (args); + } + RETURN (SCM_BOOL_T); + case scm_tcs_closures: +#ifdef DEVAL + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args); +#else + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)) + scm_wrong_num_args (proc); + + /* Copy argument list */ + if (SCM_IMP (arg1)) + args = arg1; + else + { + SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); + for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1)) + { + SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); + tl = SCM_CDR (tl); + } + SCM_SETCDR (tl, arg1); + } + + args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + args, + SCM_ENV (proc)); + proc = SCM_CLOSURE_BODY (proc); + again: + arg1 = SCM_CDR (proc); + while (!scm_is_null (arg1)) + { + if (SCM_IMP (SCM_CAR (proc))) + { + if (SCM_ISYMP (SCM_CAR (proc))) + { + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (proc))) + m_expand_body (proc, args); + scm_dynwind_end (); + goto again; + } + else + SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc)); + } + else + (void) EVAL (SCM_CAR (proc), args); + proc = arg1; + arg1 = SCM_CDR (proc); + } + RETURN (EVALCAR (proc, args)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badproc; + if (SCM_UNBNDP (arg1)) + RETURN (SCM_SMOB_APPLY_0 (proc)); + else if (scm_is_null (args)) + RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); + else if (scm_is_null (SCM_CDR (args))) + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); + else + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); + case scm_tc7_cclo: +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = scm_cons (arg1, args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); +#endif + goto tail; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.vect[0].a.proc = proc; +#endif + goto tail; + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + RETURN (scm_apply_generic (proc, args)); + } + else if (SCM_I_OPERATORP (proc)) + { + /* operator */ +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = scm_cons (arg1, args); +#endif + if (SCM_NIMP (proc)) + goto tail; + else + goto badproc; + } + else + goto badproc; + default: + badproc: + scm_wrong_type_arg ("apply", SCM_ARG1, proc); + } +#ifdef DEVAL +exit: + if (scm_check_exit_p && SCM_TRAPS_P) + if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) + { + SCM_CLEAR_TRACED_FRAME (debug); + arg1 = scm_make_debugobj (&debug); + SCM_TRAPS_P = 0; + arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); + SCM_TRAPS_P = 1; + if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) + proc = SCM_CDR (arg1); + } + scm_i_set_last_debug_frame (debug.prev); + return proc; +#endif +} + From 243ebb61133e9cdd56fb3b7feb1ed75827c576f7 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:20:35 +0000 Subject: [PATCH 103/116] * private-options.h: idem. * eval.i.c: copyright nitpicking. * eval.c: distangle. move duplicate code to eval.i.c and include twice. * eval.i.c: new file. * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, read.h, stacks.c, symbols.c, throw.c: use private-options.h * private-options.h: new file: contain hardcoded option definitions. --- libguile/ChangeLog | 4 ++++ libguile/eval.c | 14 +++++++------- libguile/eval.i.c | 20 ++++++++++++++++++++ libguile/private-options.h | 2 +- 4 files changed, 32 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index eb5d6e9ad..4a6749ef1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,9 @@ 2007-01-22 Han-Wen Nienhuys + * private-options.h: idem. + + * eval.i.c: copyright nitpicking. + * eval.c: distangle. move duplicate code to eval.i.c and include twice. diff --git a/libguile/eval.c b/libguile/eval.c index fba9f4a65..b48eef78f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2972,13 +2972,13 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, - - /* - FIXME. - */ - { SCM_OPTION_INTEGER, "stack", 0, "Stack size limit (measured in words; 0 = no check)." }, - { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}, - { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }, + { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, + { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, + "Show file names and line numbers " + "in backtraces when not `#f'. A value of `base' " + "displays only base names, while `#t' displays full names."}, + { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, + "Warn when deprecated features are used." }, { 0 }, }; diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 898cca5ec..c1e1fb62e 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -1,3 +1,23 @@ +/* + * eval.i.c - actual evaluator code for GUILE + * + * Copyright (C) 2002, 03, 04, 05, 06, 07 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 2.1 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 + */ + #undef RETURN #undef ENTER_APPLY #undef PREP_APPLY diff --git a/libguile/private-options.h b/libguile/private-options.h index 6ec83538c..eeaf0c17b 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -4,7 +4,7 @@ * We put this in a private header, since layout of data structures * is an implementation detail that we want to hide. * - * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc. + * Copyright (C) 2007 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 From 3d178652b8e5906df1b5da5f6183c5967e49342b Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:29:56 +0000 Subject: [PATCH 104/116] * eval.c: remove superfluous ifndef DEVAL. * eval.c: distangle. move duplicate code to eval.i.c and include twice. * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, read.h, stacks.c, symbols.c, throw.c: use private-options.h --- libguile/ChangeLog | 2 ++ libguile/eval.c | 4 ---- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4a6749ef1..e5e7028c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2007-01-22 Han-Wen Nienhuys + * eval.c: remove superfluous ifndef DEVAL. + * private-options.h: idem. * eval.i.c: copyright nitpicking. diff --git a/libguile/eval.c b/libguile/eval.c index b48eef78f..b51b58f74 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3162,8 +3162,6 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, /* SECTION: The rest of this file is only read once. */ -#ifndef DEVAL - /* Trampolines * * Trampolines make it possible to move procedure application dispatch @@ -4089,8 +4087,6 @@ scm_init_eval () scm_add_feature ("delay"); } -#endif /* !DEVAL */ - /* Local Variables: c-file-style: "gnu" From d00a0704a95a20e1803ddcabddfb50c6ba3c68a2 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 15:57:22 +0000 Subject: [PATCH 105/116] regularize comments. --- libguile/ChangeLog | 2 ++ libguile/srcprop.c | 24 +++++++++++++----------- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e5e7028c2..72aae203a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2007-01-22 Han-Wen Nienhuys + * srcprop.c: regularize comments. + * eval.c: remove superfluous ifndef DEVAL. * private-options.h: idem. diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 16c023bc2..c7d4e2cc0 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -58,13 +58,14 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); /* - layout: + * Source properties are stored as double cells with the + * following layout: - car = tag - cbr = pos - ccr = copy - cdr = plist -*/ + * car = tag + * cbr = pos + * ccr = copy + * cdr = plist + */ #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) #define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK) @@ -117,11 +118,12 @@ scm_c_source_property_breakpoint_p (SCM form) /* - A protected cells whose cdr contains the last plist - used if plist contains only the filename. - - This works because scm_set_source_property_x does - not use assoc-set! for modifying the plist. + * We remember the last file name settings, so we can share that plist + * entry. This works because scm_set_source_property_x does not use + * assoc-set! for modifying the plist. + * + * This variable contains a protected cons, whose cdr is the cached + * plist */ static SCM scm_last_plist_filename; From 8cb7939c78e71ef9be636d9570d181a6e41933ff Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 22 Jan 2007 16:00:23 +0000 Subject: [PATCH 106/116] (s_scm_vector_move_right_x): complain about naming. --- libguile/ChangeLog | 2 ++ libguile/vectors.c | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 72aae203a..d53274640 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,7 @@ 2007-01-22 Han-Wen Nienhuys + * vectors.c (s_scm_vector_move_right_x): complain about naming. + * srcprop.c: regularize comments. * eval.c: remove superfluous ifndef DEVAL. diff --git a/libguile/vectors.c b/libguile/vectors.c index fef48cc3e..33a216a95 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -439,6 +439,10 @@ scm_i_vector_equal_p (SCM x, SCM y) } +/* + * Naming is inconsistent: this routine modifies its 3rd argument, + * rather than 1st. --hwn + */ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n" @@ -477,6 +481,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, } #undef FUNC_NAME +/* + * See previous naming comment. --hwn + */ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n" From 2a8d66b090cdbf9646714653f64359acc83f13fe Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Thu, 25 Jan 2007 01:16:24 +0000 Subject: [PATCH 107/116] *** empty log message *** --- libguile/ChangeLog | 4 ++++ libguile/vectors.c | 7 ------- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d53274640..2b764f9cb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2007-01-25 Han-Wen Nienhuys + + * vector.c: remove comment as per kryde's request. + 2007-01-22 Han-Wen Nienhuys * vectors.c (s_scm_vector_move_right_x): complain about naming. diff --git a/libguile/vectors.c b/libguile/vectors.c index 33a216a95..fef48cc3e 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -439,10 +439,6 @@ scm_i_vector_equal_p (SCM x, SCM y) } -/* - * Naming is inconsistent: this routine modifies its 3rd argument, - * rather than 1st. --hwn - */ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n" @@ -481,9 +477,6 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, } #undef FUNC_NAME -/* - * See previous naming comment. --hwn - */ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n" From a872aa83e5e4a34e9c002abe34350785f40caa9f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 28 Jan 2007 09:35:18 +0000 Subject: [PATCH 108/116] New upstream version. --- ABOUT-NLS | 1459 ++++++++++++++++++++++++++++++++--------------------- ChangeLog | 4 + 2 files changed, 900 insertions(+), 563 deletions(-) diff --git a/ABOUT-NLS b/ABOUT-NLS index 2f50c6693..ec20977e0 100644 --- a/ABOUT-NLS +++ b/ABOUT-NLS @@ -1,10 +1,11 @@ -Notes on the Free Translation Project -************************************* +1 Notes on the Free Translation Project +*************************************** Free software is going international! The Free Translation Project is a way to get maintainers of free software, translators, and users all -together, so that will gradually become able to speak many languages. -A few packages already provide translations for their messages. +together, so that free software will gradually become able to speak many +languages. A few packages already provide translations for their +messages. If you found this `ABOUT-NLS' file inside a distribution, you may assume that the distributed package does use GNU `gettext' internally, @@ -15,15 +16,15 @@ this package with messages translated. Installers will find here some useful hints. These notes also explain how users should proceed for getting the programs to use the available translations. They tell how people wanting to contribute and -work at translations should contact the appropriate team. +work on translations can contact the appropriate team. When reporting bugs in the `intl/' directory or bugs which may be related to internationalization, you should tell about the version of `gettext' which is used. The information can be found in the `intl/VERSION' file, in internationalized packages. -Quick configuration advice -========================== +1.1 Quick configuration advice +============================== If you want to exploit the full power of internationalization, you should configure it using @@ -45,8 +46,8 @@ to change to GNU `gettext' as soon as possible. you have installed a recent copy of the GNU gettext package with the included `libintl'. -INSTALL Matters -=============== +1.2 INSTALL Matters +=================== Some packages are "localizable" when properly installed; the programs they contain can be made to speak your own native language. Most such @@ -55,27 +56,27 @@ internationalization, predating GNU `gettext'. By default, this package will be installed to allow translation of messages. It will automatically detect whether the system already -provides the GNU `gettext' functions. If not, the GNU `gettext' own -library will be used. This library is wholly contained within this -package, usually in the `intl/' subdirectory, so prior installation of -the GNU `gettext' package is _not_ required. Installers may use -special options at configuration time for changing the default -behaviour. The commands: +provides the GNU `gettext' functions. If not, the included GNU +`gettext' library will be used. This library is wholly contained +within this package, usually in the `intl/' subdirectory, so prior +installation of the GNU `gettext' package is _not_ required. +Installers may use special options at configuration time for changing +the default behaviour. The commands: ./configure --with-included-gettext ./configure --disable-nls -will respectively bypass any pre-existing `gettext' to use the +will, respectively, bypass any pre-existing `gettext' to use the internationalizing routines provided within this package, or else, _totally_ disable translation of messages. When you already have GNU `gettext' installed on your system and run configure without an option for your new package, `configure' will probably detect the previously built and installed `libintl.a' file and -will decide to use this. This might be not what is desirable. You -should use the more recent version of the GNU `gettext' library. I.e. -if the file `intl/VERSION' shows that the library which comes with this -package is more recent, you should use +will decide to use this. This might not be desirable. You should use +the more recent version of the GNU `gettext' library. I.e. if the file +`intl/VERSION' shows that the library which comes with this package is +more recent, you should use ./configure --with-included-gettext @@ -86,7 +87,7 @@ and therefore it will not be used. The reason is that even an emulation of `gettext' on top of `catgets' could not provide all the extensions of the GNU `gettext' library. - Internationalized packages have usually many `po/LL.po' files, where + Internationalized packages usually have many `po/LL.po' files, where LL gives an ISO 639 two-letter code identifying the language. Unless translations have been forbidden at `configure' time by using the `--disable-nls' switch, all available translations are installed @@ -95,8 +96,8 @@ may be set, prior to configuration, to limit the installed set. `LINGUAS' should then contain a space separated list of two-letter codes, stating which languages are allowed. -Using This Package -================== +1.3 Using This Package +====================== As a user, if your language has been installed for this package, you only have to set the `LANG' environment variable to the appropriate @@ -117,8 +118,8 @@ country code serves to distinguish the dialects. language and `CC' denoting the country, is the one use on systems based on GNU libc. On other systems, some variations of this scheme are used, such as `LL' or `LL_CC.ENCODING'. You can get the list of -locales supported by your system for your country by running the command -`locale -a | grep '^LL''. +locales supported by your system for your language by running the +command `locale -a | grep '^LL''. Not all programs have translations for all languages. By default, an English message is shown in place of a nonexistent translation. If you @@ -144,8 +145,8 @@ to denote the language's main dialect. For example, `de' is equivalent to `de_DE' (German as spoken in Germany), and `pt' to `pt_PT' (Portuguese as spoken in Portugal) in this context. -Translating Teams -================= +1.4 Translating Teams +===================== For the Free Translation Project to be a success, we need interested people who like their own language and write it well, and who are also @@ -171,565 +172,897 @@ get started, please write to `translation@iro.umontreal.ca' to reach the coordinator for all translator teams. The English team is special. It works at improving and uniformizing -the terminology in use. Proven linguistic skill are praised more than -programming skill, here. +the terminology in use. Proven linguistic skills are praised more than +programming skills, here. -Available Packages -================== +1.5 Available Packages +====================== Languages are not equally supported in all packages. The following -matrix shows the current state of internationalization, as of January -2004. The matrix shows, in regard of each package, for which languages +matrix shows the current state of internationalization, as of October +2006. The matrix shows, in regard of each package, for which languages PO files have been submitted to translation coordination, with a translation percentage of at least 50%. - Ready PO files af am ar az be bg bs ca cs da de el en en_GB eo es + Ready PO files af am ar az be bg bs ca cs cy da de el en en_GB eo +----------------------------------------------------+ - a2ps | [] [] [] [] | - aegis | () | - ant-phone | () | - anubis | | + GNUnet | [] | + a2ps | [] [] [] [] [] | + aegis | () | + ant-phone | () | + anubis | [] | ap-utils | | - aspell | [] | - bash | [] [] [] [] | - batchelor | | - bfd | [] [] | - binutils | [] [] | - bison | [] [] [] | - bluez-pin | [] [] [] | - clisp | | - clisp | [] [] [] | - console-tools | [] [] | - coreutils | [] [] [] [] | - cpio | [] [] [] | - darkstat | [] () [] | - diffutils | [] [] [] [] [] [] [] | - e2fsprogs | [] [] [] | - enscript | [] [] [] [] | - error | [] [] [] [] [] | - fetchmail | [] () [] [] [] [] | - fileutils | [] [] [] | - findutils | [] [] [] [] [] [] [] | - flex | [] [] [] [] | - fslint | | - gas | [] | - gawk | [] [] [] [] | - gbiff | [] | + aspell | [] [] [] [] [] | + bash | [] [] [] | + batchelor | [] | + bfd | | + bibshelf | [] | + binutils | [] | + bison | [] [] | + bison-runtime | | + bluez-pin | [] [] [] [] [] | + cflow | [] | + clisp | [] [] | + console-tools | [] [] | + coreutils | [] [] [] | + cpio | | + cpplib | [] [] [] | + cryptonit | [] | + darkstat | [] () [] | + dialog | [] [] [] [] [] [] | + diffutils | [] [] [] [] [] [] | + doodle | [] | + e2fsprogs | [] [] | + enscript | [] [] [] [] | + error | [] [] [] [] | + fetchmail | [] [] () [] | + fileutils | [] [] | + findutils | [] [] [] | + flex | [] [] [] | + fslint | [] | + gas | | + gawk | [] [] [] | + gbiff | [] | gcal | [] | - gcc | [] [] | - gettext | [] [] [] [] [] | - gettext-examples | [] [] [] [] | - gettext-runtime | [] [] [] [] [] | - gettext-tools | [] [] [] | - gimp-print | [] [] [] [] [] | - gliv | | - glunarclock | [] [] | - gnubiff | [] | - gnucash | [] () [] [] | - gnucash-glossary | [] () [] | - gnupg | [] () [] [] [] [] | - gpe-aerial | [] | - gpe-beam | [] [] | - gpe-calendar | [] [] | - gpe-clock | [] [] | - gpe-conf | [] [] | - gpe-contacts | [] [] | + gcc | [] | + gettext-examples | [] [] [] [] [] | + gettext-runtime | [] [] [] [] [] | + gettext-tools | [] [] | + gimp-print | [] [] [] [] | + gip | [] | + gliv | [] | + glunarclock | [] | + gmult | [] [] | + gnubiff | () | + gnucash | () () [] | + gnucash-glossary | [] () | + gnuedu | | + gnulib | [] [] [] [] [] [] | + gnunet-gtk | | + gnutls | | + gpe-aerial | [] [] | + gpe-beam | [] [] | + gpe-calendar | | + gpe-clock | [] [] | + gpe-conf | [] [] | + gpe-contacts | | gpe-edit | [] | + gpe-filemanager | | gpe-go | [] | - gpe-login | [] [] | - gpe-ownerinfo | [] [] | - gpe-sketchbook | [] [] | - gpe-su | [] [] | - gpe-taskmanager | [] [] | + gpe-login | [] [] | + gpe-ownerinfo | [] [] | + gpe-package | | + gpe-sketchbook | [] [] | + gpe-su | [] [] | + gpe-taskmanager | [] [] | gpe-timesheet | [] | - gpe-today | [] [] | - gpe-todo | [] [] | - gphoto2 | [] [] [] [] | - gprof | [] [] [] | - gpsdrive | () () () | - gramadoir | [] | - grep | [] [] [] [] [] [] | - gretl | [] | - gtick | [] () | - hello | [] [] [] [] [] [] | - id-utils | [] [] | - indent | [] [] [] [] | - iso_3166 | [] [] [] [] [] [] [] [] [] [] | - iso_3166_1 | [] [] [] [] [] [] | + gpe-today | [] [] | + gpe-todo | | + gphoto2 | [] [] [] [] | + gprof | [] [] | + gpsdrive | () () | + gramadoir | [] [] | + grep | [] [] [] [] [] [] | + gretl | | + gsasl | | + gss | | + gst-plugins | [] [] [] [] | + gst-plugins-base | [] [] [] | + gst-plugins-good | [] [] [] [] [] [] [] | + gstreamer | [] [] [] [] [] [] [] | + gtick | () | + gtkam | [] [] [] | + gtkorphan | [] [] | + gtkspell | [] [] [] [] | + gutenprint | [] | + hello | [] [] [] [] [] | + id-utils | [] [] | + impost | | + indent | [] [] [] | + iso_3166 | [] [] | iso_3166_2 | | - iso_3166_3 | [] | - iso_4217 | [] [] [] [] | - iso_639 | | - jpilot | [] [] [] | + iso_4217 | [] | + iso_639 | [] [] | + jpilot | [] | jtag | | - jwhois | [] | - kbd | [] [] [] [] [] | - latrine | () | - ld | [] [] | - libc | [] [] [] [] [] [] | - libgpewidget | [] [] | - libiconv | [] [] [] [] [] | - lifelines | [] () | - lilypond | [] | + jwhois | | + kbd | [] [] [] [] | + keytouch | | + keytouch-editor | | + keytouch-keyboa... | | + latrine | () | + ld | [] | + leafpad | [] [] [] [] [] | + libc | [] [] [] [] [] | + libexif | [] | + libextractor | [] | + libgpewidget | [] [] [] | + libgpg-error | [] | + libgphoto2 | [] [] | + libgphoto2_port | [] [] | + libgsasl | | + libiconv | [] [] | + libidn | [] [] | + lifelines | [] () | + lilypond | [] | lingoteach | | - lingoteach_lessons | () () | - lynx | [] [] [] [] | - m4 | [] [] [] [] | - mailutils | [] [] | - make | [] [] [] | - man-db | [] () [] [] () | - minicom | [] [] [] | - mysecretdiary | [] [] [] | - nano | [] () [] [] [] | - nano_1_0 | [] () [] [] [] | - opcodes | [] | - parted | [] [] [] [] [] | - ptx | [] [] [] [] [] | + lynx | [] [] [] [] | + m4 | [] [] [] [] | + mailutils | [] | + make | [] [] | + man-db | [] () [] [] | + minicom | [] [] [] | + mysecretdiary | [] [] | + nano | [] [] [] | + nano_1_0 | [] () [] [] | + opcodes | [] | + parted | | + pilot-qof | [] | + psmisc | [] | + pwdutils | | python | | - radius | [] | - recode | [] [] [] [] [] [] [] | - rpm | [] [] | + qof | | + radius | [] | + recode | [] [] [] [] [] [] | + rpm | [] [] | screem | | - scrollkeeper | [] [] [] [] [] [] | - sed | [] [] [] [] [] [] | - sh-utils | [] [] [] | - shared-mime-info | | - sharutils | [] [] [] [] [] [] | - silky | () | - skencil | [] () [] | - sketch | [] () [] | - soundtracker | [] [] [] | - sp | [] | - tar | [] [] [] [] | - texinfo | [] [] [] | - textutils | [] [] [] [] | - tin | () () | - tp-robot | | - tuxpaint | [] [] [] [] [] [] [] | + scrollkeeper | [] [] [] [] [] [] [] [] | + sed | [] [] [] | + sh-utils | [] [] | + shared-mime-info | [] [] [] [] | + sharutils | [] [] [] [] [] [] | + shishi | | + silky | | + skencil | [] () | + sketch | [] () | + solfege | | + soundtracker | [] [] | + sp | [] | + stardict | [] | + system-tools-ba... | [] [] [] [] [] [] [] [] [] | + tar | [] | + texinfo | [] [] [] | + textutils | [] [] [] | + tin | () () | + tp-robot | [] | + tuxpaint | [] [] [] [] [] | unicode-han-tra... | | unicode-transla... | | - util-linux | [] [] [] [] [] | - vorbis-tools | [] [] [] [] | - wastesedge | () | - wdiff | [] [] [] [] | - wget | [] [] [] [] [] [] | - xchat | [] [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] | + util-linux | [] [] [] [] | + vorbis-tools | [] [] [] [] | + wastesedge | () | + wdiff | [] [] [] [] | + wget | [] [] | + xchat | [] [] [] [] [] [] | + xkeyboard-config | | + xpad | [] [] | +----------------------------------------------------+ - af am ar az be bg bs ca cs da de el en en_GB eo es - 4 0 0 1 9 4 1 40 41 60 78 17 1 5 13 68 - - et eu fa fi fr ga gl he hr hu id is it ja ko lg + af am ar az be bg bs ca cs cy da de el en en_GB eo + 10 0 1 2 9 22 1 42 41 2 60 95 16 1 17 16 + + es et eu fa fi fr ga gl gu he hi hr hu id is it + +--------------------------------------------------+ + GNUnet | | + a2ps | [] [] [] () | + aegis | | + ant-phone | [] | + anubis | [] | + ap-utils | [] [] | + aspell | [] [] [] | + bash | [] [] [] | + batchelor | [] [] | + bfd | [] | + bibshelf | [] [] [] | + binutils | [] [] [] | + bison | [] [] [] [] [] [] | + bison-runtime | [] [] [] [] [] | + bluez-pin | [] [] [] [] [] | + cflow | [] | + clisp | [] [] | + console-tools | | + coreutils | [] [] [] [] [] [] | + cpio | [] [] [] | + cpplib | [] [] | + cryptonit | [] | + darkstat | [] () [] [] [] | + dialog | [] [] [] [] [] [] [] [] | + diffutils | [] [] [] [] [] [] [] [] [] | + doodle | [] [] | + e2fsprogs | [] [] [] | + enscript | [] [] [] | + error | [] [] [] [] [] | + fetchmail | [] | + fileutils | [] [] [] [] [] [] | + findutils | [] [] [] [] | + flex | [] [] [] | + fslint | [] | + gas | [] [] | + gawk | [] [] [] [] | + gbiff | [] | + gcal | [] [] | + gcc | [] | + gettext-examples | [] [] [] [] [] [] | + gettext-runtime | [] [] [] [] [] [] | + gettext-tools | [] [] [] | + gimp-print | [] [] | + gip | [] [] [] | + gliv | () | + glunarclock | [] [] [] | + gmult | [] [] [] | + gnubiff | () () | + gnucash | () () () | + gnucash-glossary | [] [] | + gnuedu | [] | + gnulib | [] [] [] [] [] [] [] [] | + gnunet-gtk | | + gnutls | | + gpe-aerial | [] [] | + gpe-beam | [] [] | + gpe-calendar | | + gpe-clock | [] [] [] [] | + gpe-conf | [] | + gpe-contacts | [] [] | + gpe-edit | [] [] [] [] | + gpe-filemanager | [] | + gpe-go | [] [] [] | + gpe-login | [] [] [] | + gpe-ownerinfo | [] [] [] [] [] | + gpe-package | [] | + gpe-sketchbook | [] [] | + gpe-su | [] [] [] [] | + gpe-taskmanager | [] [] [] | + gpe-timesheet | [] [] [] [] | + gpe-today | [] [] [] [] | + gpe-todo | [] | + gphoto2 | [] [] [] [] [] | + gprof | [] [] [] [] | + gpsdrive | () () [] () | + gramadoir | [] [] | + grep | [] [] [] [] [] [] [] [] [] [] [] [] | + gretl | [] [] [] | + gsasl | [] [] | + gss | [] | + gst-plugins | [] [] [] | + gst-plugins-base | [] [] | + gst-plugins-good | [] [] [] | + gstreamer | [] [] [] | + gtick | [] | + gtkam | [] [] [] [] | + gtkorphan | [] [] | + gtkspell | [] [] [] [] [] [] | + gutenprint | [] | + hello | [] [] [] [] [] [] [] [] [] [] [] [] [] | + id-utils | [] [] [] [] [] | + impost | [] [] | + indent | [] [] [] [] [] [] [] [] [] [] | + iso_3166 | [] [] [] | + iso_3166_2 | [] | + iso_4217 | [] [] [] [] | + iso_639 | [] [] [] [] [] | + jpilot | [] [] | + jtag | [] | + jwhois | [] [] [] [] [] | + kbd | [] [] | + keytouch | [] | + keytouch-editor | [] | + keytouch-keyboa... | [] | + latrine | [] [] [] | + ld | [] [] | + leafpad | [] [] [] [] [] [] | + libc | [] [] [] [] [] | + libexif | [] | + libextractor | [] | + libgpewidget | [] [] [] [] [] | + libgpg-error | | + libgphoto2 | [] [] [] | + libgphoto2_port | [] [] | + libgsasl | [] [] | + libiconv | [] [] | + libidn | [] [] | + lifelines | () | + lilypond | [] | + lingoteach | [] [] [] | + lynx | [] [] [] | + m4 | [] [] [] [] | + mailutils | [] [] | + make | [] [] [] [] [] [] [] [] | + man-db | () | + minicom | [] [] [] [] | + mysecretdiary | [] [] [] | + nano | [] [] [] [] [] [] | + nano_1_0 | [] [] [] [] [] | + opcodes | [] [] [] [] | + parted | [] [] [] [] | + pilot-qof | | + psmisc | [] [] [] | + pwdutils | | + python | | + qof | [] | + radius | [] [] | + recode | [] [] [] [] [] [] [] [] | + rpm | [] [] | + screem | | + scrollkeeper | [] [] [] | + sed | [] [] [] [] [] | + sh-utils | [] [] [] [] [] [] [] | + shared-mime-info | [] [] [] [] [] [] | + sharutils | [] [] [] [] [] [] [] [] | + shishi | | + silky | [] | + skencil | [] [] | + sketch | [] [] | + solfege | [] | + soundtracker | [] [] [] | + sp | [] | + stardict | [] | + system-tools-ba... | [] [] [] [] [] [] [] [] | + tar | [] [] [] [] [] [] [] | + texinfo | [] [] | + textutils | [] [] [] [] [] | + tin | [] () | + tp-robot | [] [] [] [] | + tuxpaint | [] [] | + unicode-han-tra... | | + unicode-transla... | [] [] | + util-linux | [] [] [] [] [] [] [] | + vorbis-tools | [] [] | + wastesedge | () | + wdiff | [] [] [] [] [] [] [] [] | + wget | [] [] [] [] [] [] [] [] | + xchat | [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] [] [] | + xpad | [] [] [] | + +--------------------------------------------------+ + es et eu fa fi fr ga gl gu he hi hr hu id is it + 88 22 14 2 40 115 61 14 1 8 1 6 59 31 0 52 + + ja ko ku ky lg lt lv mk mn ms mt nb ne nl nn no +-------------------------------------------------+ - a2ps | [] [] [] () () | - aegis | | - ant-phone | [] | - anubis | [] | - ap-utils | [] | - aspell | [] [] | - bash | [] [] | - batchelor | [] [] | - bfd | [] | - binutils | [] [] | - bison | [] [] [] [] | - bluez-pin | [] [] [] [] [] | - clisp | | - clisp | [] | + GNUnet | | + a2ps | () [] [] () | + aegis | () | + ant-phone | [] | + anubis | [] [] [] | + ap-utils | [] | + aspell | [] [] | + bash | [] | + batchelor | [] [] | + bfd | | + bibshelf | [] | + binutils | | + bison | [] [] [] | + bison-runtime | [] [] [] | + bluez-pin | [] [] [] | + cflow | | + clisp | [] | console-tools | | - coreutils | [] [] [] [] [] [] | - cpio | [] [] [] [] | - darkstat | () [] [] [] | - diffutils | [] [] [] [] [] [] [] | - e2fsprogs | | - enscript | [] [] | - error | [] [] [] [] | - fetchmail | [] | - fileutils | [] [] [] [] [] [] | - findutils | [] [] [] [] [] [] [] [] [] [] [] | - flex | [] [] [] | - fslint | [] | - gas | [] | - gawk | [] [] [] | - gbiff | [] | - gcal | [] | - gcc | [] | - gettext | [] [] [] | - gettext-examples | [] [] | - gettext-runtime | [] [] [] [] [] | - gettext-tools | [] [] [] | - gimp-print | [] [] | - gliv | () | - glunarclock | [] [] [] [] | - gnubiff | [] | - gnucash | () [] | - gnucash-glossary | [] | - gnupg | [] [] [] [] [] [] [] | - gpe-aerial | [] | - gpe-beam | [] | - gpe-calendar | [] [] [] | - gpe-clock | [] | - gpe-conf | [] | - gpe-contacts | [] [] | - gpe-edit | [] [] | - gpe-go | [] | - gpe-login | [] [] | - gpe-ownerinfo | [] [] [] | - gpe-sketchbook | [] | - gpe-su | [] | - gpe-taskmanager | [] | - gpe-timesheet | [] [] [] | - gpe-today | [] [] | - gpe-todo | [] [] | - gphoto2 | [] [] [] | - gprof | [] [] | - gpsdrive | () () () | - gramadoir | [] [] | - grep | [] [] [] [] [] [] [] [] [] [] [] | - gretl | [] [] | - gtick | [] [] [] | - hello | [] [] [] [] [] [] [] [] [] [] [] [] [] | - id-utils | [] [] [] [] | - indent | [] [] [] [] [] [] [] [] [] | - iso_3166 | [] [] [] [] [] [] [] | - iso_3166_1 | [] [] [] [] [] | - iso_3166_2 | | - iso_3166_3 | | - iso_4217 | [] [] [] [] [] [] | - iso_639 | | - jpilot | [] () | - jtag | [] | - jwhois | [] [] [] [] | - kbd | [] | - latrine | [] | - ld | [] | - libc | [] [] [] [] [] [] | - libgpewidget | [] [] [] [] | - libiconv | [] [] [] [] [] [] [] [] [] | - lifelines | () | - lilypond | [] | - lingoteach | [] [] | - lingoteach_lessons | | - lynx | [] [] [] [] | - m4 | [] [] [] [] | + coreutils | [] | + cpio | | + cpplib | [] | + cryptonit | [] | + darkstat | [] [] | + dialog | [] [] | + diffutils | [] [] [] | + doodle | | + e2fsprogs | [] | + enscript | [] | + error | [] | + fetchmail | [] [] | + fileutils | [] [] | + findutils | [] | + flex | [] [] | + fslint | [] [] | + gas | | + gawk | [] [] | + gbiff | [] | + gcal | | + gcc | | + gettext-examples | [] [] | + gettext-runtime | [] [] [] | + gettext-tools | [] [] | + gimp-print | [] [] | + gip | [] [] | + gliv | [] | + glunarclock | [] [] | + gmult | [] [] | + gnubiff | | + gnucash | () () | + gnucash-glossary | [] | + gnuedu | | + gnulib | [] [] [] [] | + gnunet-gtk | | + gnutls | | + gpe-aerial | [] | + gpe-beam | [] | + gpe-calendar | [] | + gpe-clock | [] [] [] | + gpe-conf | [] [] | + gpe-contacts | [] | + gpe-edit | [] [] [] | + gpe-filemanager | [] [] | + gpe-go | [] [] [] | + gpe-login | [] [] [] | + gpe-ownerinfo | [] [] | + gpe-package | [] [] | + gpe-sketchbook | [] [] | + gpe-su | [] [] [] | + gpe-taskmanager | [] [] [] [] | + gpe-timesheet | [] | + gpe-today | [] [] | + gpe-todo | [] | + gphoto2 | [] [] | + gprof | | + gpsdrive | () () () | + gramadoir | () | + grep | [] [] [] [] | + gretl | | + gsasl | [] | + gss | | + gst-plugins | [] | + gst-plugins-base | | + gst-plugins-good | [] | + gstreamer | [] | + gtick | | + gtkam | [] | + gtkorphan | [] | + gtkspell | [] [] | + gutenprint | | + hello | [] [] [] [] [] [] | + id-utils | [] | + impost | | + indent | [] [] | + iso_3166 | [] | + iso_3166_2 | [] | + iso_4217 | [] [] [] | + iso_639 | [] [] | + jpilot | () () () | + jtag | | + jwhois | [] | + kbd | [] | + keytouch | [] | + keytouch-editor | | + keytouch-keyboa... | | + latrine | [] | + ld | | + leafpad | [] [] | + libc | [] [] [] [] [] | + libexif | | + libextractor | | + libgpewidget | [] | + libgpg-error | | + libgphoto2 | [] | + libgphoto2_port | [] | + libgsasl | [] | + libiconv | | + libidn | [] [] | + lifelines | [] | + lilypond | | + lingoteach | [] | + lynx | [] [] | + m4 | [] [] | mailutils | | - make | [] [] [] [] [] [] | - man-db | () () | - minicom | [] [] [] [] | - mysecretdiary | [] [] | - nano | [] [] [] [] | - nano_1_0 | [] [] [] [] | - opcodes | [] | - parted | [] [] [] | - ptx | [] [] [] [] [] [] [] | + make | [] [] [] | + man-db | () | + minicom | [] | + mysecretdiary | [] | + nano | [] [] [] | + nano_1_0 | [] [] [] | + opcodes | [] | + parted | [] [] | + pilot-qof | | + psmisc | [] [] [] | + pwdutils | | python | | - radius | [] | - recode | [] [] [] [] [] [] | - rpm | [] [] | - screem | | - scrollkeeper | [] | - sed | [] [] [] [] [] [] [] [] [] | - sh-utils | [] [] [] [] [] [] [] | - shared-mime-info | [] [] [] | - sharutils | [] [] [] [] [] | - silky | () [] () () | - skencil | [] | - sketch | [] | - soundtracker | [] [] | - sp | [] () | - tar | [] [] [] [] [] [] [] [] [] | - texinfo | [] [] [] [] | - textutils | [] [] [] [] [] [] | - tin | [] () | - tp-robot | [] | - tuxpaint | [] [] [] [] [] [] [] [] [] | + qof | | + radius | | + recode | [] | + rpm | [] [] | + screem | [] | + scrollkeeper | [] [] [] [] | + sed | [] [] | + sh-utils | [] [] | + shared-mime-info | [] [] [] [] [] | + sharutils | [] [] | + shishi | | + silky | [] | + skencil | | + sketch | | + solfege | | + soundtracker | | + sp | () | + stardict | [] [] | + system-tools-ba... | [] [] [] [] | + tar | [] [] [] | + texinfo | [] [] [] | + textutils | [] [] [] | + tin | | + tp-robot | [] | + tuxpaint | [] | unicode-han-tra... | | - unicode-transla... | [] [] | - util-linux | [] [] [] [] () [] | - vorbis-tools | [] | - wastesedge | () | - wdiff | [] [] [] [] [] [] | - wget | [] [] [] [] [] [] [] | - xchat | [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] [] | + unicode-transla... | | + util-linux | [] [] | + vorbis-tools | [] | + wastesedge | [] | + wdiff | [] [] | + wget | [] [] | + xchat | [] [] [] [] | + xkeyboard-config | [] | + xpad | [] [] [] | +-------------------------------------------------+ - et eu fa fi fr ga gl he hr hu id is it ja ko lg - 22 2 1 26 106 28 24 8 10 41 33 1 26 33 12 0 - - lt lv mk mn ms mt nb nl nn no nso pl pt pt_BR ro ru - +-----------------------------------------------------+ - a2ps | [] [] () () [] [] [] | - aegis | () () () | - ant-phone | [] [] | - anubis | [] [] [] [] [] [] | - ap-utils | [] () [] | - aspell | [] | - bash | [] [] [] | - batchelor | [] | - bfd | [] | - binutils | [] | - bison | [] [] [] [] [] | - bluez-pin | [] [] [] | - clisp | | - clisp | [] | - console-tools | [] | - coreutils | [] [] | - cpio | [] [] [] [] [] | - darkstat | [] [] [] [] | - diffutils | [] [] [] [] [] [] | - e2fsprogs | [] | - enscript | [] [] [] [] | - error | [] [] [] | - fetchmail | [] [] () [] | - fileutils | [] [] [] | - findutils | [] [] [] [] [] | - flex | [] [] [] [] | - fslint | [] [] | - gas | | - gawk | [] [] [] | - gbiff | [] [] | - gcal | | - gcc | | - gettext | [] [] [] | - gettext-examples | [] [] [] | - gettext-runtime | [] [] [] [] | - gettext-tools | [] [] | - gimp-print | [] | - gliv | [] [] [] | - glunarclock | [] [] [] [] | - gnubiff | [] | - gnucash | [] [] () [] | - gnucash-glossary | [] [] | - gnupg | [] | - gpe-aerial | [] [] [] [] | - gpe-beam | [] [] [] [] | - gpe-calendar | [] [] [] [] | - gpe-clock | [] [] [] [] | - gpe-conf | [] [] [] [] | - gpe-contacts | [] [] [] [] | - gpe-edit | [] [] [] [] | - gpe-go | [] [] [] | - gpe-login | [] [] [] [] | - gpe-ownerinfo | [] [] [] [] | - gpe-sketchbook | [] [] [] [] | - gpe-su | [] [] [] [] | - gpe-taskmanager | [] [] [] [] | - gpe-timesheet | [] [] [] [] | - gpe-today | [] [] [] [] | - gpe-todo | [] [] [] [] | - gphoto2 | [] | - gprof | [] [] | - gpsdrive | () () [] | - gramadoir | () [] | - grep | [] [] [] [] [] | - gretl | | - gtick | [] [] [] | - hello | [] [] [] [] [] [] [] [] [] [] | - id-utils | [] [] [] [] | - indent | [] [] [] [] | - iso_3166 | [] [] [] | - iso_3166_1 | [] [] | - iso_3166_2 | | - iso_3166_3 | [] | - iso_4217 | [] [] [] [] [] [] [] [] | - iso_639 | [] | - jpilot | () () | - jtag | | - jwhois | [] [] [] [] () | - kbd | [] [] [] | - latrine | [] | - ld | | - libc | [] [] [] [] | - libgpewidget | [] [] [] | - libiconv | [] [] [] [] [] | - lifelines | | - lilypond | | - lingoteach | | - lingoteach_lessons | | - lynx | [] [] [] | - m4 | [] [] [] [] [] | - mailutils | [] [] [] | - make | [] [] [] [] | - man-db | [] | - minicom | [] [] [] [] | - mysecretdiary | [] [] [] | - nano | [] [] [] [] [] | - nano_1_0 | [] [] [] [] [] [] | - opcodes | [] [] | - parted | [] [] [] [] | - ptx | [] [] [] [] [] [] [] [] | - python | | - radius | [] [] | - recode | [] [] [] [] | - rpm | [] [] [] | - screem | | - scrollkeeper | [] [] [] [] [] | - sed | [] [] [] | - sh-utils | [] [] | - shared-mime-info | [] [] | - sharutils | [] [] | - silky | () | - skencil | [] [] | - sketch | [] [] | - soundtracker | | - sp | | - tar | [] [] [] [] [] [] | - texinfo | [] [] [] [] | - textutils | [] [] | - tin | | - tp-robot | [] | - tuxpaint | [] [] [] [] [] [] [] [] | - unicode-han-tra... | | - unicode-transla... | | - util-linux | [] [] [] | - vorbis-tools | [] [] [] | - wastesedge | | - wdiff | [] [] [] [] [] | - wget | [] [] [] | - xchat | [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] [] | - +-----------------------------------------------------+ - lt lv mk mn ms mt nb nl nn no nso pl pt pt_BR ro ru - 1 2 0 3 12 0 10 69 6 7 1 40 26 36 76 63 - - sk sl sr sv ta th tr uk ven vi wa xh zh_CN zh_TW zu - +-----------------------------------------------------+ - a2ps | [] [] [] [] | 16 - aegis | | 0 - ant-phone | | 3 - anubis | [] [] | 9 - ap-utils | () | 3 - aspell | | 4 - bash | | 9 - batchelor | | 3 - bfd | [] [] | 6 - binutils | [] [] [] | 8 - bison | [] [] | 14 - bluez-pin | [] [] [] | 14 - clisp | | 0 - clisp | | 5 - console-tools | | 3 - coreutils | [] [] [] [] | 16 - cpio | [] [] | 14 - darkstat | [] [] [] () () | 12 - diffutils | [] [] [] | 23 - e2fsprogs | [] [] | 6 - enscript | [] [] | 12 - error | [] [] [] | 15 - fetchmail | [] [] | 11 - fileutils | [] [] [] [] [] | 17 - findutils | [] [] [] [] [] [] | 29 - flex | [] [] | 13 - fslint | | 3 - gas | [] | 3 - gawk | [] [] | 12 - gbiff | | 4 - gcal | [] [] | 4 - gcc | [] | 4 - gettext | [] [] [] [] [] | 16 - gettext-examples | [] [] [] [] [] | 14 - gettext-runtime | [] [] [] [] [] [] [] [] | 22 - gettext-tools | [] [] [] [] [] [] | 14 - gimp-print | [] [] | 10 - gliv | | 3 - glunarclock | [] [] [] | 13 - gnubiff | | 3 - gnucash | [] [] | 9 - gnucash-glossary | [] [] [] | 8 - gnupg | [] [] [] [] | 17 - gpe-aerial | [] | 7 - gpe-beam | [] | 8 - gpe-calendar | [] [] [] [] | 13 - gpe-clock | [] [] [] | 10 - gpe-conf | [] [] | 9 - gpe-contacts | [] [] [] | 11 - gpe-edit | [] [] [] [] [] | 12 - gpe-go | | 5 - gpe-login | [] [] [] [] [] | 13 - gpe-ownerinfo | [] [] [] [] | 13 - gpe-sketchbook | [] [] | 9 - gpe-su | [] [] [] | 10 - gpe-taskmanager | [] [] [] | 10 - gpe-timesheet | [] [] [] [] | 12 - gpe-today | [] [] [] [] [] | 13 - gpe-todo | [] [] [] [] | 12 - gphoto2 | [] [] [] | 11 - gprof | [] [] | 9 - gpsdrive | [] [] | 3 - gramadoir | [] | 5 - grep | [] [] [] [] | 26 - gretl | | 3 - gtick | | 7 - hello | [] [] [] [] [] | 34 - id-utils | [] [] | 12 - indent | [] [] [] [] | 21 - iso_3166 | [] [] [] [] [] [] [] | 27 - iso_3166_1 | [] [] [] | 16 - iso_3166_2 | | 0 - iso_3166_3 | | 2 - iso_4217 | [] [] [] [] [] [] | 24 - iso_639 | | 1 - jpilot | [] [] [] [] [] | 9 - jtag | [] | 2 - jwhois | () [] [] | 11 - kbd | [] [] | 11 - latrine | | 2 - ld | [] [] | 5 - libc | [] [] [] [] | 20 - libgpewidget | [] [] [] [] | 13 - libiconv | [] [] [] [] [] [] [] [] | 27 - lifelines | [] | 2 - lilypond | [] | 3 - lingoteach | | 2 - lingoteach_lessons | () | 0 - lynx | [] [] [] | 14 - m4 | [] [] | 15 - mailutils | | 5 - make | [] [] [] | 16 - man-db | [] | 5 - minicom | | 11 - mysecretdiary | [] [] | 10 - nano | [] [] [] [] | 17 - nano_1_0 | [] [] [] | 17 - opcodes | [] [] | 6 - parted | [] [] [] | 15 - ptx | [] [] | 22 - python | | 0 - radius | | 4 - recode | [] [] [] | 20 - rpm | [] [] | 9 - screem | [] [] | 2 - scrollkeeper | [] [] [] | 15 - sed | [] [] [] [] [] [] | 24 - sh-utils | [] [] | 14 - shared-mime-info | [] [] | 7 - sharutils | [] [] [] [] | 17 - silky | () | 3 - skencil | [] | 6 - sketch | [] | 6 - soundtracker | [] [] | 7 - sp | [] | 3 - tar | [] [] [] [] [] | 24 - texinfo | [] [] [] | 14 - textutils | [] [] [] [] | 16 - tin | | 1 - tp-robot | | 2 - tuxpaint | [] [] [] [] [] | 29 - unicode-han-tra... | | 0 - unicode-transla... | | 2 - util-linux | [] [] | 15 - vorbis-tools | | 8 - wastesedge | | 0 - wdiff | [] [] [] | 18 - wget | [] [] [] [] [] [] [] [] | 24 - xchat | [] [] [] [] [] | 15 - xfree86_xkb_xml | [] [] [] [] [] | 11 - xpad | | 5 - +-----------------------------------------------------+ - 63 teams sk sl sr sv ta th tr uk ven vi wa xh zh_CN zh_TW zu - 131 domains 47 19 28 83 0 0 59 13 1 1 11 0 22 22 0 1373 + ja ko ku ky lg lt lv mk mn ms mt nb ne nl nn no + 52 24 2 2 1 3 0 2 3 21 0 15 1 97 5 1 + + nso or pa pl pt pt_BR rm ro ru rw sk sl sq sr sv ta + +------------------------------------------------------+ + GNUnet | | + a2ps | () [] [] [] [] [] [] | + aegis | () () | + ant-phone | [] [] | + anubis | [] [] [] | + ap-utils | () | + aspell | [] [] | + bash | [] [] [] | + batchelor | [] [] | + bfd | | + bibshelf | [] | + binutils | [] [] | + bison | [] [] [] [] [] | + bison-runtime | [] [] [] [] | + bluez-pin | [] [] [] [] [] [] [] [] [] | + cflow | [] | + clisp | [] | + console-tools | [] | + coreutils | [] [] [] [] | + cpio | [] [] [] | + cpplib | [] | + cryptonit | [] [] | + darkstat | [] [] [] [] [] [] | + dialog | [] [] [] [] [] [] [] [] [] | + diffutils | [] [] [] [] [] [] | + doodle | [] [] | + e2fsprogs | [] [] | + enscript | [] [] [] [] [] | + error | [] [] [] [] | + fetchmail | [] [] [] | + fileutils | [] [] [] [] [] | + findutils | [] [] [] [] [] [] | + flex | [] [] [] [] [] | + fslint | [] [] [] [] | + gas | | + gawk | [] [] [] [] | + gbiff | [] | + gcal | [] | + gcc | [] | + gettext-examples | [] [] [] [] [] [] [] [] | + gettext-runtime | [] [] [] [] [] [] [] [] | + gettext-tools | [] [] [] [] [] [] [] | + gimp-print | [] [] | + gip | [] [] [] [] | + gliv | [] [] [] [] | + glunarclock | [] [] [] [] [] [] | + gmult | [] [] [] [] | + gnubiff | () | + gnucash | () [] | + gnucash-glossary | [] [] [] | + gnuedu | | + gnulib | [] [] [] [] [] | + gnunet-gtk | [] | + gnutls | [] [] | + gpe-aerial | [] [] [] [] [] [] [] | + gpe-beam | [] [] [] [] [] [] [] | + gpe-calendar | [] | + gpe-clock | [] [] [] [] [] [] [] [] | + gpe-conf | [] [] [] [] [] [] [] | + gpe-contacts | [] [] [] [] [] | + gpe-edit | [] [] [] [] [] [] [] [] | + gpe-filemanager | [] [] | + gpe-go | [] [] [] [] [] [] | + gpe-login | [] [] [] [] [] [] [] [] | + gpe-ownerinfo | [] [] [] [] [] [] [] [] | + gpe-package | [] [] | + gpe-sketchbook | [] [] [] [] [] [] [] [] | + gpe-su | [] [] [] [] [] [] [] [] | + gpe-taskmanager | [] [] [] [] [] [] [] [] | + gpe-timesheet | [] [] [] [] [] [] [] [] | + gpe-today | [] [] [] [] [] [] [] [] | + gpe-todo | [] [] [] [] | + gphoto2 | [] [] [] [] [] | + gprof | [] [] [] | + gpsdrive | [] [] [] | + gramadoir | [] [] | + grep | [] [] [] [] [] [] [] [] | + gretl | [] | + gsasl | [] [] [] | + gss | [] [] [] | + gst-plugins | [] [] [] [] | + gst-plugins-base | [] | + gst-plugins-good | [] [] [] [] | + gstreamer | [] [] [] | + gtick | [] | + gtkam | [] [] [] [] | + gtkorphan | [] | + gtkspell | [] [] [] [] [] [] [] [] | + gutenprint | [] | + hello | [] [] [] [] [] [] [] [] | + id-utils | [] [] [] [] | + impost | [] | + indent | [] [] [] [] [] [] | + iso_3166 | [] [] [] [] [] [] | + iso_3166_2 | | + iso_4217 | [] [] [] [] | + iso_639 | [] [] [] [] | + jpilot | | + jtag | [] | + jwhois | [] [] [] [] | + kbd | [] [] [] | + keytouch | [] | + keytouch-editor | [] | + keytouch-keyboa... | [] | + latrine | [] [] | + ld | [] | + leafpad | [] [] [] [] [] [] | + libc | [] [] [] [] [] | + libexif | [] | + libextractor | [] [] | + libgpewidget | [] [] [] [] [] [] [] | + libgpg-error | [] [] | + libgphoto2 | [] | + libgphoto2_port | [] [] [] | + libgsasl | [] [] [] [] | + libiconv | [] [] | + libidn | [] [] () | + lifelines | [] [] | + lilypond | | + lingoteach | [] | + lynx | [] [] [] | + m4 | [] [] [] [] [] | + mailutils | [] [] [] [] | + make | [] [] [] [] | + man-db | [] [] | + minicom | [] [] [] [] [] | + mysecretdiary | [] [] [] [] | + nano | [] [] [] | + nano_1_0 | [] [] [] [] | + opcodes | [] [] | + parted | [] | + pilot-qof | [] | + psmisc | [] [] | + pwdutils | [] [] | + python | | + qof | [] [] | + radius | [] [] | + recode | [] [] [] [] [] [] [] | + rpm | [] [] [] [] | + screem | | + scrollkeeper | [] [] [] [] [] [] [] | + sed | [] [] [] [] [] [] [] [] [] | + sh-utils | [] [] [] | + shared-mime-info | [] [] [] [] [] | + sharutils | [] [] [] [] | + shishi | [] | + silky | [] | + skencil | [] [] [] | + sketch | [] [] [] | + solfege | [] | + soundtracker | [] [] | + sp | | + stardict | [] [] [] | + system-tools-ba... | [] [] [] [] [] [] [] [] [] | + tar | [] [] [] [] [] | + texinfo | [] [] [] [] | + textutils | [] [] [] | + tin | () | + tp-robot | [] | + tuxpaint | [] [] [] [] [] | + unicode-han-tra... | | + unicode-transla... | | + util-linux | [] [] [] [] | + vorbis-tools | [] [] | + wastesedge | | + wdiff | [] [] [] [] [] [] | + wget | [] [] [] [] | + xchat | [] [] [] [] [] [] [] | + xkeyboard-config | [] [] | + xpad | [] [] [] | + +------------------------------------------------------+ + nso or pa pl pt pt_BR rm ro ru rw sk sl sq sr sv ta + 0 2 3 58 30 54 5 73 72 4 40 46 11 50 128 2 + + tg th tk tr uk ven vi wa xh zh_CN zh_HK zh_TW zu + +---------------------------------------------------+ + GNUnet | [] | 2 + a2ps | [] [] [] | 19 + aegis | | 0 + ant-phone | [] [] | 6 + anubis | [] [] [] | 11 + ap-utils | () [] | 4 + aspell | [] [] [] | 15 + bash | [] | 11 + batchelor | [] [] | 9 + bfd | | 1 + bibshelf | [] | 7 + binutils | [] [] [] | 9 + bison | [] [] [] | 19 + bison-runtime | [] [] [] | 15 + bluez-pin | [] [] [] [] [] [] | 28 + cflow | [] [] | 5 + clisp | | 6 + console-tools | [] [] | 5 + coreutils | [] [] | 16 + cpio | [] [] [] | 9 + cpplib | [] [] [] [] | 11 + cryptonit | | 5 + darkstat | [] () () | 15 + dialog | [] [] [] [] [] | 30 + diffutils | [] [] [] [] | 28 + doodle | [] | 6 + e2fsprogs | [] [] | 10 + enscript | [] [] [] | 16 + error | [] [] [] [] | 18 + fetchmail | [] [] | 12 + fileutils | [] [] [] | 18 + findutils | [] [] [] | 17 + flex | [] [] | 15 + fslint | [] | 9 + gas | [] | 3 + gawk | [] [] | 15 + gbiff | [] | 5 + gcal | [] | 5 + gcc | [] [] [] | 6 + gettext-examples | [] [] [] [] [] [] | 27 + gettext-runtime | [] [] [] [] [] [] | 28 + gettext-tools | [] [] [] [] [] | 19 + gimp-print | [] [] | 12 + gip | [] [] | 12 + gliv | [] [] | 8 + glunarclock | [] [] [] | 15 + gmult | [] [] [] [] | 15 + gnubiff | [] | 1 + gnucash | () | 2 + gnucash-glossary | [] [] | 9 + gnuedu | [] | 2 + gnulib | [] [] [] [] [] | 28 + gnunet-gtk | | 1 + gnutls | | 2 + gpe-aerial | [] [] | 14 + gpe-beam | [] [] | 14 + gpe-calendar | [] | 3 + gpe-clock | [] [] [] [] | 21 + gpe-conf | [] [] | 14 + gpe-contacts | [] [] | 10 + gpe-edit | [] [] [] [] | 20 + gpe-filemanager | [] | 6 + gpe-go | [] [] | 15 + gpe-login | [] [] [] [] [] | 21 + gpe-ownerinfo | [] [] [] [] | 21 + gpe-package | [] | 6 + gpe-sketchbook | [] [] | 16 + gpe-su | [] [] [] | 20 + gpe-taskmanager | [] [] [] | 20 + gpe-timesheet | [] [] [] [] | 18 + gpe-today | [] [] [] [] [] | 21 + gpe-todo | [] | 7 + gphoto2 | [] [] [] [] | 20 + gprof | [] [] | 11 + gpsdrive | | 4 + gramadoir | [] | 7 + grep | [] [] [] [] | 34 + gretl | | 4 + gsasl | [] [] | 8 + gss | [] | 5 + gst-plugins | [] [] [] | 15 + gst-plugins-base | [] [] [] | 9 + gst-plugins-good | [] [] [] [] [] | 20 + gstreamer | [] [] [] | 17 + gtick | [] | 3 + gtkam | [] | 13 + gtkorphan | [] | 7 + gtkspell | [] [] [] [] [] [] | 26 + gutenprint | | 3 + hello | [] [] [] [] [] | 37 + id-utils | [] [] | 14 + impost | [] | 4 + indent | [] [] [] [] | 25 + iso_3166 | [] [] [] [] | 16 + iso_3166_2 | | 2 + iso_4217 | [] [] | 14 + iso_639 | [] | 14 + jpilot | [] [] [] [] | 7 + jtag | [] | 3 + jwhois | [] [] [] | 13 + kbd | [] [] | 12 + keytouch | [] | 4 + keytouch-editor | | 2 + keytouch-keyboa... | [] | 3 + latrine | [] [] | 8 + ld | [] [] [] [] | 8 + leafpad | [] [] [] [] | 23 + libc | [] [] [] | 23 + libexif | [] | 4 + libextractor | [] | 5 + libgpewidget | [] [] [] | 19 + libgpg-error | [] | 4 + libgphoto2 | [] | 8 + libgphoto2_port | [] [] [] | 11 + libgsasl | [] | 8 + libiconv | [] | 7 + libidn | [] [] | 10 + lifelines | | 4 + lilypond | | 2 + lingoteach | [] | 6 + lynx | [] [] [] | 15 + m4 | [] [] [] | 18 + mailutils | [] | 8 + make | [] [] [] | 20 + man-db | [] | 6 + minicom | [] | 14 + mysecretdiary | [] [] | 12 + nano | [] [] | 17 + nano_1_0 | [] [] [] | 18 + opcodes | [] [] | 10 + parted | [] [] [] | 10 + pilot-qof | [] | 3 + psmisc | [] | 10 + pwdutils | [] | 3 + python | | 0 + qof | [] | 4 + radius | [] | 6 + recode | [] [] [] | 25 + rpm | [] [] [] [] | 14 + screem | [] | 2 + scrollkeeper | [] [] [] [] | 26 + sed | [] [] [] | 22 + sh-utils | [] | 15 + shared-mime-info | [] [] [] [] | 24 + sharutils | [] [] [] | 23 + shishi | | 1 + silky | [] | 4 + skencil | [] | 7 + sketch | | 6 + solfege | | 2 + soundtracker | [] [] | 9 + sp | [] | 3 + stardict | [] [] [] [] | 11 + system-tools-ba... | [] [] [] [] [] [] [] | 37 + tar | [] [] [] [] | 20 + texinfo | [] [] [] | 15 + textutils | [] [] [] | 17 + tin | | 1 + tp-robot | [] [] [] | 10 + tuxpaint | [] [] [] | 16 + unicode-han-tra... | | 0 + unicode-transla... | | 2 + util-linux | [] [] [] | 20 + vorbis-tools | [] [] | 11 + wastesedge | | 1 + wdiff | [] [] | 22 + wget | [] [] [] | 19 + xchat | [] [] [] [] | 29 + xkeyboard-config | [] [] [] [] | 11 + xpad | [] [] [] | 14 + +---------------------------------------------------+ + 77 teams tg th tk tr uk ven vi wa xh zh_CN zh_HK zh_TW zu + 170 domains 0 1 1 77 39 0 136 10 1 48 5 54 0 2028 Some counters in the preceding matrix are higher than the number of visible blocks let us expect. This is because a few extra PO files are @@ -742,13 +1075,13 @@ distributed as such by its maintainer. There might be an observable lag between the mere existence a PO file and its wide availability in a distribution. - If January 2004 seems to be old, you may fetch a more recent copy of + If October 2006 seems to be old, you may fetch a more recent copy of this `ABOUT-NLS' file on most GNU archive sites. The most up-to-date matrix with full percentage details can be found at `http://www.iro.umontreal.ca/contrib/po/HTML/matrix.html'. -Using `gettext' in new packages -=============================== +1.6 Using `gettext' in new packages +=================================== If you are writing a freely available program and want to internationalize it you are welcome to use GNU `gettext' in your diff --git a/ChangeLog b/ChangeLog index b64d3cc60..1452b9d2d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2007-01-28 Neil Jerram + + * ABOUT-NLS: New upstream version. + 2007-01-22 Han-Wen Nienhuys * .gitignore: new file. Make using git easier. From 3d4797caa52a174b122f156dc22aa6eade43b3a3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 28 Jan 2007 09:36:51 +0000 Subject: [PATCH 109/116] New upstream version of INSTALL. --- ChangeLog | 2 ++ INSTALL | 50 ++++++++++++++++++++++++-------------------------- 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1452b9d2d..4a7459a91 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2007-01-28 Neil Jerram + * INSTALL: New upstream version. + * ABOUT-NLS: New upstream version. 2007-01-22 Han-Wen Nienhuys diff --git a/INSTALL b/INSTALL index 23e5f25d0..5458714e1 100644 --- a/INSTALL +++ b/INSTALL @@ -1,8 +1,8 @@ Installation Instructions ************************* -Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005 Free -Software Foundation, Inc. +Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, +2006 Free Software Foundation, Inc. This file is free documentation; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -10,7 +10,10 @@ unlimited permission to copy, distribute and modify it. Basic Installation ================== -These are generic installation instructions. +Briefly, the shell commands `./configure; make; make install' should +configure, build, and install this package. The following +more-detailed instructions are generic; see the `README' file for +instructions specific to this package. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses @@ -23,9 +26,9 @@ debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves -the results of its tests to speed up reconfiguring. (Caching is +the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale -cache files.) +cache files. If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail @@ -35,20 +38,17 @@ some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create -`configure' by a program called `autoconf'. You only need -`configure.ac' if you want to change it or regenerate `configure' using -a newer version of `autoconf'. +`configure' by a program called `autoconf'. You need `configure.ac' if +you want to change it or regenerate `configure' using a newer version +of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type - `./configure' to configure the package for your system. If you're - using `csh' on an old version of System V, you might need to type - `sh ./configure' instead to prevent `csh' from trying to execute - `configure' itself. + `./configure' to configure the package for your system. - Running `configure' takes awhile. While running, it prints some - messages telling which features it is checking for. + Running `configure' might take a while. While running, it prints + some messages telling which features it is checking for. 2. Type `make' to compile the package. @@ -78,7 +78,7 @@ details on some of the pertinent environment variables. by setting variables in the command line or in the environment. Here is an example: - ./configure CC=c89 CFLAGS=-O2 LIBS=-lposix + ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. @@ -87,17 +87,15 @@ Compiling For Multiple Architectures You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their -own directory. To do this, you must use a version of `make' that -supports the `VPATH' variable, such as GNU `make'. `cd' to the +own directory. To do this, you can use GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. - If you have to use a `make' that does not support the `VPATH' -variable, you have to compile the package for one architecture at a -time in the source code directory. After you have installed the -package for one architecture, use `make distclean' before reconfiguring -for another architecture. + With a non-GNU `make', it is safer to compile the package for one +architecture at a time in the source code directory. After you have +installed the package for one architecture, use `make distclean' before +reconfiguring for another architecture. Installation Names ================== @@ -190,12 +188,12 @@ them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified `gcc' to be used as the C compiler (unless it is -overridden in the site shell script). Here is a another example: +overridden in the site shell script). - /bin/bash ./configure CONFIG_SHELL=/bin/bash +Unfortunately, this technique does not work for `CONFIG_SHELL' due to +an Autoconf bug. Until the bug is fixed you can use this workaround: -Here the `CONFIG_SHELL=/bin/bash' operand causes subsequent -configuration-related scripts to be executed by `/bin/bash'. + CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash `configure' Invocation ====================== From 0bdb025f7bc89222f0759f39a87c2369faec407d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 28 Jan 2007 15:58:07 +0000 Subject: [PATCH 110/116] * configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will run autopoint. * acinclude.m4 (AM_INTL_SUBDIR): Provide dummy definition, to work around current autoconf/automake/gettext bug. --- ChangeLog | 6 ++++++ acinclude.m4 | 2 ++ configure.in | 1 + 3 files changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 4a7459a91..ab33f7db7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,11 @@ 2007-01-28 Neil Jerram + * configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will + run autopoint. + + * acinclude.m4 (AM_INTL_SUBDIR): Provide dummy definition, to work + around current autoconf/automake/gettext bug. + * INSTALL: New upstream version. * ABOUT-NLS: New upstream version. diff --git a/acinclude.m4 b/acinclude.m4 index 345e323b3..deae8658f 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -308,3 +308,5 @@ else fi AC_LANG_RESTORE ])dnl ACX_PTHREAD + +AC_DEFUN([AM_INTL_SUBDIR], [])dnl diff --git a/configure.in b/configure.in index d2eca30cc..7ac933132 100644 --- a/configure.in +++ b/configure.in @@ -706,6 +706,7 @@ dnl i18n tests #fi #AC_CHECK_FUNCS([bindtextdomain textdomain]) AM_GNU_GETTEXT([external], [need-ngettext]) +AM_GNU_GETTEXT_VERSION([0.16]) ### Some systems don't declare some functions. On such systems, we ### need to at least provide our own K&R-style declarations. From a2f00b9b36930797bf9e19c4a00fd089b0be3c9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Jan 2007 20:58:20 +0000 Subject: [PATCH 111/116] Changes from arch/CVS synchronization --- ChangeLog | 5 + configure.in | 11 +- doc/ref/ChangeLog | 15 + doc/ref/api-data.texi | 4 +- doc/ref/api-i18n.texi | 441 +++++++++++------ doc/ref/posix.texi | 2 +- doc/ref/srfi-modules.texi | 15 +- ice-9/ChangeLog | 57 ++- ice-9/i18n.scm | 378 ++++++++++++++- libguile/ChangeLog | 35 ++ libguile/i18n.c | 864 ++++++++++++++++++++++++++++------ libguile/i18n.h | 2 + libguile/posix.c | 26 +- srfi/ChangeLog | 29 +- srfi/srfi-19.scm | 95 +--- test-suite/ChangeLog | 15 + test-suite/tests/i18n.test | 141 +++++- test-suite/tests/srfi-19.test | 16 + 18 files changed, 1732 insertions(+), 419 deletions(-) diff --git a/ChangeLog b/ChangeLog index ab33f7db7..47bc98d40 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2007-01-31 Ludovic Courtès + + * configure.in: Look for `langinfo.h', `nl_types.h', `xlocale.h' + and `nl_langinfo'. + 2007-01-28 Neil Jerram * configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will diff --git a/configure.in b/configure.in index 7ac933132..2d45f5f1c 100644 --- a/configure.in +++ b/configure.in @@ -530,12 +530,13 @@ AC_HEADER_SYS_WAIT # complex.h - new in C99 # fenv.h - available in C99, but not older systems # process.h - mingw specific +# langinfo.h, nl_types.h - SuS v2 # AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.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 \ -direct.h]) +direct.h langinfo.h nl_types.h]) # "complex double" is new in C99, and "complex" is only a keyword if # is included @@ -624,9 +625,10 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # truncate - not in mingw # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific -# strcoll_l, newlocale - GNU extensions (glibc) +# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin +# nl_langinfo - X/Open, not available on Windows. # -AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe 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 truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe 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 truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo]) # Reasons for testing: # netdb.h - not in mingw @@ -635,8 +637,9 @@ AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate # check this specifically, we need it for the timespec test below. # sethostname - the function itself check because it's not in mingw, # the DECL is checked because Solaris 10 doens't have in any header +# xlocale.h - needed on Darwin for the `locale_t' API # -AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h) +AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) AC_CHECK_DECLS([sethostname]) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 880772f17..c09bc96d0 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,18 @@ +2007-01-31 Ludovic Courtès + + * api-data.texi (Conversion): Made cross refs point to `Number + Input and Output' rather than `The ice-9 i18n Module'. + (String Comparison): Likewise for `Text Collation'. + * api-i18n.texi (Internationalization): Re-organized the whole + section, documented new i18n features. Added the following + subsections: `i18n Introduction', `Text Collation', `Character + Case Mapping', `Number Input and Output', `Accessing Locale + Information'. Removed `The ice-9 i18n Module'. + * posix.texi (Locales): Updated cross-ref formerly pointing to + `The ice-9 i18n Module'. + * srfi-modules.texi (SRFI-19 String to date): Mention the + internationalization of `string->date'. + 2007-01-19 Han-Wen Nienhuys * api-options.texi (Evaluator trap options): document diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 0b31b15e3..df913b2cd 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1015,7 +1015,7 @@ zero. The following procedures read and write numbers according to their external representation as defined by R5RS (@pxref{Lexical structure, R5RS Lexical Structure,, r5rs, The Revised^5 Report on the Algorithmic -Language Scheme}). @xref{The ice-9 i18n Module, the @code{(ice-9 +Language Scheme}). @xref{Number Input and Output, the @code{(ice-9 i18n)} module}, for locale-dependent number parsing. @deffn {Scheme Procedure} number->string n [radix] @@ -2949,7 +2949,7 @@ predicates (@pxref{Characters}), but are defined on character sequences. The first set is specified in R5RS and has names that end in @code{?}. The second set is specified in SRFI-13 and the names have no ending @code{?}. The predicates ending in @code{-ci} ignore the character case -when comparing strings. @xref{The ice-9 i18n Module, the @code{(ice-9 +when comparing strings. @xref{Text Collation, the @code{(ice-9 i18n)} module}, for locale-dependent string comparison. @rnindex string=? diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index 1927a755b..be5afe4f9 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -11,24 +11,29 @@ @cindex internationalization @cindex i18n -Guile provides internationalization support for Scheme programs in two -ways. First, procedures to manipulate text and data in a way that -conforms to particular cultural conventions (i.e., in a -``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}. -Second, Guile allows the use of GNU @code{gettext} to translate -program message strings. +Guile provides internationalization@footnote{For concision and style, +programmers often like to refer to internationalization as ``i18n''.} +support for Scheme programs in two ways. First, procedures to +manipulate text and data in a way that conforms to particular cultural +conventions (i.e., in a ``locale-dependent'' way) are provided in the +@code{(ice-9 i18n)}. Second, Guile allows the use of GNU +@code{gettext} to translate program message strings. @menu -* The ice-9 i18n Module:: Honoring cultural conventions. -* Gettext Support:: Translating message strings. +* i18n Introduction:: Introduction to Guile's i18n support. +* Text Collation:: Sorting strings and characters. +* Character Case Mapping:: Case mapping. +* Number Input and Output:: Parsing and printing numbers. +* Accessing Locale Information:: Detailed locale information. +* Gettext Support:: Translating message strings. @end menu -@node The ice-9 i18n Module -@subsection The @code{(ice-9 i18n)} Module +@node i18n Introduction, Text Collation, Internationalization, Internationalization +@subsection Internationalization with Guile -In order to make use of the following functions, one must import the -@code{(ice-9 i18n)} module in the usual way: +In order to make use of the functions described thereafter, the +@code{(ice-9 i18n)} module must be imported in the usual way: @example (use-modules (ice-9 i18n)) @@ -64,83 +69,41 @@ the user is defined by the @code{LC_MESSAGES} category The procedures provided by this module allow the development of programs that adapt automatically to any locale setting. As we will -see later, many of the locale-dependent procedures provided by this -module can optionally take a @dfn{locale object} argument. This -additional argument defines the locale settings that must be followed -by the invoked procedure. When it is omitted, then the current locale -settings of the process are followed (@pxref{Locales, -@code{setlocale}}). +see later, many of these procedures can optionally take a @dfn{locale +object} argument. This additional argument defines the locale +settings that must be followed by the invoked procedure. When it is +omitted, then the current locale settings of the process are followed +(@pxref{Locales, @code{setlocale}}). The following procedures allow the manipulation of such locale objects. -@deffn {Scheme Procedure} make-locale category-mask locale-name [base-locale] -@deffnx {C Function} scm_make_locale (category_mask, locale_name, base_locale) +@deffn {Scheme Procedure} make-locale category-list locale-name [base-locale] +@deffnx {C Function} scm_make_locale (category_list, locale_name, base_locale) Return a reference to a data structure representing a set of locale datasets. @var{locale-name} should be a string denoting a particular -locale, e.g., @code{"aa_DJ"}. Unlike for the @var{category} parameter -for @code{setlocale}, the @var{category-mask} parameter here uses a -single bit for each category, made by OR'ing together @code{LC_*_MASK} -bits. The optional @var{base-locale} argument can be used to specify -a locale object whose settings are to be used as a basis for the -locale object being returned. +locale (e.g., @code{"aa_DJ"}) and @var{category-list} should be either +a list of locale categories or a single category as used with +@code{setlocale} (@pxref{Locales, @code{setlocale}}). Optionally, if +@code{base-locale} is passed, it should be a locale object denoting +settings for categories not listed in @var{category-list}. -The available locale category masks are the following: - -@defvar LC_COLLATE_MASK -Represents the collation locale category. -@end defvar -@defvar LC_CTYPE_MASK -Represents the character classification locale category. -@end defvar -@defvar LC_MESSAGES_MASK -Represents the messages locale category. -@end defvar -@defvar LC_MONETARY_MASK -Represents the monetary locale category. -@end defvar -@defvar LC_NUMERIC_MASK -Represents the way numbers are displayed. -@end defvar -@defvar LC_TIME_MASK -Represents the way date and time are displayed -@end defvar - -The following category masks are also available but will not have any -effect on systems that do not support them: - -@defvar LC_PAPER_MASK -@defvarx LC_NAME_MASK -@defvarx LC_ADDRESS_MASK -@defvarx LC_TELEPHONE_MASK -@defvarx LC_MEASUREMENT_MASK -@defvarx LC_IDENTIFICATION_MASK -@end defvar - -Finally, there is also: - -@defvar LC_ALL_MASK -This represents all the locale categories supported by the system. -@end defvar - -The @code{LC_*_MASK} variables are bound to integers which may be OR'd -together using @code{logior} (@pxref{Primitive Numerics, -@code{logior}}). For instance, the following invocation creates a -locale object that combines the use of Esperanto for messages and -character classification with the default settings for the other -categories (i.e., the settings of the default @code{C} locale which -usually represents conventions in use in the USA): +The following invocation creates a locale object that combines the use +of Swedish for messages and character classification with the +default settings for the other categories (i.e., the settings of the +default @code{C} locale which usually represents conventions in use in +the USA): @example -(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO") +(make-locale (list LC_MESSAGE LC_CTYPE) "sv_SE") @end example -The following example combines the use of Swedish conventions with -monetary conventions from Croatia: +The following example combines the use of Esperanto messages and +conventions with monetary conventions from Croatia: @example -(make-locale LC_MONETARY_MASK "hr_HR" - (make-locale LC_ALL_MASK "sv_SE")) +(make-locale LC_MONETARY "hr_HR" + (make-locale LC_ALL "eo_EO")) @end example A @code{system-error} exception (@pxref{Handling Errors}) is raised by @@ -155,70 +118,56 @@ error may be raised later, when the locale object is actually used. Return true if @var{obj} is a locale object. @end deffn -The following procedures provide support for text collation. +@defvr {Scheme Variable} %global-locale +@defvrx {C Variable} scm_global_locale +This variable is bound to a locale object denoting the current process +locale as installed using @code{setlocale ()} (@pxref{Locales}). It +may be used like any other locale object, including as a third +argument to @code{make-locale}, for instance. +@end defvr + + +@node Text Collation, Character Case Mapping, i18n Introduction, Internationalization +@subsection Text Collation + +The following procedures provide support for text collation, i.e., +locale-dependent string and character sorting. @deffn {Scheme Procedure} string-locale? s1 s2 [locale] +@deffnx {Scheme Procedure} string-locale>? s1 s2 [locale] @deffnx {C Function} scm_string_locale_gt (s1, s2, locale) +@deffnx {Scheme Procedure} string-locale-ci? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) Compare strings @var{s1} and @var{s2} in a locale-dependent way. If @var{locale} is provided, it should be locale object (as returned by @code{make-locale}) and will be used to perform the comparison; -otherwise, the current system locale is used. -@end deffn - -@deffn {Scheme Procedure} string-locale-ci? s1 s2 [locale] -@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) -Compare strings @var{s1} and @var{s2} in a case-insensitive, and -locale-dependent way. If @var{locale} is provided, it should be -locale object (as returned by @code{make-locale}) and will be used to -perform the comparison; otherwise, the current system locale is used. +otherwise, the current system locale is used. For the @code{-ci} +variants, the comparison is made in a case-insensitive way. @end deffn @deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale] @deffnx {C Function} scm_string_locale_ci_eq (s1, s2, locale) Compare strings @var{s1} and @var{s2} in a case-insensitive, and locale-dependent way. If @var{locale} is provided, it should be -locale object (as returned by @code{make-locale}) and will be used to +a locale object (as returned by @code{make-locale}) and will be used to perform the comparison; otherwise, the current system locale is used. @end deffn @deffn {Scheme Procedure} char-locale? c1 c2 [locale] +@deffnx {Scheme Procedure} char-locale>? c1 c2 [locale] @deffnx {C Function} scm_char_locale_gt (c1, c2, locale) -Return true if character @var{c1} is greater than @var{c2} according -to @var{locale} or to the current locale. -@end deffn - -@deffn {Scheme Procedure} char-locale-ci? c1 c2 [locale] +@deffnx {Scheme Procedure} char-locale-ci>? c1 c2 [locale] @deffnx {C Function} scm_char_locale_ci_gt (c1, c2, locale) -Return true if character @var{c1} is greater than @var{c2}, in a case -insensitive way according to @var{locale} or to the current locale. +Compare characters @var{c1} and @var{c2} according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current locale. For the @code{-ci} variants, the comparison is +made in a case-insensitive way. @end deffn @deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale] @@ -227,6 +176,9 @@ Return true if character @var{c1} is equal to @var{c2}, in a case insensitive way according to @var{locale} or to the current locale. @end deffn +@node Character Case Mapping, Number Input and Output, Text Collation, Internationalization +@subsection Character Case Mapping + The procedures below provide support for ``character case mapping'', i.e., to convert characters or strings to their upper-case or lower-case equivalent. Note that SRFI-13 provides procedures that @@ -236,8 +188,8 @@ account specificities of the customs in use in a particular language or region of the world. For instance, while most languages using the Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'', Turkish maps lower-case ``i'' to ``Latin capital letter I with dot -above''. The following procedures allow to provide idiomatic -character mapping. +above''. The following procedures allow programmers to provide +idiomatic character mapping. @deffn {Scheme Procedure} char-locale-downcase chr [locale] @deffnx {C Function} scm_char_locale_upcase (chr, locale) @@ -263,12 +215,20 @@ Return a new string that is the down-case version of @var{str} according to either @var{locale} or the current locale. @end deffn -Finally, the following procedures allow programs to read numbers +Note that in the current implementation Guile has no notion of +multibyte characters and in a multibyte locale characters may not be +converted correctly. + +@node Number Input and Output, Accessing Locale Information, Character Case Mapping, Internationalization +@subsection Number Input and Output + +The following procedures allow programs to read and write numbers written according to a particular locale. As an example, in English, ``ten thousand and a half'' is usually written @code{10,000.5} while -in French it is written @code{10000,5}. These procedures allow to -account for these differences. +in French it is written @code{10 000,5}. These procedures allow such +differences to be taken into account. +@findex strtod @deffn {Scheme Procedure} locale-string->integer str [base [locale]] @deffnx {C Function} scm_locale_string_to_integer (str, base, locale) Convert string @var{str} into an integer according to either @@ -276,22 +236,239 @@ Convert string @var{str} into an integer according to either the current process locale. If @var{base} is specified, then it determines the base of the integer being read (e.g., @code{16} for an hexadecimal number, @code{10} for a decimal number); by default, -decimal numbers are read. Return two values: an integer (on success) -or @code{#f}, and the number of characters read from @var{str} -(@code{0} on failure). +decimal numbers are read. Return two values (@pxref{Multiple +Values}): an integer (on success) or @code{#f}, and the number of +characters read from @var{str} (@code{0} on failure). + +This function is based on the C library's @code{strtol} function +(@pxref{Parsing of Integers, @code{strtol},, libc, The GNU C Library +Reference Manual}). @end deffn +@findex strtod @deffn {Scheme Procedure} locale-string->inexact str [locale] @deffnx {C Function} scm_locale_string_to_inexact (str, locale) Convert string @var{str} into an inexact number according to either @var{locale} (a locale object as returned by @code{make-locale}) or -the current process locale. Return two values: an inexact number (on -success) or @code{#f}, and the number of characters read from -@var{str} (@code{0} on failure). +the current process locale. Return two values (@pxref{Multiple +Values}): an inexact number (on success) or @code{#f}, and the number +of characters read from @var{str} (@code{0} on failure). + +This function is based on the C library's @code{strtod} function +(@pxref{Parsing of Floats, @code{strtod},, libc, The GNU C Library +Reference Manual}). +@end deffn + +@deffn {Scheme Procedure} number->locale-string number [fraction-digits [locale]] +Convert @var{number} (an inexact) into a string according to the +cultural conventions of either @var{locale} (a locale object) or the +current locale. Optionally, @var{fraction-digits} may be bound to an +integer specifying the number of fractional digits to be displayed. +@end deffn + +@deffn {Scheme Procedure} monetary-amount->locale-string amount intl? [locale] +Convert @var{amount} (an inexact denoting a monetary amount) into a +string according to the cultural conventions of either @var{locale} (a +locale object) or the current locale. If @var{intl?} is true, then +the international monetary format for the given locale is used +(@pxref{Currency Symbol, international and locale monetary formats,, +libc, The GNU C Library Reference Manual}). @end deffn -@node Gettext Support +@node Accessing Locale Information, Gettext Support, Number Input and Output, Internationalization +@subsection Accessing Locale Information + +@findex nl_langinfo +@cindex low-level locale information +It is sometimes useful to obtain very specific information about a +locale such as the word it uses for days or months, its format for +representing floating-point figures, etc. The @code{(ice-9 i18n)} +module provides support for this in a way that is similar to the libc +functions @code{nl_langinfo ()} and @code{localeconv ()} +(@pxref{Locale Information, accessing locale information from C,, +libc, The GNU C Library Reference Manual}). The available functions +are listed below. + +@deffn {Scheme Procedure} locale-encoding [locale] +Return the name of the encoding (a string whose interpretation is +system-dependent) of either @var{locale} or the current locale. +@end deffn + +The following functions deal with dates and times. + +@deffn {Scheme Procedure} locale-day day [locale] +@deffnx {Scheme Procedure} locale-day-short day [locale] +@deffnx {Scheme Procedure} locale-month month [locale] +@deffnx {Scheme Procedure} locale-month-short month [locale] +Return the word (a string) used in either @var{locale} or the current +locale to name the day (or month) denoted by @var{day} (or +@var{month}), an integer between 1 and 7 (or 1 and 12). The +@code{-short} variants provide an abbreviation instead of a full name. +@end deffn + +@deffn {Scheme Procedure} locale-am-string [locale] +@deffnx {Scheme Procedure} locale-pm-string [locale] +Return a (potentially empty) string that is used to denote @i{ante +meridiem} (or @i{post meridiem}) hours in 12-hour format. +@end deffn + +@deffn {Scheme Procedure} locale-date+time-format [locale] +@deffnx {Scheme Procedure} locale-date-format [locale] +@deffnx {Scheme Procedure} locale-time-format [locale] +@deffnx {Scheme Procedure} locale-time+am/pm-format [locale] +@deffnx {Scheme Procedure} locale-era-date-format [locale] +@deffnx {Scheme Procedure} locale-era-date+time-format [locale] +@deffnx {Scheme Procedure} locale-era-time-format [locale] +These procedures return format strings suitable to @code{strftime} +(@pxref{Time}) that may be used to display (part of) a date/time +according to certain constraints and to the conventions of either +@var{locale} or the current locale (@pxref{The Elegant and Fast Way, +the @code{nl_langinfo ()} items,, libc, The GNU C Library Reference +Manual}). +@end deffn + +@deffn {Scheme Procedure} locale-era [locale] +@deffnx {Scheme Procedure} locale-era-year [locale] +These functions return, respectively, the era and the year of the +relevant era used in @var{locale} or the current locale. Most locales +do not define this value. In this case, the empty string is returned. +An example of a locale that does define this value is the Japanese +one. +@end deffn + +The following procedures give information about number representation. + +@deffn {Scheme Procedure} locale-decimal-point [locale] +@deffnx {Scheme Procedure} locale-thousands-separator [locale] +These functions return a string denoting the representation of the +decimal point or that of the thousand separator (respectively) for +either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} locale-digit-grouping [locale] +Return a (potentially circular) list of integers denoting how digits +of the integer part of a number are to be grouped, starting at the +decimal point and going to the left. The list contains integers +indicating the size of the successive groups, from right to left. If +the list is non-circular, then no grouping occurs for digits beyond +the last group. + +For instance, if the returned list is a circular list that contains +only @code{3} and the thousand separator is @code{","} (as is the case +with English locales), then the number @code{12345678} should be +printed @code{12,345,678}. +@end deffn + +The following procedures deal with the representation of monetary +amounts. Some of them take an additional @var{intl?} argument (a +boolean) that tells whether the international or local monetary +conventions for the given locale are to be used. + +@deffn {Scheme Procedure} locale-monetary-decimal-point [locale] +@deffnx {Scheme Procedure} locale-monetary-thousands-separator [locale] +@deffnx {Scheme Procedure} locale-monetary-grouping [locale] +These are the monetary counterparts of the above procedures. These +procedures apply to monetary amounts. +@end deffn + +@deffn {Scheme Procedure} locale-currency-symbol intl? [locale] +Return the currency symbol (a string) of either @var{locale} or the +current locale. + +The following example illustrates the difference between the local and +international monetary formats: + +@example +(define us (make-locale LC_MONETARY "en_US")) +(locale-currency-symbol #f us) +@result{} "-$" +(locale-currency-symbol #t us) +@result{} "USD " +@end example +@end deffn + +@deffn {Scheme Procedure} locale-monetary-fractional-digits intl? [locale] +Return the number of fractional digits to be used when printing +monetary amounts according to either @var{locale} or the current +locale. If the locale does not specify it, then @code{#f} is +returned. +@end deffn + +@deffn {Scheme Procedure} locale-currency-symbol-precedes-positive? intl? [locale] +@deffnx {Scheme Procedure} locale-currency-symbol-precedes-negative? intl? [locale] +@deffnx {Scheme Procedure} locale-positive-separated-by-space? intl? [locale] +@deffnx {Scheme Procedure} locale-negative-separated-by-space? intl? [locale] +These procedures return a boolean indicating whether the currency +symbol should precede a positive/negative number, and whether a +whitespace should be inserted between the currency symbol and a +positive/negative amount. +@end deffn + +@deffn {Scheme Procedure} locale-monetary-positive-sign [locale] +@deffnx {Scheme Procedure} locale-monetary-negative-sign [locale] +Return a string denoting the positive (respectively negative) sign +that should be used when printing a monetary amount. +@end deffn + +@deffn {Scheme Procedure} locale-positive-sign-position +@deffnx {Scheme Procedure} locale-negative-sign-position +These functions return a symbol telling where a sign of a +positive/negative monetary amount is to appear when printing it. The +possible values are: + +@table @code +@item parenthesize +The currency symbol and quantity should be surrounded by parentheses. +@item sign-before +Print the sign string before the quantity and currency symbol. +@item sign-after +Print the sign string after the quantity and currency symbol. +@item sign-before-currency-symbol +Print the sign string right before the currency symbol. +@item sign-after-currency-symbol +Print the sign string right after the currency symbol. +@item unspecified +Unspecified. We recommend you print the sign after the currency +symbol. +@end table + +@end deffn + +Finally, the two following procedures may be helpful when programming +user interfaces: + +@deffn {Scheme Procedure} locale-yes-regexp [locale] +@deffnx {Scheme Procedure} locale-no-regexp [locale] +Return a string that can be used as a regular expression to recognize +a positive (respectively, negative) response to a yes/no question. +For the C locale, the default values are typically @code{"^[yY]"} and +@code{"^[nN]"}, respectively. + +Here is an example: + +@example +(format #t "Does Guile rock?~%") +(let ((answer (read-line))) + (cond ((string-match (locale-yes-regexp) answer) + "Yes it does.") + ((string-match (locale-no-regexp) answer) + "No it doesn't.") + (else + "What do you mean?"))) +@end example + +For an internationalized yes/no string output, @code{gettext} should +be used (@pxref{Gettext Support}). +@end deffn + +Example uses of some of these functions are the implementation of the +@code{number->locale-string} and @code{monetary-amount->locale-string} +procedures (@pxref{Number Input and Output}), as well as that the +SRFI-19 date and time convertion to/from strings (@pxref{SRFI-19}). + + +@node Gettext Support, , Accessing Locale Information, Internationalization @subsection Gettext Support Guile provides an interface to GNU @code{gettext} for translating diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 31ca20b0d..faf57d6b1 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3219,7 +3219,7 @@ Locales and Internationalization, libc, The GNU C Library Reference Manual}. Note that @code{setlocale} affects locale settings for the whole -process. @xref{The ice-9 i18n Module, locale objects and +process. @xref{i18n Introduction, locale objects and @code{make-locale}}, for a thread-safe alternative. @end deffn diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 61c105c5b..df356cc58 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2132,10 +2132,10 @@ Conversions @samp{~D}, @samp{~x} and @samp{~X} are not currently described here, since the specification and reference implementation differ. -Currently Guile doesn't implement any localizations for the above, all -outputs are in English, and the @samp{~c} conversion is POSIX -@code{ctime} style @samp{~a ~b ~d ~H:~M:~S~z ~Y}. This may change in -the future. +Conversion is locale-dependent on systems that support it +(@pxref{Accessing Locale Information}). @xref{Locales, +@code{setlocale}}, for information on how to change the current +locale. @node SRFI-19 String to date @@ -2256,9 +2256,10 @@ Notice that the weekday matching forms don't affect the date object returned, instead the weekday will be derived from the day, month and year. -Currently Guile doesn't implement any localizations for the above, -month and weekday names are always expected in English. This may -change in the future. +Conversion is locale-dependent on systems that support it +(@pxref{Accessing Locale Information}). @xref{Locales, +@code{setlocale}}, for information on how to change the current +locale. @end defun diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 574c96b7d..9d03408db 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,31 @@ +2007-01-31 Ludovic Courtès + + * i18n.scm: Use `(ice-9 optargs)'. Don't export `LC_*_MASK' + variables. Added new exports. + (locale-encoding, locale-day-short, locale-day, + locale-month-short, locale-month, locale-am-string, + locale-pm-string, locale-date+time-format, locale-date-format, + locale-time-format, locale-time+am/pm-format, locale-era, + locale-era-year, locale-era-date+time-format, + locale-era-date-format, locale-era-time-format, + locale-currency-symbol, locale-monetary-fractional-digits, + locale-monetary-positive-sign, locale-monetary-negative-sign, + locale-monetary-decimal-point, + locale-monetary-thousands-separator, + locale-monetary-digit-grouping, + locale-currency-symbol-precedes-positive?, + locale-currency-symbol-precedes-negative?, + locale-positive-separated-by-space?, + locale-negative-separated-by-space?, + locale-positive-sign-position, locale-negative-sign-position, + %number-integer-part, add-monetary-sign+currency, + monetary-amount->locale-string, locale-digit-grouping, + locale-decimal-point, locale-thousands-separator, + number->locale-string, locale-yes-regexp, locale-no-regexp): New + procedures. + (define-vector-langinfo-mapping, define-simple-langinfo-mapping, + define-monetary-langinfo-mapping): New macros. + 2007-01-04 Kevin Ryde * boot-9.scm (top-repl): Check (defined? 'SIGBUS) before using that @@ -124,7 +152,7 @@ where `futures' should become `threads' from Marius' change of 2006-01-29. -2006-03-04 Ludovic Courts +2006-03-04 Ludovic Courtès * ice-9/boot-9.scm (make-autoload-interface): Don't call `set-car!' if the autoload interface has already been removed from MODULE's uses. @@ -146,7 +174,7 @@ * boot-9.scm (try-module-autoload): Make sure that module code is loaded with the default reader (current-reader #f). Thanks to - Ludovic Courts for pointing this problem out. + Ludovic Courtès for pointing this problem out. * stack-catch.scm (stack-catch): Use catch pre-unwind handler instead of lazy-catch. @@ -154,7 +182,7 @@ * boot-9.scm (error-catching-loop): Use catch pre-unwind handler instead of lazy-catch. -2006-02-01 Ludovic Courts +2006-02-01 Ludovic Courtès * deprecated.scm (make-uniform-array): Fill the returned vector with PROT, per guile 1.6 behaviour. @@ -170,7 +198,7 @@ 2006-01-13 Neil Jerram * boot-9.scm (repl-reader): Use value of current-reader fluid to - do the read, if set. (Thanks to Ludovic Courts for the patch.) + do the read, if set. (Thanks to Ludovic Courtès for the patch.) 2005-12-14 Neil Jerram @@ -186,7 +214,7 @@ * boot-9.scm (%cond-expand-features): Add srfi-61. -2005-10-27 Ludovic Courts +2005-10-27 Ludovic Courtès * networking.scm (sockaddr:flowinfo, sockaddr:scopeid): New functions. @@ -1215,7 +1243,7 @@ 2002-01-12 Marius Vollmer - More options for pretty-print. Thanks to Matthias Kppe! + More options for pretty-print. Thanks to Matthias Köppe! * pretty-print.scm (generic-write): New per-line-prefix argument. (pretty-print): Check whether the new keyword argument style is @@ -1292,7 +1320,7 @@ * session.scm (arity): Use new `arglist' procedure property to present a more detailed argument list. - Thanks to Matthias Kppe! + Thanks to Matthias Köppe! 2001-09-07 Thien-Thi Nguyen @@ -1511,12 +1539,12 @@ * optargs.scm (lambda*): Make sure that BODY is always put into a real body context so that it can contain internal definitions. - Thanks to Matthias Kppe! + Thanks to Matthias Köppe! * format.scm: Use (ice-9 and-let-star). (format:out): Initialize format:output-col with current column of `port', if it has one. Else leave it alone. Thanks to Matthias - Kppe! + Köppe! 2001-06-05 Marius Vollmer @@ -1621,7 +1649,7 @@ * boot-9.scm (define-module): Return the new module. (process-define-module): Use `spec' instead of `module-name' when - getting the syntax transformer. Thanks to Matthias Kppe! + getting the syntax transformer. Thanks to Matthias Köppe! 2001-05-21 Marius Vollmer @@ -1731,7 +1759,7 @@ * boot-9.scm (error-catching-repl): Call the E ("eval'er") procedure via call-with-values and call the P - ("printer") for each produced value. Thanks to Matthias Kppe! + ("printer") for each produced value. Thanks to Matthias Köppe! 2001-05-14 Martin Grabmueller @@ -2252,7 +2280,7 @@ 2000-08-14 Mikael Djurfeldt * format.scm (format:obj->str): Made tail-recursive. (Thanks to - Matthias Kppe.) + Matthias Köppe.) 2000-08-13 Mikael Djurfeldt @@ -2351,7 +2379,7 @@ 2000-06-20 Mikael Djurfeldt * session.scm (make-fold-modules): Detect circular references in - module graph. (Thanks to Matthias Kppe.) + module graph. (Thanks to Matthias Köppe.) 2000-06-20 Mikael Djurfeldt @@ -4813,3 +4841,6 @@ Fri Apr 19 13:53:08 1996 Tom Lord * The more things change... +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/ice-9/i18n.scm b/ice-9/i18n.scm index e782ee21a..e7c116e53 100644 --- a/ice-9/i18n.scm +++ b/ice-9/i18n.scm @@ -1,6 +1,6 @@ ;;;; i18n.scm --- internationalization support -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007 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 @@ -29,18 +29,10 @@ ;;; Code: (define-module (ice-9 i18n) + :use-module (ice-9 optargs) :export (;; `locale' type make-locale locale? - - ;; locale category masks (standard) - LC_ALL_MASK - LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK - LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK - - ;; locale category masks (non-standard) - LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK - LC_TELEPHONE_MASK LC_MEASUREMENT_MASK - LC_IDENTIFICATION_MASK + %global-locale ;; text collation string-locale? @@ -54,11 +46,373 @@ string-locale-downcase string-locale-upcase ;; reading numbers - locale-string->integer locale-string->inexact)) + locale-string->integer locale-string->inexact + + ;; charset/encoding + locale-encoding + + ;; days and months + locale-day-short locale-day locale-month-short locale-month + + ;; date and time + locale-am-string locale-pm-string + locale-date+time-format locale-date-format locale-time-format + locale-time+am/pm-format + locale-era locale-era-year + locale-era-date-format locale-era-date+time-format + locale-era-time-format + + ;; monetary + locale-currency-symbol + locale-monetary-decimal-point locale-monetary-thousands-separator + locale-monetary-grouping locale-monetary-fractional-digits + locale-currency-symbol-precedes-positive? + locale-currency-symbol-precedes-negative? + locale-positive-separated-by-space? + locale-negative-separated-by-space? + locale-monetary-positive-sign locale-monetary-negative-sign + locale-positive-sign-position locale-negative-sign-position + monetary-amount->locale-string + + ;; number formatting + locale-digit-grouping locale-decimal-point + locale-thousands-separator + number->locale-string + + ;; miscellaneous + locale-yes-regexp locale-no-regexp)) (load-extension "libguile-i18n-v-0" "scm_init_i18n") + +;;; +;;; Charset/encoding. +;;; + +(define (locale-encoding . locale) + (apply nl-langinfo CODESET locale)) + + +;;; +;;; Months and days. +;;; + +;; Helper macro: Define a procedure named NAME that maps its argument to +;; NL-ITEMS (when `nl-langinfo' is provided) or DEFAULTS (when `nl-langinfo' +;; is not provided). +(define-macro (define-vector-langinfo-mapping name nl-items defaults) + (let* ((item-count (length nl-items)) + (defines (if (provided? 'nl-langinfo) + `(define %nl-items (vector #f ,@nl-items)) + `(define %defaults (vector #f ,@defaults)))) + (make-body (lambda (result) + `(if (and (integer? item) (exact? item)) + (if (and (>= item 1) (<= item ,item-count)) + ,result + (throw 'out-of-range "out of range" item)) + (throw 'wrong-type-arg "wrong argument type" item))))) + `(define (,name item . locale) + ,defines + ,(make-body (if (provided? 'nl-langinfo) + '(apply nl-langinfo (vector-ref %nl-items item) locale) + '(vector-ref %defaults item)))))) + + +(define-vector-langinfo-mapping locale-day-short + (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7) + ("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) + +(define-vector-langinfo-mapping locale-day + (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7) + ("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(define-vector-langinfo-mapping locale-month-short + (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6 + ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12) + ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + +(define-vector-langinfo-mapping locale-month + (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12) + ("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + + + +;;; +;;; Date and time. +;;; + +;; Helper macro: Define a procedure NAME that gets langinfo item ITEM. +(define-macro (define-simple-langinfo-mapping name item default) + (let ((body (if (and (provided? 'nl-langinfo) (defined? item)) + `(apply nl-langinfo ,item locale) + default))) + `(define (,name . locale) + ,body))) + +(define-simple-langinfo-mapping locale-am-string + AM_STR "AM") +(define-simple-langinfo-mapping locale-pm-string + PM_STR "PM") +(define-simple-langinfo-mapping locale-date+time-format + D_T_FMT "%a %b %e %H:%M:%S %Y") +(define-simple-langinfo-mapping locale-date-format + D_FMT "%m/%d/%y") +(define-simple-langinfo-mapping locale-time-format + T_FMT "%H:%M:%S") +(define-simple-langinfo-mapping locale-time+am/pm-format + T_FMT_AMPM "%I:%M:%S %p") +(define-simple-langinfo-mapping locale-era + ERA "") +(define-simple-langinfo-mapping locale-era-year + ERA_YEAR "") +(define-simple-langinfo-mapping locale-era-date+time-format + ERA_D_T_FMT "") +(define-simple-langinfo-mapping locale-era-date-format + ERA_D_FMT "") +(define-simple-langinfo-mapping locale-era-time-format + ERA_T_FMT "") + + + +;;; +;;; Monetary information. +;;; + +(define-macro (define-monetary-langinfo-mapping name local-item intl-item + default/local default/intl) + (let ((body + (let ((intl (if (and (provided? 'nl-langinfo) (defined? intl-item)) + `(apply nl-langinfo ,intl-item locale) + default/intl)) + (local (if (and (provided? 'nl-langinfo) (defined? local-item)) + `(apply nl-langinfo ,local-item locale) + default/local))) + `(if intl? ,intl ,local)))) + + `(define (,name intl? . locale) + ,body))) + +;; FIXME: How can we use ALT_DIGITS? +(define-monetary-langinfo-mapping locale-currency-symbol + CRNCYSTR INT_CURR_SYMBOL + "-" "") +(define-monetary-langinfo-mapping locale-monetary-fractional-digits + FRAC_DIGITS INT_FRAC_DIGITS + 2 2) + +(define-simple-langinfo-mapping locale-monetary-positive-sign + POSITIVE_SIGN "+") +(define-simple-langinfo-mapping locale-monetary-negative-sign + NEGATIVE_SIGN "-") +(define-simple-langinfo-mapping locale-monetary-decimal-point + MON_DECIMAL_POINT "") +(define-simple-langinfo-mapping locale-monetary-thousands-separator + MON_THOUSANDS_SEP "") +(define-simple-langinfo-mapping locale-monetary-digit-grouping + MON_GROUPING '()) + +(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive? + P_CS_PRECEDES INT_P_CS_PRECEDES + #t #t) +(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative? + N_CS_PRECEDES INT_N_CS_PRECEDES + #t #t) + + +(define-monetary-langinfo-mapping locale-positive-separated-by-space? + ;; Whether a space should be inserted between a positive amount and the + ;; currency symbol. + P_SEP_BY_SPACE INT_P_SEP_BY_SPACE + #t #t) +(define-monetary-langinfo-mapping locale-negative-separated-by-space? + ;; Whether a space should be inserted between a negative amount and the + ;; currency symbol. + N_SEP_BY_SPACE INT_N_SEP_BY_SPACE + #t #t) + +(define-monetary-langinfo-mapping locale-positive-sign-position + ;; Position of the positive sign wrt. currency symbol and quantity in a + ;; monetary amount. + P_SIGN_POSN INT_P_SIGN_POSN + 'unspecified 'unspecified) +(define-monetary-langinfo-mapping locale-negative-sign-position + ;; Position of the negative sign wrt. currency symbol and quantity in a + ;; monetary amount. + N_SIGN_POSN INT_N_SIGN_POSN + 'unspecified 'unspecified) + + +(define (%number-integer-part int grouping separator) + ;; Process INT (a string denoting a number's integer part) and return a new + ;; string with digit grouping and separators according to GROUPING (a list, + ;; potentially circular) and SEPARATOR (a string). + + ;; Process INT from right to left. + (let loop ((int int) + (grouping grouping) + (result '())) + (cond ((string=? int "") (apply string-append result)) + ((null? grouping) (apply string-append int result)) + (else + (let* ((len (string-length int)) + (cut (min (car grouping) len))) + (loop (substring int 0 (- len cut)) + (cdr grouping) + (let ((sub (substring int (- len cut) len))) + (if (> len cut) + (cons* separator sub result) + (cons sub result))))))))) + +(define (add-monetary-sign+currency amount figure intl? locale) + ;; Add a sign and currency symbol around FIGURE. FIGURE should be a + ;; formatted unsigned amount (a string) representing AMOUNT. + (let* ((positive? (> amount 0)) + (sign + (cond ((> amount 0) (locale-monetary-positive-sign locale)) + ((< amount 0) (locale-monetary-negative-sign locale)) + (else ""))) + (currency (locale-currency-symbol intl? locale)) + (currency-precedes? + (if positive? + locale-currency-symbol-precedes-positive? + locale-currency-symbol-precedes-negative?)) + (separated? + (if positive? + locale-positive-separated-by-space? + locale-negative-separated-by-space?)) + (sign-position + (if positive? + locale-positive-sign-position + locale-negative-sign-position)) + (currency-space + (if (separated? intl? locale) " " "")) + (append-currency + (lambda (amt) + (if (currency-precedes? intl? locale) + (string-append currency currency-space amt) + (string-append amt currency-space currency))))) + + (case (sign-position intl? locale) + ((parenthesize) + (string-append "(" (append-currency figure) ")")) + ((sign-before) + (string-append sign (append-currency figure))) + ((sign-after unspecified) + ;; following glibc's recommendation for `unspecified'. + (if (currency-precedes? intl? locale) + (string-append currency currency-space sign figure) + (string-append figure currency-space currency sign))) + ((sign-before-currency-symbol) + (if (currency-precedes? intl? locale) + (string-append sign currency currency-space figure) + (string-append figure currency-space sign currency))) ;; unlikely + ((sign-after-currency-symbol) + (if (currency-precedes? intl? locale) + (string-append currency sign currency-space figure) + (string-append figure currency-space currency sign))) + (else + (error "unsupported sign position" (sign-position intl? locale)))))) + + +(define* (monetary-amount->locale-string amount intl? + #:optional (locale %global-locale)) + "Convert @var{amount} (an inexact) into a string according to the cultural +conventions of either @var{locale} (a locale object) or the current locale. +If @var{intl?} is true, then the international monetary format for the given +locale is used." + + (let* ((fraction-digits + (or (locale-monetary-fractional-digits intl? locale) 2)) + (decimal-part + (lambda (dec) + (if (or (string=? dec "") (eq? 0 fraction-digits)) + "" + (string-append (locale-monetary-decimal-point locale) + (if (< fraction-digits (string-length dec)) + (substring dec 0 fraction-digits) + dec))))) + + (external-repr (number->string (if (> amount 0) amount (- amount)))) + (int+dec (string-split external-repr #\.)) + (int (car int+dec)) + (dec (decimal-part (if (null? (cdr int+dec)) + "" + (cadr int+dec)))) + (grouping (locale-monetary-digit-grouping locale)) + (separator (locale-monetary-thousands-separator locale))) + + (add-monetary-sign+currency amount + (string-append + (%number-integer-part int grouping + separator) + dec) + intl? locale))) + + + +;;; +;;; Number formatting. +;;; + +(define-simple-langinfo-mapping locale-digit-grouping + GROUPING '()) +(define-simple-langinfo-mapping locale-decimal-point + RADIXCHAR ".") +(define-simple-langinfo-mapping locale-thousands-separator + THOUSEP "") + +(define* (number->locale-string number + #:optional (fraction-digits #t) + (locale %global-locale)) + "Convert @var{number} (an inexact) into a string according to the cultural +conventions of either @var{locale} (a locale object) or the current locale. +Optionally, @var{fraction-digits} may be bound to an integer specifying the +number of fractional digits to be displayed." + + (let* ((sign + (cond ((> number 0) "") + ((< number 0) "-") + (else ""))) + (decimal-part + (lambda (dec) + (if (or (string=? dec "") (eq? 0 fraction-digits)) + "" + (string-append (locale-decimal-point locale) + (if (and (integer? fraction-digits) + (< fraction-digits + (string-length dec))) + (substring dec 0 fraction-digits) + dec)))))) + + (let* ((external-repr (number->string (if (> number 0) + number + (- number)))) + (int+dec (string-split external-repr #\.)) + (int (car int+dec)) + (dec (decimal-part (if (null? (cdr int+dec)) + "" + (cadr int+dec)))) + (grouping (locale-digit-grouping locale)) + (separator (locale-thousands-separator locale))) + + (string-append sign + (%number-integer-part int grouping separator) + dec)))) + + +;;; +;;; Miscellaneous. +;;; + +(define-simple-langinfo-mapping locale-yes-regexp + YESEXPR "^[yY]") +(define-simple-langinfo-mapping locale-no-regexp + NOEXPR "^[nN]") + +;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them. + ;;; Local Variables: ;;; coding: latin-1 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2b764f9cb..29124f9b6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,38 @@ +2007-01-31 Ludovic Courtès + + * i18n.c: Include "libguile/threads.h" and "libguile/posix.h" + unconditionally. Include and when + available. + (SCM_I18N_STRINGIFY, SCM_LOCALE_CATEGORY_MASK, + SCM_LIST_OR_INTEGER_P): New macros. + (LC_*_MASK): When `USE_GNU_LOCALE_API' is undefined, define them + as powers of two instead of `(1 << LC_*)'. + (scm_i_locale_free): New function/macro. + (scm_global_locale): New global variable. + (smob_locale_free): Use `scm_i_locale_free ()'. + (smob_locale_mark): Check whether the SMOB is `%global-locale'. + (get_current_locale_settings): Return `EINVAL' instead of `errno' + when `setlocale' fails. + (restore_locale_settings): Likewise. + (install_locale_categories): Likewise. + (install_locale): Likewise. Stop the locale stack traversal when + all categories have been handled. + (get_current_locale, category_to_category_mask, + category_list_to_category_mask): New function. + (scm_make_locale): Use them. Accept both lists of `LC_*' values + and single `LC_*' values as the first argument. Handle the case + where BASE_LOCALE is `%global-locale'. When `USE_GNU_LOCALE_API', + duplicate C_BASE_LOCALE before using it. + (scm_nl_langinfo, define_langinfo_items): New functions. + (scm_init_i18n): When `HAVE_NL_LANGINFO', add feature + `nl-langinfo' and invoke `define_langinfo_items ()'. + * i18n.h (scm_global_locale, scm_nl_langinfo): New declarations. + * posix.c: Include when available. + (scm_i_locale_mutex): Always define it. Statically initialized. + (scm_set_locale): Invoke `scm_i_to_lc_category ()' before + acquiring the locale mutex. + (scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here. + 2007-01-25 Han-Wen Nienhuys * vector.c: remove comment as per kryde's request. diff --git a/libguile/i18n.c b/libguile/i18n.c index 76dd9a514..e23f79072 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2007 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 @@ -46,6 +46,7 @@ void *alloca (size_t); #include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/values.h" +#include "libguile/threads.h" #include #include /* `strcoll ()' */ @@ -53,11 +54,29 @@ void *alloca (size_t); #include #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale + Model, a Proposal'', by Ulrich Drepper: + + http://people.redhat.com/drepper/tllocale.ps.gz + + It is now also implemented by Darwin: + + http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html + + The whole API is being standardized by the X/Open Group (as of Jan. 2007) + following Drepper's proposal. */ # define USE_GNU_LOCALE_API #endif -#ifndef USE_GNU_LOCALE_API -# include "libguile/posix.h" /* for `scm_i_locale_mutex' */ +#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H) +# include +#endif + +#include "libguile/posix.h" /* for `scm_i_locale_mutex' */ + +#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H) +# include +# include #endif #ifndef HAVE_SETLOCALE @@ -69,6 +88,9 @@ setlocale (int category, const char *name) } #endif +/* Helper stringification macro. */ +#define SCM_I18N_STRINGIFY(_name) # _name + /* Locale objects, string and character collation, and other locale-dependent @@ -78,18 +100,16 @@ setlocale (int category, const char *name) locale API on non-GNU systems. The emulation is a bit "brute-force": Whenever a `-locale as found in glibc 2.3.6). This must be kept in sync with - `locale-categories.h'. */ +/* Provide the locale category masks as found in glibc. This must be kept in + sync with `locale-categories.h'. */ -# define LC_CTYPE_MASK (1 << LC_CTYPE) -# define LC_COLLATE_MASK (1 << LC_COLLATE) -# define LC_MESSAGES_MASK (1 << LC_MESSAGES) -# define LC_MONETARY_MASK (1 << LC_MONETARY) -# define LC_NUMERIC_MASK (1 << LC_NUMERIC) -# define LC_TIME_MASK (1 << LC_TIME) +# define LC_CTYPE_MASK 1 +# define LC_COLLATE_MASK 2 +# define LC_MESSAGES_MASK 4 +# define LC_MONETARY_MASK 8 +# define LC_NUMERIC_MASK 16 +# define LC_TIME_MASK 32 # ifdef LC_PAPER -# define LC_PAPER_MASK (1 << LC_PAPER) +# define LC_PAPER_MASK 64 # else # define LC_PAPER_MASK 0 # endif # ifdef LC_NAME -# define LC_NAME_MASK (1 << LC_NAME) +# define LC_NAME_MASK 128 # else # define LC_NAME_MASK 0 # endif # ifdef LC_ADDRESS -# define LC_ADDRESS_MASK (1 << LC_ADDRESS) +# define LC_ADDRESS_MASK 256 # else # define LC_ADDRESS_MASK 0 # endif # ifdef LC_TELEPHONE -# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) +# define LC_TELEPHONE_MASK 512 # else # define LC_TELEPHONE_MASK 0 # endif # ifdef LC_MEASUREMENT -# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) +# define LC_MEASUREMENT_MASK 1024 # else # define LC_MEASUREMENT_MASK 0 # endif # ifdef LC_IDENTIFICATION -# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) +# define LC_IDENTIFICATION_MASK 2048 # else # define LC_IDENTIFICATION_MASK 0 # endif -# define LC_ALL_MASK (LC_CTYPE_MASK \ - | LC_NUMERIC_MASK \ - | LC_TIME_MASK \ - | LC_COLLATE_MASK \ - | LC_MONETARY_MASK \ - | LC_MESSAGES_MASK \ - | LC_PAPER_MASK \ - | LC_NAME_MASK \ - | LC_ADDRESS_MASK \ - | LC_TELEPHONE_MASK \ - | LC_MEASUREMENT_MASK \ - | LC_IDENTIFICATION_MASK \ +# define LC_ALL_MASK (LC_CTYPE_MASK \ + | LC_NUMERIC_MASK \ + | LC_TIME_MASK \ + | LC_COLLATE_MASK \ + | LC_MONETARY_MASK \ + | LC_MESSAGES_MASK \ + | LC_PAPER_MASK \ + | LC_NAME_MASK \ + | LC_ADDRESS_MASK \ + | LC_TELEPHONE_MASK \ + | LC_MEASUREMENT_MASK \ + | LC_IDENTIFICATION_MASK \ ) /* Locale objects as returned by `make-locale' on non-GNU systems. */ @@ -163,12 +186,28 @@ typedef struct scm_locale int category_mask; } *scm_t_locale; -#else + +/* Free the resources used by LOCALE. */ +static inline void +scm_i_locale_free (scm_t_locale locale) +{ + free (locale->locale_name); + locale->locale_name = NULL; +} + +#else /* USE_GNU_LOCALE_API */ /* Alias for glibc's locale type. */ typedef locale_t scm_t_locale; -#endif +#define scm_i_locale_free freelocale + +#endif /* USE_GNU_LOCALE_API */ + + +/* A locale object denoting the global locale. */ +SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale"); + /* Validate parameter ARG as a locale object and set C_LOCALE to the corresponding C locale object. */ @@ -199,16 +238,8 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) { scm_t_locale c_locale; - c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); - -#ifdef USE_GNU_LOCALE_API - freelocale ((locale_t)c_locale); -#else - c_locale->base_locale = SCM_UNDEFINED; - free (c_locale->locale_name); - - scm_gc_free (c_locale, sizeof (* c_locale), "locale"); -#endif + c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); + scm_i_locale_free (c_locale); return 0; } @@ -217,76 +248,38 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) static SCM smob_locale_mark (SCM locale) { - scm_t_locale c_locale; + register SCM dependency; - c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); - return (c_locale->base_locale); -} -#endif + if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale))) + { + scm_t_locale c_locale; - -SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, - (SCM category_mask, SCM locale_name, SCM base_locale), - "Return a reference to a data structure representing a set of " - "locale datasets. Unlike for the @var{category} parameter for " - "@code{setlocale}, the @var{category_mask} parameter here uses " - "a single bit for each category, made by OR'ing together " - "@code{LC_*_MASK} bits.") -#define FUNC_NAME s_scm_make_locale -{ - SCM locale = SCM_BOOL_F; - int c_category_mask; - char *c_locale_name; - scm_t_locale c_base_locale, c_locale; - - SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask); - SCM_VALIDATE_STRING (2, locale_name); - SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); - - c_locale_name = scm_to_locale_string (locale_name); - -#ifdef USE_GNU_LOCALE_API - - c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); - - if (!c_locale) - locale = SCM_BOOL_F; + c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); + dependency = (c_locale->base_locale); + } else - SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); - - free (c_locale_name); - -#else - - c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); - c_locale->base_locale = base_locale; - - c_locale->category_mask = c_category_mask; - c_locale->locale_name = c_locale_name; - - SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + dependency = SCM_BOOL_F; + return dependency; +} #endif - return locale; -} -#undef FUNC_NAME -SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, - (SCM obj), - "Return true if @var{obj} is a locale object.") -#define FUNC_NAME s_scm_locale_p +static void inline scm_locale_error (const char *, int) SCM_NORETURN; + +/* Throw an exception corresponding to error ERR. */ +static void inline +scm_locale_error (const char *func_name, int err) { - if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)) - return SCM_BOOL_T; - - return SCM_BOOL_F; + scm_syserror_msg (func_name, + "Failed to install locale", + SCM_EOL, err); } -#undef FUNC_NAME -#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */ +/* Emulating GNU's reentrant locale API. */ +#ifndef USE_GNU_LOCALE_API /* Maximum number of chained locales (via `base_locale'). */ @@ -309,7 +302,7 @@ get_current_locale_settings (scm_t_locale_settings *settings) #define SCM_DEFINE_LOCALE_CATEGORY(_name) \ { \ SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \ - if (!locale_name) \ + if (locale_name == NULL) \ goto handle_error; \ \ settings-> _name = strdup (locale_name); \ @@ -323,7 +316,7 @@ get_current_locale_settings (scm_t_locale_settings *settings) return 0; handle_error: - return errno; + return EINVAL; handle_oom: return ENOMEM; @@ -346,7 +339,7 @@ restore_locale_settings (const scm_t_locale_settings *settings) return 0; handle_error: - return errno; + return EINVAL; } /* Free memory associated with SETTINGS. */ @@ -376,7 +369,7 @@ install_locale_categories (const char *locale_name, int category_mask) else { #define SCM_DEFINE_LOCALE_CATEGORY(_name) \ - if (category_mask & LC_ ## _name ## _MASK) \ + if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \ { \ SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \ if (result == NULL) \ @@ -389,7 +382,7 @@ install_locale_categories (const char *locale_name, int category_mask) return 0; handle_error: - return errno; + return EINVAL; } /* Install LOCALE, recursively installing its base locales first. On @@ -398,6 +391,7 @@ static int install_locale (scm_t_locale locale) { scm_t_locale stack[LOCALE_STACK_SIZE_MAX]; + int category_mask = 0; size_t stack_size = 0; int stack_offset = 0; const char *result = NULL; @@ -412,12 +406,16 @@ install_locale (scm_t_locale locale) stack[stack_size++] = locale; + /* Keep track of which categories have already been taken into + account. */ + category_mask |= locale->category_mask; + if (locale->base_locale != SCM_UNDEFINED) - locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale); + locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale); else locale = NULL; } - while (locale != NULL); + while ((locale != NULL) && (category_mask != LC_ALL_MASK)); /* Install the C locale to start from a pristine state. */ SCM_SYSCALL (result = setlocale (LC_ALL, "C")); @@ -442,7 +440,7 @@ install_locale (scm_t_locale locale) return 0; handle_error: - return errno; + return EINVAL; } /* Leave the locked locale section. */ @@ -481,19 +479,6 @@ enter_locale_section (scm_t_locale locale, return err; } -/* Throw an exception corresponding to error ERR. */ -static void inline -scm_locale_error (const char *func_name, int err) -{ - SCM s_err; - - s_err = scm_from_int (err); - scm_error (scm_system_error_key, func_name, - "Failed to install locale", - scm_cons (scm_strerror (s_err), SCM_EOL), - scm_cons (s_err, SCM_EOL)); -} - /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */ #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \ do \ @@ -514,10 +499,248 @@ scm_locale_error (const char *func_name, int err) } \ while (0) +/* Convert the current locale settings into a locale SMOB. On success, zero + is returned and RESULT points to the new SMOB. Otherwise, an error is + returned. */ +static int +get_current_locale (SCM *result) +{ + int err = 0; + scm_t_locale c_locale; + const char *current_locale; + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + c_locale->category_mask = LC_ALL_MASK; + c_locale->base_locale = SCM_UNDEFINED; + + current_locale = setlocale (LC_ALL, NULL); + if (current_locale != NULL) + { + c_locale->locale_name = strdup (current_locale); + if (c_locale->locale_name == NULL) + err = ENOMEM; + } + else + err = EINVAL; + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (err) + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); + else + SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale); + + return err; +} + + #endif /* !USE_GNU_LOCALE_API */ + -/* Locale-dependent string comparison. */ +/* `make-locale' can take either category lists or single categories (the + `LC_*' integer constants). */ +#define SCM_LIST_OR_INTEGER_P(arg) \ + (scm_is_integer (arg) || scm_is_true (scm_list_p (arg))) + + +/* Return the category mask corresponding to CATEGORY (an `LC_' integer + constant). */ +static inline int +category_to_category_mask (SCM category, + const char *func_name, int pos) +{ + int c_category; + int c_category_mask; + + c_category = scm_to_int (category); + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + case LC_ ## _name: \ + c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \ + break; + + switch (c_category) + { +#include "locale-categories.h" + + case LC_ALL: + c_category_mask = LC_ALL_MASK; + break; + + default: + scm_wrong_type_arg_msg (func_name, pos, category, + "locale category"); + } + +#undef SCM_DEFINE_LOCALE_CATEGORY + + return c_category_mask; +} + +/* Convert CATEGORIES, a list of locale categories or a single category (an + integer), into a category mask. */ +static int +category_list_to_category_mask (SCM categories, + const char *func_name, int pos) +{ + int c_category_mask = 0; + + if (scm_is_integer (categories)) + c_category_mask = category_to_category_mask (categories, + func_name, pos); + else + for (; !scm_is_null (categories); categories = SCM_CDR (categories)) + { + SCM category = SCM_CAR (categories); + + c_category_mask |= + category_to_category_mask (category, func_name, pos); + } + + return c_category_mask; +} + + +SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, + (SCM category_list, SCM locale_name, SCM base_locale), + "Return a reference to a data structure representing a set of " + "locale datasets. @var{category_list} should be either a list " + "of locale categories or a single category as used with " + "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and " + "@var{locale_name} should be the name of the locale considered " + "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is " + "passed, it should be a locale object denoting settings for " + "categories not listed in @var{category_list}.") +#define FUNC_NAME s_scm_make_locale +{ + SCM locale = SCM_BOOL_F; + int err = 0; + int c_category_mask; + char *c_locale_name; + scm_t_locale c_base_locale, c_locale; + + SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P); + SCM_VALIDATE_STRING (2, locale_name); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); + + c_category_mask = category_list_to_category_mask (category_list, + FUNC_NAME, 1); + c_locale_name = scm_to_locale_string (locale_name); + +#ifdef USE_GNU_LOCALE_API + + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + { + /* Fetch the current locale and turn in into a `locale_t'. Don't + duplicate the resulting `locale_t' because we want it to be consumed + by `newlocale ()'. */ + char *current_locale; + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + current_locale = setlocale (LC_ALL, NULL); + c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL); + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (c_base_locale == (locale_t) 0) + scm_locale_error (FUNC_NAME, errno); + } + else if (c_base_locale != (locale_t) 0) + { + /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be + duplicated before. */ + c_base_locale = duplocale (c_base_locale); + if (c_base_locale == (locale_t) 0) + { + err = errno; + goto fail; + } + } + + c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + + free (c_locale_name); + + if (c_locale == (locale_t) 0) + { + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + /* The base locale object was created lazily and must be freed. */ + freelocale (c_base_locale); + + scm_locale_error (FUNC_NAME, errno); + } + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + +#else + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + + c_locale->category_mask = c_category_mask; + c_locale->locale_name = c_locale_name; + + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + { + /* Get the current locale settings and turn them into a locale + object. */ + err = get_current_locale (&base_locale); + if (err) + goto fail; + } + + c_locale->base_locale = base_locale; + + { + /* Try out the new locale and raise an exception if it doesn't work. */ + int err; + scm_t_locale_settings prev_locale; + + err = enter_locale_section (c_locale, &prev_locale); + leave_locale_section (&prev_locale); + + if (err) + goto fail; + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + } + +#endif + + return locale; + + fail: +#ifndef USE_GNU_LOCALE_API + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); +#endif + free (c_locale_name); + scm_locale_error (FUNC_NAME, err); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a locale object.") +#define FUNC_NAME s_scm_locale_p +{ + return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)); +} +#undef FUNC_NAME + + + +/* Locale-dependent string comparison. + + A similar API can be found in MzScheme starting from version 200: + http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */ + /* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return an integer whose sign is the same as the difference between C_S1 and @@ -1124,33 +1347,388 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", } #undef FUNC_NAME + +/* Language information, aka. `nl_langinfo ()'. */ + +/* FIXME: Issues related to `nl-langinfo'. + + 1. The `CODESET' value is not normalized. This is a secondary issue, but + still a practical issue. See + http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset + normalization. + + 2. `nl_langinfo ()' is not available on Windows. + + 3. `nl_langinfo ()' may return strings encoded in a locale different from + the current one, thereby defeating `scm_from_locale_string ()'. + Example: support the current locale is "Latin-1" and one asks: + + (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8")) + + The result will be a UTF-8 string. However, `scm_from_locale_string', + which expects a Latin-1 string, won't be able to make much sense of the + returned string. Thus, we'd need an `scm_from_string ()' variant where + the locale (or charset) is explicitly passed. */ + + +SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, + (SCM item, SCM locale), + "Return a string denoting locale information for @var{item} " + "in the current locale or that specified by @var{locale}. " + "The semantics and arguments are the same as those of the " + "X/Open @code{nl_langinfo} function (@pxref{The Elegant and " + "Fast Way, @code{nl_langinfo},, libc, The GNU C Library " + "Reference Manual}).") +#define FUNC_NAME s_scm_nl_langinfo +{ +#ifdef HAVE_NL_LANGINFO + SCM result; + nl_item c_item; + char *c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_INT_COPY (2, item, c_item); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According + to SuS v2, that static string may be modified by subsequent calls to + `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must + acquire the locale mutex before doing invoking `nl_langinfo ()'. See + http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for + details. */ + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = nl_langinfo_l (c_item, c_locale); +#else + /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale + mutex is already taken. */ + int lsec_err; + scm_t_locale_settings lsec_prev_locale; + + lsec_err = get_current_locale_settings (&lsec_prev_locale); + if (lsec_err) + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + else + { + lsec_err = install_locale (c_locale); + if (lsec_err) + { + leave_locale_section (&lsec_prev_locale); + free_locale_settings (&lsec_prev_locale); + } + } + + if (lsec_err) + scm_locale_error (FUNC_NAME, lsec_err); + else + { + c_result = nl_langinfo (c_item); + + leave_locale_section (&lsec_prev_locale); + free_locale_settings (&lsec_prev_locale); + } +#endif + } + else + c_result = nl_langinfo (c_item); + + c_result = strdup (c_result); + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (c_result == NULL) + result = SCM_BOOL_F; + else + { + char *p; + + switch (c_item) + { + case GROUPING: + case MON_GROUPING: + /* In this cases, the result is to be interpreted as a list of + numbers. If the last item is `CHARS_MAX', it has the special + meaning "no more grouping". */ + result = SCM_EOL; + for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++) + result = scm_cons (SCM_I_MAKINUM ((int) *p), result); + + { + SCM last_pair = result; + + result = scm_reverse_x (result, SCM_EOL); + + if (*p != CHAR_MAX) + { + /* Cyclic grouping information. */ + if (last_pair != SCM_EOL) + SCM_SETCDR (last_pair, result); + } + } + + free (c_result); + break; + + case FRAC_DIGITS: + case INT_FRAC_DIGITS: + /* This is to be interpreted as a single integer. */ + if (*c_result == CHAR_MAX) + /* Unspecified. */ + result = SCM_BOOL_F; + else + result = SCM_I_MAKINUM (*c_result); + + free (c_result); + break; + + case P_CS_PRECEDES: + case N_CS_PRECEDES: + case INT_P_CS_PRECEDES: + case INT_N_CS_PRECEDES: + case P_SEP_BY_SPACE: + case N_SEP_BY_SPACE: + /* This is to be interpreted as a boolean. */ + result = scm_from_bool (*c_result); + + free (c_result); + break; + + case P_SIGN_POSN: + case N_SIGN_POSN: + case INT_P_SIGN_POSN: + case INT_N_SIGN_POSN: + /* See `(libc) Sign of Money Amount' for the interpretation of the + return value here. */ + switch (*c_result) + { + case 0: + result = scm_from_locale_symbol ("parenthesize"); + break; + + case 1: + result = scm_from_locale_symbol ("sign-before"); + break; + + case 2: + result = scm_from_locale_symbol ("sign-after"); + break; + + case 3: + result = scm_from_locale_symbol ("sign-before-currency-symbol"); + break; + + case 4: + result = scm_from_locale_symbol ("sign-after-currency-symbol"); + break; + + default: + result = scm_from_locale_symbol ("unspecified"); + } + break; + + default: + /* FIXME: `locale_string ()' is not appropriate here because of + encoding issues (see comment above). */ + result = scm_take_locale_string (c_result); + } + } + + return result; +#else + scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system", + SCM_EOL, ENOSYS); + + return SCM_BOOL_F; +#endif +} +#undef FUNC_NAME + +/* Define the `nl_item' constants. */ +static inline void +define_langinfo_items (void) +{ +#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H) + +#define DEFINE_NLITEM_CONSTANT(_item) \ + scm_c_define (# _item, scm_from_int (_item)) + + DEFINE_NLITEM_CONSTANT (CODESET); + + /* Abbreviated days of the week. */ + DEFINE_NLITEM_CONSTANT (ABDAY_1); + DEFINE_NLITEM_CONSTANT (ABDAY_2); + DEFINE_NLITEM_CONSTANT (ABDAY_3); + DEFINE_NLITEM_CONSTANT (ABDAY_4); + DEFINE_NLITEM_CONSTANT (ABDAY_5); + DEFINE_NLITEM_CONSTANT (ABDAY_6); + DEFINE_NLITEM_CONSTANT (ABDAY_7); + + /* Long-named days of the week. */ + DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */ + DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */ + DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */ + DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */ + DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */ + DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */ + DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */ + + /* Abbreviated month names. */ + DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */ + DEFINE_NLITEM_CONSTANT (ABMON_2); + DEFINE_NLITEM_CONSTANT (ABMON_3); + DEFINE_NLITEM_CONSTANT (ABMON_4); + DEFINE_NLITEM_CONSTANT (ABMON_5); + DEFINE_NLITEM_CONSTANT (ABMON_6); + DEFINE_NLITEM_CONSTANT (ABMON_7); + DEFINE_NLITEM_CONSTANT (ABMON_8); + DEFINE_NLITEM_CONSTANT (ABMON_9); + DEFINE_NLITEM_CONSTANT (ABMON_10); + DEFINE_NLITEM_CONSTANT (ABMON_11); + DEFINE_NLITEM_CONSTANT (ABMON_12); + + /* Long month names. */ + DEFINE_NLITEM_CONSTANT (MON_1); /* January */ + DEFINE_NLITEM_CONSTANT (MON_2); + DEFINE_NLITEM_CONSTANT (MON_3); + DEFINE_NLITEM_CONSTANT (MON_4); + DEFINE_NLITEM_CONSTANT (MON_5); + DEFINE_NLITEM_CONSTANT (MON_6); + DEFINE_NLITEM_CONSTANT (MON_7); + DEFINE_NLITEM_CONSTANT (MON_8); + DEFINE_NLITEM_CONSTANT (MON_9); + DEFINE_NLITEM_CONSTANT (MON_10); + DEFINE_NLITEM_CONSTANT (MON_11); + DEFINE_NLITEM_CONSTANT (MON_12); + + DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */ + DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */ + + DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */ + DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */ + DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */ + DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */ + + DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */ + DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */ + DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era + format. */ + DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */ + + DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */ + DEFINE_NLITEM_CONSTANT (RADIXCHAR); + DEFINE_NLITEM_CONSTANT (THOUSEP); + +#ifdef YESEXPR + DEFINE_NLITEM_CONSTANT (YESEXPR); +#endif +#ifdef NOEXPR + DEFINE_NLITEM_CONSTANT (NOEXPR); +#endif + +#ifdef CRNCYSTR /* currency symbol */ + DEFINE_NLITEM_CONSTANT (CRNCYSTR); +#endif + + /* GNU extensions. */ + +#ifdef ERA_YEAR + DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */ +#endif + + /* LC_MONETARY category: formatting of monetary quantities. + These items each correspond to a member of `struct lconv', + defined in . */ +#ifdef INT_CURR_SYMBOL + DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL); +#endif +#ifdef MON_DECIMAL_POINT + DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT); +#endif +#ifdef MON_THOUSANDS_SEP + DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP); +#endif +#ifdef MON_GROUPING + DEFINE_NLITEM_CONSTANT (MON_GROUPING); +#endif +#ifdef POSITIVE_SIGN + DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN); +#endif +#ifdef NEGATIVE_SIGN + DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN); +#endif +#ifdef GROUPING + DEFINE_NLITEM_CONSTANT (GROUPING); +#endif +#ifdef INT_FRAC_DIGITS + DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS); +#endif +#ifdef FRAC_DIGITS + DEFINE_NLITEM_CONSTANT (FRAC_DIGITS); +#endif +#ifdef P_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES); +#endif +#ifdef P_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE); +#endif +#ifdef N_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES); +#endif +#ifdef N_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE); +#endif +#ifdef P_SIGN_POSN + DEFINE_NLITEM_CONSTANT (P_SIGN_POSN); +#endif +#ifdef N_SIGN_POSN + DEFINE_NLITEM_CONSTANT (N_SIGN_POSN); +#endif +#ifdef INT_P_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES); +#endif +#ifdef INT_P_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE); +#endif +#ifdef INT_N_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES); +#endif +#ifdef INT_N_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE); +#endif +#ifdef INT_P_SIGN_POSN + DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN); +#endif +#ifdef INT_N_SIGN_POSN + DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN); +#endif + +#undef DEFINE_NLITEM_CONSTANT + +#endif /* HAVE_NL_TYPES_H */ +} void scm_init_i18n () { - scm_add_feature ("ice-9-i18n"); + SCM global_locale_smob; -#define _SCM_STRINGIFY_LC(_name) # _name -#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name) - - /* Define all the relevant `_MASK' variables. */ -#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ - scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \ - SCM_I_MAKINUM (LC_ ## _name ## _MASK)); -#include "locale-categories.h" - -#undef SCM_DEFINE_LOCALE_CATEGORY -#undef SCM_STRINGIFY_LC -#undef _SCM_STRINGIFY_LC - - scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK)); +#ifdef HAVE_NL_LANGINFO + scm_add_feature ("nl-langinfo"); + define_langinfo_items (); +#endif #include "libguile/i18n.x" #ifndef USE_GNU_LOCALE_API scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); #endif + + /* Initialize the global locale object with a special `locale' SMOB. */ + SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL); + SCM_VARIABLE_SET (scm_global_locale, global_locale_smob); } diff --git a/libguile/i18n.h b/libguile/i18n.h index 7d5d9baa9..17dc240d8 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -22,6 +22,7 @@ #include "libguile/__scm.h" +SCM_API SCM scm_global_locale; SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale); SCM_API SCM scm_locale_p (SCM obj); SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale); @@ -40,6 +41,7 @@ SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale); SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale); SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale); SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale); +SCM_API SCM scm_nl_langinfo (SCM item, SCM locale); SCM_API void scm_init_i18n (void); diff --git a/libguile/posix.c b/libguile/posix.c index dda20e8e1..81539baf2 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -119,6 +119,10 @@ extern char ** environ; # define USE_GNU_LOCALE_API #endif +#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H) +# include +#endif + #if HAVE_CRYPT_H # include #endif @@ -1399,12 +1403,11 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, } #undef FUNC_NAME -#ifndef USE_GNU_LOCALE_API /* This mutex is used to serialize invocations of `setlocale ()' on non-GNU - systems (i.e., systems where a reentrant locale API is not available). - See `i18n.c' for details. */ -scm_i_pthread_mutex_t scm_i_locale_mutex; -#endif + systems (i.e., systems where a reentrant locale API is not available). It + is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for + details. */ +scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #ifdef HAVE_SETLOCALE @@ -1421,6 +1424,7 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, "the locale will be set using environment variables.") #define FUNC_NAME s_scm_setlocale { + int c_category; char *clocale; char *rv; @@ -1436,13 +1440,11 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, scm_dynwind_free (clocale); } -#ifndef USE_GNU_LOCALE_API + c_category = scm_i_to_lc_category (category, 1); + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); -#endif - rv = setlocale (scm_i_to_lc_category (category, 1), clocale); -#ifndef USE_GNU_LOCALE_API + rv = setlocale (c_category, clocale); scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); -#endif if (rv == NULL) { @@ -1986,10 +1988,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, void scm_init_posix () { -#ifndef USE_GNU_LOCALE_API - scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL); -#endif - scm_add_feature ("posix"); #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e662163fb..40e306902 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,20 @@ +2007-01-31 Ludovic Courtès + + * srfi-19.scm: Use `(ice-9 i18n)'. + (priv:locale-abbr-weekday-vector, priv:locale-long-weekday-vector, + priv:locale-abbr-month-vector, priv:locale-long-month-vector): + Removed. + (priv:locale-number-separator, priv:locale-pm, priv:locale-am, + priv:locale-abbr-weekday, priv:locale-long-weekday, + priv:locale-abbr-month, priv:locale-long-month): Aliases for their + respective `(ice-9 i18n)' equivalent. + (priv:vector-find): Removed, replaced by... + (priv:date-reverse-lookup): New procedure. Updated callers. + (priv:locale-am/pm): Use `priv:locale-pm' and `priv:locale-am' as + procedures. + (priv:directives): Use `priv:locale-number-separator' as a + procedure. + 2006-12-02 Kevin Ryde * srfi-60.c (scm_srfi60_copy_bit): Should be long not int for fixnum @@ -288,7 +305,7 @@ 2004-08-02 Kevin Ryde * srfi-13.c (scm_string_every): Correction to initial "res" value, - return should be #t for an empty string. Reported by Andreas Vgele. + return should be #t for an empty string. Reported by Andreas Vögele. 2004-07-10 Marius Vollmer @@ -511,7 +528,7 @@ * srfi-14.h (SCM_CHARSET_GET): Cast IDX to unsigned char so that it works for 8-bit characters. Thanks to Matthias Koeppe! No, - make that "Kppe". + make that "Köppe". 2002-04-24 Marius Vollmer @@ -564,7 +581,7 @@ 2002-02-22 Neil Jerram * srfi-19.scm (priv:year-day): Index into priv:month-assoc using - month number, not day number. (Thanks to Sbastien de Menten de + month number, not day number. (Thanks to Sébastien de Menten de Horne for reporting the problem.) 2002-02-11 Marius Vollmer @@ -983,7 +1000,7 @@ 2001-05-28 Michael Livshin * srfi-19.scm: removed a stray open parenthesis. (thanks to - Matthias Kppe for the report). + Matthias Köppe for the report). 2001-05-23 Rob Browning @@ -1239,3 +1256,7 @@ * Started guile-srfi-13 package. Files are copied from the guile-gdbm and slightly modified. + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 896dd035f..a8daa26d1 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -41,7 +41,8 @@ (define-module (srfi srfi-19) :use-module (srfi srfi-6) :use-module (srfi srfi-8) - :use-module (srfi srfi-9)) + :use-module (srfi srfi-9) + :use-module (ice-9 i18n)) (begin-deprecated ;; Prevent `export' from re-exporting core bindings. This behaviour @@ -150,48 +151,9 @@ ;;-- LOCALE dependent constants -(define priv:locale-number-separator ".") - -(define priv:locale-abbr-weekday-vector - (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) - -(define priv:locale-long-weekday-vector - (vector - "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) - -;; note empty string in 0th place. -(define priv:locale-abbr-month-vector - (vector "" - "Jan" - "Feb" - "Mar" - "Apr" - "May" - "Jun" - "Jul" - "Aug" - "Sep" - "Oct" - "Nov" - "Dec")) - -(define priv:locale-long-month-vector - (vector "" - "January" - "February" - "March" - "April" - "May" - "June" - "July" - "August" - "September" - "October" - "November" - "December")) - -(define priv:locale-pm "PM") -(define priv:locale-am "AM") +(define priv:locale-number-separator locale-decimal-point) +(define priv:locale-pm locale-pm-string) +(define priv:locale-am locale-am-string) ;; See date->string (define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") @@ -964,38 +926,33 @@ (define (priv:last-n-digits i n) (abs (remainder i (expt 10 n)))) -(define (priv:locale-abbr-weekday n) - (vector-ref priv:locale-abbr-weekday-vector n)) +(define priv:locale-abbr-weekday locale-day-short) +(define priv:locale-long-weekday locale-day) +(define priv:locale-abbr-month locale-month-short) +(define priv:locale-long-month locale-month) -(define (priv:locale-long-weekday n) - (vector-ref priv:locale-long-weekday-vector n)) - -(define (priv:locale-abbr-month n) - (vector-ref priv:locale-abbr-month-vector n)) - -(define (priv:locale-long-month n) - (vector-ref priv:locale-long-month-vector n)) - -(define (priv:vector-find needle haystack comparator) - (let ((len (vector-length haystack))) - (define (priv:vector-find-int index) - (cond - ((>= index len) #f) - ((comparator needle (vector-ref haystack index)) index) - (else (priv:vector-find-int (+ index 1))))) - (priv:vector-find-int 0))) +(define (priv:date-reverse-lookup needle haystack-ref haystack-len + same?) + ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure + ;; that returns a string corresponding to the given index) by passing it + ;; indices lower than HAYSTACK-LEN. + (let loop ((index 1)) + (cond ((> index haystack-len) #f) + ((same? needle (haystack-ref index)) + index) + (else (loop (+ index 1)))))) (define (priv:locale-abbr-weekday->index string) - (priv:vector-find string priv:locale-abbr-weekday-vector string=?)) + (priv:date-reverse-lookup string priv:locale-abbr-weekday 7 string=?)) (define (priv:locale-long-weekday->index string) - (priv:vector-find string priv:locale-long-weekday-vector string=?)) + (priv:date-reverse-lookup string priv:locale-long-weekday 7 string=?)) (define (priv:locale-abbr-month->index string) - (priv:vector-find string priv:locale-abbr-month-vector string=?)) + (priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?)) (define (priv:locale-long-month->index string) - (priv:vector-find string priv:locale-long-month-vector string=?)) + (priv:date-reverse-lookup string priv:locale-long-month 12 string=?)) ;; FIXME: mkoeppe: Put a symbolic time zone in the date structs. @@ -1003,10 +960,8 @@ (define (priv:locale-print-time-zone date port) (priv:tz-printer (date-zone-offset date) port)) -;; FIXME: we should use strftime to determine this dynamically if possible. -;; Again, locale specific. (define (priv:locale-am/pm hr) - (if (> hr 11) priv:locale-pm priv:locale-am)) + (if (> hr 11) (priv:locale-pm) (priv:locale-am))) (define (priv:tz-printer offset port) (cond @@ -1069,7 +1024,7 @@ (le (string-length ns))) (if (> le 2) (begin - (display priv:locale-number-separator port) + (display (priv:locale-number-separator) port) (display (substring ns 2 le) port))))))) (cons #\h (lambda (date pad-with port) (display (date->string date "~b") port))) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 4688477fc..999c0c7d8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,18 @@ +2007-01-31 Ludovic Courtès + + * tests/i18n.test: Use `(srfi srfi-1)'. + (exception:locale-error): New. + (locale objects): Test `make-locale' with both lists of `LC_*' + values and single `LC_*' values (instead of `LC_*_MASK' values). + [%global-locale]: New test. + (number parsing)[locale-string->inexact (French)]: New test. + (%c-locale, %english-days, every?): New top-level variables. + (nl-langinfo et al.): New test prefix. + + * tests/srfi-19.test: Install the C locale. + (SRFI date/time library)[string->date understands days and + months]: New test. + 2007-01-19 Ludovic Courtès * tests/eval.test (values): New test prefix. Values are structs, diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index fca99c768..78d7e54fb 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,6 +1,6 @@ ;;;; i18n.test --- Exercise the i18n API. ;;;; -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;;;; Ludovic Courts ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -19,25 +19,41 @@ (define-module (test-suite i18n) :use-module (ice-9 i18n) + :use-module (srfi srfi-1) :use-module (test-suite lib)) ;; Start from a pristine locale state. (setlocale LC_ALL "C") +(define exception:locale-error + (cons 'system-error "Failed to install locale")) + + (with-test-prefix "locale objects" (pass-if "make-locale (2 args)" - (not (not (make-locale LC_ALL_MASK "C")))) + (not (not (make-locale LC_ALL "C")))) + + (pass-if "make-locale (2 args, list)" + (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C")))) (pass-if "make-locale (3 args)" - (not (not (make-locale LC_COLLATE_MASK "C" - (make-locale LC_MESSAGES_MASK "C"))))) + (not (not (make-locale (list LC_COLLATE) "C" + (make-locale (list LC_MESSAGES) "C"))))) + + (pass-if-exception "make-locale with unknown locale" exception:locale-error + (make-locale LC_ALL "does-not-exist")) (pass-if "locale?" - (and (locale? (make-locale LC_ALL_MASK "C")) - (locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C" - (make-locale LC_CTYPE_MASK "C")))))) + (and (locale? (make-locale (list LC_ALL) "C")) + (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C" + (make-locale (list LC_CTYPE) "C"))))) + + (pass-if "%global-locale" + (and (locale? %global-locale)) + (locale? (make-locale (list LC_MONETARY) "C" + %global-locale)))) @@ -46,27 +62,30 @@ (pass-if "string-localeinexact "123.456" - (make-locale LC_NUMERIC_MASK "C"))) + (make-locale (list LC_NUMERIC) "C"))) (lambda (result char-count) (and (equal? result 123.456) - (equal? char-count 7)))))) + (equal? char-count 7))))) + + (pass-if "locale-string->inexact (French)" + (under-french-locale-or-unresolved + (lambda () + (call-with-values + (lambda () + (locale-string->inexact "123,456" %french-locale)) + (lambda (result char-count) + (and (equal? result 123.456) + (equal? char-count 7)))))))) + + +;;; +;;; `nl-langinfo' +;;; + +(setlocale LC_ALL "C") +(define %c-locale (make-locale LC_ALL "C")) + +(define %english-days + '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(define (every? . args) + (not (not (apply every args)))) + + +(with-test-prefix "nl-langinfo et al." + + (pass-if "locale-day (1 arg)" + (every? equal? + %english-days + (map locale-day (map 1+ (iota 7))))) + + (pass-if "locale-day (2 args)" + (every? equal? + %english-days + (map (lambda (day) + (locale-day day %c-locale)) + (map 1+ (iota 7))))) + + (pass-if "locale-day (2 args, using `%global-locale')" + (every? equal? + %english-days + (map (lambda (day) + (locale-day day %global-locale)) + (map 1+ (iota 7))))) + + (pass-if "locale-day (French)" + (under-french-locale-or-unresolved + (lambda () + (let ((result (locale-day 3 %french-locale))) + (and (string? result) + (string-ci=? result "mardi")))))) + + (pass-if "locale-day (French, using `%global-locale')" + ;; Make sure `%global-locale' captures the current locale settings as + ;; installed using `setlocale'. + (under-french-locale-or-unresolved + (lambda () + (dynamic-wind + (lambda () + (setlocale LC_TIME %french-locale-name)) + (lambda () + (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale)) + (result (locale-day 3 fr))) + (setlocale LC_ALL "C") + (and (string? result) + (string-ci=? result "mardi")))) + (lambda () + (setlocale LC_ALL "C")))))) + + (pass-if "default locale" + ;; Make sure the default locale does not capture the current locale + ;; settings as installed using `setlocale'. The default locale should be + ;; "C". + (under-french-locale-or-unresolved + (lambda () + (dynamic-wind + (lambda () + (setlocale LC_ALL %french-locale-name)) + (lambda () + (let* ((locale (make-locale (list LC_MONETARY) "C")) + (result (locale-day 3 locale))) + (setlocale LC_ALL "C") + (and (string? result) + (string-ci=? result "Tuesday")))) + (lambda () + (setlocale LC_ALL "C"))))))) ;;; Local Variables: diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 126198afa..33e667cfc 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -27,6 +27,9 @@ :use-module (srfi srfi-19) :use-module (ice-9 format)) +;; Make sure we use the default locale. +(setlocale LC_ALL "C") + (define (with-tz* tz thunk) "Temporarily set the TZ environment variable to the passed string value and call THUNK." @@ -142,6 +145,19 @@ incomplete numerical tower implementation.)" (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M"))) (date->time-utc (make-date 0 0 0 12 1 6 2001 0)))) + (pass-if "string->date understands days and months" + (time=? (let ((d (string->date "Saturday, December 9, 2006" + "~A, ~B ~d, ~Y"))) + (date->time-utc (make-date (date-nanosecond d) + (date-second d) + (date-minute d) + (date-hour d) + (date-day d) + (date-month d) + (date-year d) + 0))) + (date->time-utc + (make-date 0 0 0 0 9 12 2006 0)))) ;; check time comparison procedures (let* ((time1 (make-time time-monotonic 0 0)) (time2 (make-time time-monotonic 0 0)) From 2656b1b208ab8f2ab96b4e27edb7a9096acc2060 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 4 Feb 2007 21:16:31 +0000 Subject: [PATCH 112/116] Changes from arch/CVS synchronization --- srfi/ChangeLog | 8 ++++++++ srfi/srfi-19.scm | 8 ++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 40e306902..fbc5e5d0f 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,11 @@ +2007-02-04 Ludovic Courtès + + * srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day + number before invoking `locale-day-short'. Failing to do so + resulted in days shifted by one in the result of `date->string', + or in the failure of `date->string' when the day is zero. + (priv:locale-long-weekday): Likewise. + 2007-01-31 Ludovic Courtès * srfi-19.scm: Use `(ice-9 i18n)'. diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index a8daa26d1..1b71a16bd 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -926,10 +926,10 @@ (define (priv:last-n-digits i n) (abs (remainder i (expt 10 n)))) -(define priv:locale-abbr-weekday locale-day-short) -(define priv:locale-long-weekday locale-day) -(define priv:locale-abbr-month locale-month-short) -(define priv:locale-long-month locale-month) +(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n))) +(define (priv:locale-long-weekday n) (locale-day (+ 1 n))) +(define priv:locale-abbr-month locale-month-short) +(define priv:locale-long-month locale-month) (define (priv:date-reverse-lookup needle haystack-ref haystack-len same?) From ed1dec3ce3f00af862efe7a962e6611495fe5baf Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 6 Feb 2007 23:31:03 +0000 Subject: [PATCH 113/116] * gds-scheme.el (gds-display-results): Use save-selected-window instead of switching to other-window in order to return to the proper window in frames with more than two windows. --- emacs/ChangeLog | 6 +++++ emacs/gds-scheme.el | 66 ++++++++++++++++++++++----------------------- 2 files changed, 39 insertions(+), 33 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index fabe42310..5a4365ff5 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,9 @@ +2007-02-06 Clinton Ebadi + + * gds-scheme.el (gds-display-results): Use save-selected-window + instead of switching to other-window in order to return to the + proper window in frames with more than two windows. + 2007-01-17 Neil Jerram * gds-scheme.el (gds-display-results): Add another binding for diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index 29a54a574..a03a07ba5 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -382,39 +382,39 @@ region's code." '(nil . "*Guile Evaluation*")))) (helpp (car helpp+bufname))) (let ((buf (get-buffer-create (cdr helpp+bufname)))) - (save-excursion - (set-buffer buf) - (gds-dissociate-buffer) - (erase-buffer) - (scheme-mode) - (insert (cdr correlator) "\n\n") - (while results - (insert (car results)) - (or (bolp) (insert "\\\n")) - (if helpp - nil - (if (cadr results) - (mapcar (function (lambda (value) - (insert " => " value "\n"))) - (cadr results)) - (insert " => no (or unspecified) value\n")) - (insert "\n")) - (setq results (cddr results))) - (if stack-available - (let ((beg (point)) - (map (make-sparse-keymap))) - (define-key map [mouse-1] 'gds-show-last-stack) - (define-key map "\C-m" 'gds-show-last-stack) - (insert "[click here to show error stack]") - (add-text-properties beg (point) - (list 'keymap map - 'mouse-face 'highlight)) - (insert "\n"))) - (goto-char (point-min)) - (gds-associate-buffer client)) - (pop-to-buffer buf) - (run-hooks 'temp-buffer-show-hook) - (other-window 1)))) + (save-selected-window + (save-excursion + (set-buffer buf) + (gds-dissociate-buffer) + (erase-buffer) + (scheme-mode) + (insert (cdr correlator) "\n\n") + (while results + (insert (car results)) + (or (bolp) (insert "\\\n")) + (if helpp + nil + (if (cadr results) + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert " => no (or unspecified) value\n")) + (insert "\n")) + (setq results (cddr results))) + (if stack-available + (let ((beg (point)) + (map (make-sparse-keymap))) + (define-key map [mouse-1] 'gds-show-last-stack) + (define-key map "\C-m" 'gds-show-last-stack) + (insert "[click here to show error stack]") + (add-text-properties beg (point) + (list 'keymap map + 'mouse-face 'highlight)) + (insert "\n"))) + (goto-char (point-min)) + (gds-associate-buffer client)) + (pop-to-buffer buf) + (run-hooks 'temp-buffer-show-hook))))) (defun gds-show-last-stack () "Show stack of the most recent error." From e6ee0d484f81834bdb291990ddc5b90f94264eee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 9 Feb 2007 16:25:50 +0000 Subject: [PATCH 114/116] Changes from arch/CVS synchronization --- ice-9/ChangeLog | 4 ++++ ice-9/Makefile.am | 25 +++++++++++++------------ 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 9d03408db..0db6fcb84 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2007-02-09 Ludovic Courtès + + * Makefile.am (ice9_sources): Added `i18n.scm'. + 2007-01-31 Ludovic Courtès * i18n.scm: Use `(ice-9 optargs)'. Don't export `LC_*_MASK' diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 0eb1ac8f2..454b117cc 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -24,18 +24,19 @@ AUTOMAKE_OPTIONS = gnu SUBDIRS = debugger debugging # These should be installed and distributed. -ice9_sources = \ - and-let-star.scm boot-9.scm calling.scm common-list.scm \ - debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ - format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \ - match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ - posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm regex.scm runq.scm rw.scm \ - safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ - streams.scm string-fun.scm syncase.scm threads.scm \ - buffered-input.scm time.scm history.scm channel.scm \ - pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \ - weak-vector.scm deprecated.scm list.scm serialize.scm \ +ice9_sources = \ + and-let-star.scm boot-9.scm calling.scm common-list.scm \ + debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ + format.scm getopt-long.scm hcons.scm i18n.scm \ + lineio.scm ls.scm mapping.scm \ + match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ + posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ + rdelim.scm receive.scm regex.scm runq.scm rw.scm \ + safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ + streams.scm string-fun.scm syncase.scm threads.scm \ + buffered-input.scm time.scm history.scm channel.scm \ + pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \ + weak-vector.scm deprecated.scm list.scm serialize.scm \ gds-client.scm gds-server.scm subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9 From 169ccff576c7c7d6e9c4b77deb65241ebaa3ee71 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 18 Feb 2007 23:03:35 +0000 Subject: [PATCH 115/116] (connect-to-gds): Break generation of client name into ... (client-name): New procedure. (client-name): Put something from (program-arguments) in the client name that GDS displays in Emacs. (connect-to-gds, client-name): Add application-name arg to allow caller to specify client name. --- ice-9/ChangeLog | 10 ++++++++++ ice-9/gds-client.scm | 16 ++++++++++++++-- 2 files changed, 24 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0db6fcb84..f3848f1e0 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2007-02-18 Neil Jerram + + * gds-client.scm (connect-to-gds): Break generation of client name + into ... + (client-name): New procedure. + (client-name): Put something from (program-arguments) in the + client name that GDS displays in Emacs. + (connect-to-gds, client-name): Add application-name arg to allow + caller to specify client name. + 2007-02-09 Ludovic Courtès * Makefile.am (ice9_sources): Added `i18n.scm'. diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index 8c7bdc742..7e6e524e5 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -170,7 +170,7 @@ (safely-handle-nondebug-protocol protocol) (loop (gds-debug-read)))))))) -(define (connect-to-gds) +(define (connect-to-gds . application-name) (or gds-port (begin (set! gds-port @@ -190,7 +190,19 @@ s) (lambda _ #f))) (error "Couldn't connect to GDS by TCP or Unix domain socket"))) - (write-form (list 'name (getpid) (format #f "PID ~A" (getpid))))))) + (write-form (list 'name (getpid) (apply client-name application-name)))))) + +(define (client-name . application-name) + (let loop ((args (append application-name (program-arguments)))) + (if (null? args) + (format #f "PID ~A" (getpid)) + (let ((arg (car args))) + (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg) + (loop (cdr args))) + ((string-match "^-" arg) + (loop (cdr args))) + (else + (format #f "~A (PID ~A)" arg (getpid)))))))) (if (not (defined? 'make-mutex)) (begin From 819cd901513efdc4785d49a597072998a6d7e6af Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 18 Feb 2007 23:04:35 +0000 Subject: [PATCH 116/116] * configure.in: Remove AM_GNU_GETTEXT_VERSION again. * Makefile.am (EXTRA_DIST): Add config.rpath. * config.rpath (Module): New (from gettext package). --- ChangeLog | 8 + Makefile.am | 2 +- config.rpath | 614 +++++++++++++++++++++++++++++++++++++++++++++++++++ configure.in | 1 - 4 files changed, 623 insertions(+), 2 deletions(-) create mode 100755 config.rpath diff --git a/ChangeLog b/ChangeLog index 47bc98d40..a17f4ae19 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2007-02-18 Neil Jerram + + * configure.in: Remove AM_GNU_GETTEXT_VERSION again. + + * Makefile.am (EXTRA_DIST): Add config.rpath. + + * config.rpath (Module): New (from gettext package). + 2007-01-31 Ludovic Courtès * configure.in: Look for `langinfo.h', `nl_types.h', `xlocale.h' diff --git a/Makefile.am b/Makefile.am index 98b1c7e4a..7ead71f4b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -33,7 +33,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. -EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS +EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS config.rpath TESTS = check-guile diff --git a/config.rpath b/config.rpath new file mode 100755 index 000000000..c492a93b6 --- /dev/null +++ b/config.rpath @@ -0,0 +1,614 @@ +#! /bin/sh +# Output a system dependent set of variables, describing how to set the +# run time search path of shared libraries in an executable. +# +# Copyright 1996-2006 Free Software Foundation, Inc. +# Taken from GNU libtool, 2001 +# Originally by Gordon Matzigkeit , 1996 +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. +# +# The first argument passed to this file is the canonical host specification, +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld +# should be set by the caller. +# +# The set of defined variables is at the end of this script. + +# Known limitations: +# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer +# than 256 bytes, otherwise the compiler driver will dump core. The only +# known workaround is to choose shorter directory names for the build +# directory and/or the installation directory. + +# All known linkers require a `.a' archive for static linking (except MSVC, +# which needs '.lib'). +libext=a +shrext=.so + +host="$1" +host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + +# Code taken from libtool.m4's _LT_CC_BASENAME. + +for cc_temp in $CC""; do + case $cc_temp in + compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; + distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; + \-*) ;; + *) break;; + esac +done +cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'` + +# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC. + +wl= +if test "$GCC" = yes; then + wl='-Wl,' +else + case "$host_os" in + aix*) + wl='-Wl,' + ;; + darwin*) + case $cc_basename in + xlc*) + wl='-Wl,' + ;; + esac + ;; + mingw* | pw32* | os2*) + ;; + hpux9* | hpux10* | hpux11*) + wl='-Wl,' + ;; + irix5* | irix6* | nonstopux*) + wl='-Wl,' + ;; + newsos6) + ;; + linux*) + case $cc_basename in + icc* | ecc*) + wl='-Wl,' + ;; + pgcc | pgf77 | pgf90) + wl='-Wl,' + ;; + ccc*) + wl='-Wl,' + ;; + como) + wl='-lopt=' + ;; + *) + case `$CC -V 2>&1 | sed 5q` in + *Sun\ C*) + wl='-Wl,' + ;; + esac + ;; + esac + ;; + osf3* | osf4* | osf5*) + wl='-Wl,' + ;; + sco3.2v5*) + ;; + solaris*) + wl='-Wl,' + ;; + sunos4*) + wl='-Qoption ld ' + ;; + sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) + wl='-Wl,' + ;; + sysv4*MP*) + ;; + unicos*) + wl='-Wl,' + ;; + uts4*) + ;; + esac +fi + +# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS. + +hardcode_libdir_flag_spec= +hardcode_libdir_separator= +hardcode_direct=no +hardcode_minus_L=no + +case "$host_os" in + cygwin* | mingw* | pw32*) + # FIXME: the MSVC++ port hasn't been tested in a loooong time + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++. + if test "$GCC" != yes; then + with_gnu_ld=no + fi + ;; + interix*) + # we just hope/assume this is gcc and not c89 (= MSVC++) + with_gnu_ld=yes + ;; + openbsd*) + with_gnu_ld=no + ;; +esac + +ld_shlibs=yes +if test "$with_gnu_ld" = yes; then + # Set some defaults for GNU ld with shared library support. These + # are reset later if shared libraries are not supported. Putting them + # here allows them to be overridden if necessary. + # Unlike libtool, we use -rpath here, not --rpath, since the documented + # option of GNU ld is called -rpath, not --rpath. + hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' + case "$host_os" in + aix3* | aix4* | aix5*) + # On AIX/PPC, the GNU linker is very broken + if test "$host_cpu" != ia64; then + ld_shlibs=no + fi + ;; + amigaos*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + # Samuel A. Falvo II reports + # that the semantics of dynamic libraries on AmigaOS, at least up + # to version 4, is to share data among multiple programs linked + # with the same dynamic library. Since this doesn't match the + # behavior of shared libraries on other platforms, we cannot use + # them. + ld_shlibs=no + ;; + beos*) + if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then + : + else + ld_shlibs=no + fi + ;; + cygwin* | mingw* | pw32*) + # hardcode_libdir_flag_spec is actually meaningless, as there is + # no search path for DLLs. + hardcode_libdir_flag_spec='-L$libdir' + if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then + : + else + ld_shlibs=no + fi + ;; + interix3*) + hardcode_direct=no + hardcode_libdir_flag_spec='${wl}-rpath,$libdir' + ;; + linux*) + if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then + : + else + ld_shlibs=no + fi + ;; + netbsd*) + ;; + solaris*) + if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then + ld_shlibs=no + elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then + : + else + ld_shlibs=no + fi + ;; + sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) + case `$LD -v 2>&1` in + *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*) + ld_shlibs=no + ;; + *) + if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then + hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`' + else + ld_shlibs=no + fi + ;; + esac + ;; + sunos4*) + hardcode_direct=yes + ;; + *) + if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then + : + else + ld_shlibs=no + fi + ;; + esac + if test "$ld_shlibs" = no; then + hardcode_libdir_flag_spec= + fi +else + case "$host_os" in + aix3*) + # Note: this linker hardcodes the directories in LIBPATH if there + # are no directories specified by -L. + hardcode_minus_L=yes + if test "$GCC" = yes; then + # Neither direct hardcoding nor static linking is supported with a + # broken collect2. + hardcode_direct=unsupported + fi + ;; + aix4* | aix5*) + if test "$host_cpu" = ia64; then + # On IA64, the linker does run time linking by default, so we don't + # have to do anything special. + aix_use_runtimelinking=no + else + aix_use_runtimelinking=no + # Test if we are trying to use run time linking or normal + # AIX style linking. If -brtl is somewhere in LDFLAGS, we + # need to do runtime linking. + case $host_os in aix4.[23]|aix4.[23].*|aix5*) + for ld_flag in $LDFLAGS; do + if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then + aix_use_runtimelinking=yes + break + fi + done + ;; + esac + fi + hardcode_direct=yes + hardcode_libdir_separator=':' + if test "$GCC" = yes; then + case $host_os in aix4.[012]|aix4.[012].*) + collect2name=`${CC} -print-prog-name=collect2` + if test -f "$collect2name" && \ + strings "$collect2name" | grep resolve_lib_name >/dev/null + then + # We have reworked collect2 + hardcode_direct=yes + else + # We have old collect2 + hardcode_direct=unsupported + hardcode_minus_L=yes + hardcode_libdir_flag_spec='-L$libdir' + hardcode_libdir_separator= + fi + ;; + esac + fi + # Begin _LT_AC_SYS_LIBPATH_AIX. + echo 'int main () { return 0; }' > conftest.c + ${CC} ${LDFLAGS} conftest.c -o conftest + aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; } +}'` + if test -z "$aix_libpath"; then + aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; } +}'` + fi + if test -z "$aix_libpath"; then + aix_libpath="/usr/lib:/lib" + fi + rm -f conftest.c conftest + # End _LT_AC_SYS_LIBPATH_AIX. + if test "$aix_use_runtimelinking" = yes; then + hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath" + else + if test "$host_cpu" = ia64; then + hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib' + else + hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath" + fi + fi + ;; + amigaos*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + # see comment about different semantics on the GNU ld section + ld_shlibs=no + ;; + bsdi[45]*) + ;; + cygwin* | mingw* | pw32*) + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++. + # hardcode_libdir_flag_spec is actually meaningless, as there is + # no search path for DLLs. + hardcode_libdir_flag_spec=' ' + libext=lib + ;; + darwin* | rhapsody*) + hardcode_direct=no + if test "$GCC" = yes ; then + : + else + case $cc_basename in + xlc*) + ;; + *) + ld_shlibs=no + ;; + esac + fi + ;; + dgux*) + hardcode_libdir_flag_spec='-L$libdir' + ;; + freebsd1*) + ld_shlibs=no + ;; + freebsd2.2*) + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + ;; + freebsd2*) + hardcode_direct=yes + hardcode_minus_L=yes + ;; + freebsd* | kfreebsd*-gnu | dragonfly*) + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + ;; + hpux9*) + hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' + hardcode_libdir_separator=: + hardcode_direct=yes + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + ;; + hpux10*) + if test "$with_gnu_ld" = no; then + hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' + hardcode_libdir_separator=: + hardcode_direct=yes + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + fi + ;; + hpux11*) + if test "$with_gnu_ld" = no; then + hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' + hardcode_libdir_separator=: + case $host_cpu in + hppa*64*|ia64*) + hardcode_direct=no + ;; + *) + hardcode_direct=yes + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + ;; + esac + fi + ;; + irix5* | irix6* | nonstopux*) + hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' + hardcode_libdir_separator=: + ;; + netbsd*) + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + ;; + newsos6) + hardcode_direct=yes + hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' + hardcode_libdir_separator=: + ;; + openbsd*) + hardcode_direct=yes + if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then + hardcode_libdir_flag_spec='${wl}-rpath,$libdir' + else + case "$host_os" in + openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*) + hardcode_libdir_flag_spec='-R$libdir' + ;; + *) + hardcode_libdir_flag_spec='${wl}-rpath,$libdir' + ;; + esac + fi + ;; + os2*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + ;; + osf3*) + hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' + hardcode_libdir_separator=: + ;; + osf4* | osf5*) + if test "$GCC" = yes; then + hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' + else + # Both cc and cxx compiler support -rpath directly + hardcode_libdir_flag_spec='-rpath $libdir' + fi + hardcode_libdir_separator=: + ;; + solaris*) + hardcode_libdir_flag_spec='-R$libdir' + ;; + sunos4*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_direct=yes + hardcode_minus_L=yes + ;; + sysv4) + case $host_vendor in + sni) + hardcode_direct=yes # is this really true??? + ;; + siemens) + hardcode_direct=no + ;; + motorola) + hardcode_direct=no #Motorola manual says yes, but my tests say they lie + ;; + esac + ;; + sysv4.3*) + ;; + sysv4*MP*) + if test -d /usr/nec; then + ld_shlibs=yes + fi + ;; + sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7*) + ;; + sysv5* | sco3.2v5* | sco5v6*) + hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`' + hardcode_libdir_separator=':' + ;; + uts4*) + hardcode_libdir_flag_spec='-L$libdir' + ;; + *) + ld_shlibs=no + ;; + esac +fi + +# Check dynamic linker characteristics +# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER. +libname_spec='lib$name' +case "$host_os" in + aix3*) + ;; + aix4* | aix5*) + ;; + amigaos*) + ;; + beos*) + ;; + bsdi[45]*) + ;; + cygwin* | mingw* | pw32*) + shrext=.dll + ;; + darwin* | rhapsody*) + shrext=.dylib + ;; + dgux*) + ;; + freebsd1*) + ;; + kfreebsd*-gnu) + ;; + freebsd* | dragonfly*) + ;; + gnu*) + ;; + hpux9* | hpux10* | hpux11*) + case $host_cpu in + ia64*) + shrext=.so + ;; + hppa*64*) + shrext=.sl + ;; + *) + shrext=.sl + ;; + esac + ;; + interix3*) + ;; + irix5* | irix6* | nonstopux*) + case "$host_os" in + irix5* | nonstopux*) + libsuff= shlibsuff= + ;; + *) + case $LD in + *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;; + *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;; + *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;; + *) libsuff= shlibsuff= ;; + esac + ;; + esac + ;; + linux*oldld* | linux*aout* | linux*coff*) + ;; + linux*) + ;; + knetbsd*-gnu) + ;; + netbsd*) + ;; + newsos6) + ;; + nto-qnx*) + ;; + openbsd*) + ;; + os2*) + libname_spec='$name' + shrext=.dll + ;; + osf3* | osf4* | osf5*) + ;; + solaris*) + ;; + sunos4*) + ;; + sysv4 | sysv4.3*) + ;; + sysv4*MP*) + ;; + sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + ;; + uts4*) + ;; +esac + +sed_quote_subst='s/\(["`$\\]\)/\\\1/g' +escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"` +shlibext=`echo "$shrext" | sed -e 's,^\.,,'` +escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"` + +LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <