From 6ebb9835740d934b3ab22d66a05e85e56beb8260 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Jul 2001 22:10:29 +0000 Subject: [PATCH 01/39] (SUBDIRS): Build libguile before ice-9. --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index c352d4bd1..a4824d826 100644 --- a/Makefile.am +++ b/Makefile.am @@ -20,7 +20,7 @@ ## 330, Boston, MA 02111-1307 USA -SUBDIRS = ice-9 oop qt libltdl libguile guile-config guile-readline \ +SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ scripts srfi doc examples bin_SCRIPTS = guile-tools From 11057044d87b5700ad4e2273bce0577dc3364e51 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Jul 2001 22:10:42 +0000 Subject: [PATCH 02/39] *** empty log message *** --- ChangeLog | 4 ++++ ice-9/ChangeLog | 13 +++++++++++++ 2 files changed, 17 insertions(+) diff --git a/ChangeLog b/ChangeLog index 2aadabd3c..1bd7fc4e2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-23 Marius Vollmer + + * Makefile.am (SUBDIRS): Build libguile before ice-9. + 2001-07-22 Marius Vollmer * configure.in: Check for "inttypes.h". diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b3b7233a9..449f5327f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,16 @@ +2001-07-24 Marius Vollmer + + * syncase.scm (psyncomp): Removed, it is now in + compile-psyntax.scm. + +2001-07-23 Marius Vollmer + + * Makefile.am (psyntax.pp): Enable rule for psyntax.pp only in + maintainer mode. Use compile-psyntax.scm for actual compilation. + Make sure the uninstalled guile is used. + (EXTRA_DIST): Distribute compile-psyntax.scm + * compile-psyntax.scm: New file. + 2001-07-18 Martin Grabmueller * and-let-star.scm, debug.scm, debugger.scm, history.scm, From e5aca4b5c428232510ea207b895e894e0295401b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:22:53 +0000 Subject: [PATCH 03/39] * tags.h (scm_tc7_variable): New. * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. * print.c (scm_iprin1): Likewise. --- libguile/gc.c | 3 +++ libguile/print.c | 3 +++ libguile/tags.h | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index 65316bbb2..43d532dff 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1431,6 +1431,9 @@ gc_mark_loop_first_time: case scm_tc7_symbol: ptr = SCM_PROP_SLOTS (ptr); goto_gc_mark_loop; + case scm_tc7_variable: + ptr = SCM_CELL_OBJECT_1 (ptr); + goto_gc_mark_loop; case scm_tcs_subrs: break; case scm_tc7_port: diff --git a/libguile/print.c b/libguile/print.c index 25d854fad..3873da422 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -545,6 +545,9 @@ taloop: port); scm_remember_upto_here_1 (exp); break; + case scm_tc7_variable: + scm_i_variable_print (exp, port, pstate); + break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) diff --git a/libguile/tags.h b/libguile/tags.h index 9b877b7ec..b40fbc754 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -333,7 +333,7 @@ typedef signed long scm_t_signed_bits; #define scm_tc7_symbol 5 -/* free 7 */ +#define scm_tc7_variable 7 /* couple */ #define scm_tc7_vector 13 From dbf5dfb3c1e937b12261a32c47ee3f14ee7e3325 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:28:07 +0000 Subject: [PATCH 04/39] * variable.h (scm_tc16_variable): Removed. (SCM_VARIABLEP): Test for new tc7 code. (scm_i_variable_print): New. * variable.c (scm_tc16_variable): Removed. (variable_print): Renamed to scm_i_variable_print and made non-static. (variable_equal_p): Removed. (make_variable): Construct a tc7 object instead of a smob. (scm_init_variable): Do not register smob. --- libguile/variable.c | 35 +++++++++++++++++++---------------- libguile/variable.h | 6 +++--- 2 files changed, 22 insertions(+), 19 deletions(-) diff --git a/libguile/variable.c b/libguile/variable.c index 4037e51be..9f542eda0 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -52,24 +52,17 @@ #include "libguile/validate.h" #include "libguile/variable.h" -scm_t_bits scm_tc16_variable; -static int -variable_print (SCM exp, SCM port, scm_print_state *pstate) +void +scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); - return 1; } -static SCM -variable_equalp (SCM var1, SCM var2) -{ - return scm_equal_p (SCM_VARIABLE_REF (var1), SCM_VARIABLE_REF (var2)); -} #if SCM_ENABLE_VCELLS @@ -80,9 +73,24 @@ static SCM make_variable (SCM init) { #if !SCM_ENABLE_VCELLS - SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (init)); + { + SCM z; + SCM_NEWCELL (z); + SCM_SET_CELL_WORD_1 (z, SCM_UNPACK (init)); + SCM_SET_CELL_TYPE (z, scm_tc7_variable); + scm_remember_upto_here_1 (init); + return z; + } #else - SCM_RETURN_NEWSMOB (scm_tc16_variable, scm_cons (sym_huh, init)); + { + SCM z; + SCM cell = scm_cons (sym_huh, init); + SCM_NEWCELL (z); + SCM_SET_CELL_WORD_1 (z, SCM_UNPACK (cell)); + SCM_SET_CELL_TYPE (z, scm_tc7_variable); + scm_remember_upto_here_1 (cell); + return z; + } #endif } @@ -192,11 +200,6 @@ SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, void scm_init_variable () { - scm_tc16_variable = scm_make_smob_type ("variable", 0); - scm_set_smob_mark (scm_tc16_variable, scm_markcdr); - scm_set_smob_print (scm_tc16_variable, variable_print); - scm_set_smob_equalp (scm_tc16_variable, variable_equalp); - #ifndef SCM_MAGIC_SNARFER #include "libguile/variable.x" #endif diff --git a/libguile/variable.h b/libguile/variable.h index 014fc821f..577f1f820 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -52,9 +52,7 @@ /* Variables */ -extern scm_t_bits scm_tc16_variable; - -#define SCM_VARIABLEP(X) SCM_SMOB_PREDICATE (scm_tc16_variable, X) +#define SCM_VARIABLEP(X) (SCM_NIMP(X) && SCM_TYP7(X) == scm_tc7_variable) #if !SCM_ENABLE_VCELLS #define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1(V) @@ -83,6 +81,8 @@ extern SCM scm_variable_set_name_hint (SCM var, SCM hint); extern SCM scm_builtin_variable (SCM name); #endif +extern void scm_i_variable_print (SCM var, SCM port, scm_print_state *pstate); + extern void scm_init_variable (void); #endif /* SCM_VARIABLE_H */ From ee0c7345a98b45f7454a323271fe429ab1162d04 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:32:20 +0000 Subject: [PATCH 05/39] *** empty log message *** --- NEWS | 8 ++++++++ libguile/ChangeLog | 16 ++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/NEWS b/NEWS index 01d04af58..cd1fb1d6a 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,14 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes since the stable branch: + +** Variables have no longer a special behavior for `equal?'. + +Previously, comparing two variables with `equal?' would recursivly +compare their values. This is no longer done. Variables are now only +`equal?' if they are `eq?'. + Changes since Guile 1.4: * Changes to the distribution diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0d72dc1b3..6212314b0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2001-07-25 Marius Vollmer + + * tags.h (scm_tc7_variable): New. + * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. + * print.c (scm_iprin1): Likewise. + + * variable.h (scm_tc16_variable): Removed. + (SCM_VARIABLEP): Test for new tc7 code. + (scm_i_variable_print): New. + * variable.c (scm_tc16_variable): Removed. + (variable_print): Renamed to scm_i_variable_print and made + non-static. + (variable_equal_p): Removed. + (make_variable): Construct a tc7 object instead of a smob. + (scm_init_variable): Do not register smob. + 2001-07-22 Marius Vollmer * tags.h: Include inttypes.h when we have it. From 2b1d120cd73bd32a9976c60daffa8d1a75d4f3bb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:32:30 +0000 Subject: [PATCH 06/39] * variable.c (scm_i_variable_print): Use "value" instead of "binding" since a binding is the mapping between symbols and variables, not between variables and their values. --- libguile/variable.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/variable.c b/libguile/variable.c index 9f542eda0..7ced1e9dd 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -58,7 +58,7 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); } From 6d9ad98a173fe43900cbf3bbf521959b1d1dc7c1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 15:33:03 +0000 Subject: [PATCH 07/39] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6212314b0..609e5c02c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,9 @@ 2001-07-25 Marius Vollmer + * variable.c (scm_i_variable_print): Use "value" instead of + "binding" since a binding is the mapping between symbols and + variables, not between variables and their values. + * tags.h (scm_tc7_variable): New. * gc.c (scm_gc_mark): Handle scm_tc7_variable objects. * print.c (scm_iprin1): Likewise. From d22a0ea164401885c0567c1621b83af10739da12 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 21:03:28 +0000 Subject: [PATCH 08/39] Allow variables in memoized code (in addition to glocs). (scm_lookupcar): Handle variables in lost races. Replace symbol with variable directly, do not make a gloc. (scm_unmemocar): Rewrite variables using a reverse lookup, just like glocs. (scm_ceval, scm_deval): Deal with variables in SCM_IM_SET and in the main switch. --- libguile/eval.c | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index ef80bfbf7..a4904d071 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -372,6 +372,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) var = SCM_CAR (vloc); if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) return SCM_GLOC_VAL_LOC (var); + if (SCM_VARIABLEP (var)) + return SCM_VARIABLE_LOC (var); #ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); @@ -385,7 +387,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) } #endif /* USE_THREADS */ - SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc); + SCM_SETCAR (vloc, real_var); return SCM_VARIABLE_LOC (real_var); } } @@ -421,6 +423,14 @@ scm_unmemocar (SCM form, SCM env) sym = sym_three_question_marks; SCM_SETCAR (form, sym); } + else if (SCM_VARIABLEP (c)) + { + SCM sym = + scm_module_reverse_lookup (scm_env_module (env), c); + if (SCM_EQ_P (sym, SCM_BOOL_F)) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -2193,7 +2203,10 @@ dispatch: switch (SCM_ITAG3 (proc)) { case scm_tc3_cons: - t.lloc = scm_lookupcar (x, env, 1); + if (SCM_VARIABLEP (proc)) + t.lloc = SCM_VARIABLE_LOC (proc); + else + t.lloc = scm_lookupcar (x, env, 1); break; case scm_tc3_cons_gloc: t.lloc = SCM_GLOC_VAL_LOC (proc); @@ -2546,6 +2559,9 @@ dispatch: case scm_tcs_subrs: RETURN (x); + case scm_tc7_variable: + return SCM_VARIABLE_REF(x); + #ifdef MEMOIZE_LOCALS case SCM_BIT8(SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); @@ -2558,7 +2574,7 @@ dispatch: break; #endif /* ifdef MEMOIZE_LOCALS */ - + case scm_tcs_cons_gloc: { scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; if (vcell == 0) { From f5fe6c2f7e084e2cc756573fe782d5f9ee826175 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 21:03:59 +0000 Subject: [PATCH 09/39] *** empty log message *** --- libguile/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 609e5c02c..e0e8d88b7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-07-25 Marius Vollmer + + * eval.c: Allow variables in memoized code (in addition to glocs). + (scm_lookupcar): Handle variables in lost races. Replace symbol + with variable directly, do not make a gloc. + (scm_unmemocar): Rewrite variables using a reverse lookup, just + like glocs. + (scm_ceval, scm_deval): Deal with variables in SCM_IM_SET and in + the main switch. + 2001-07-25 Marius Vollmer * variable.c (scm_i_variable_print): Use "value" instead of From a130e9829bce7819b9f235fe2e56d303a6839eeb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 22:01:27 +0000 Subject: [PATCH 10/39] (scm_ceval, scm_deval): Use "RETURN" macro when returning value of a variable, not the plain "return" statement. --- libguile/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index a4904d071..1978b2632 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2560,7 +2560,7 @@ dispatch: RETURN (x); case scm_tc7_variable: - return SCM_VARIABLE_REF(x); + RETURN (SCM_VARIABLE_REF(x)); #ifdef MEMOIZE_LOCALS case SCM_BIT8(SCM_ILOC00): From dd29a16921104f94170b34b03d9099b7b879e790 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Jul 2001 22:01:50 +0000 Subject: [PATCH 11/39] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e0e8d88b7..91bd46a71 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-26 Marius Vollmer + + * eval.c (scm_ceval, scm_deval): Use "RETURN" macro when returning + value of a variable, not the plain "return" statement. + 2001-07-25 Marius Vollmer * eval.c: Allow variables in memoized code (in addition to glocs). From 3c3db1289a7f2578c1505c5385d3052649d8f42f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Wed, 25 Jul 2001 22:37:05 +0000 Subject: [PATCH 12/39] * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the docstrings to reflect the n-ary implementation. --- libguile/ChangeLog | 5 +++++ libguile/numbers.c | 38 ++++++++++++++++++-------------------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91bd46a71..369d1c4e7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-25 Gary Houston + + * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the + docstrings to reflect the n-ary implementation. + 2001-07-26 Marius Vollmer * eval.c (scm_ceval, scm_deval): Use "RETURN" macro when returning diff --git a/libguile/numbers.c b/libguile/numbers.c index 9b5c6a61f..0fc136cce 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -738,16 +738,14 @@ SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) #endif - SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise AND of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logand #b1100 #b1010) 2)\n" - " @result{} \"1000\"\n" - "@end lisp") + "Return the bitwise AND of the integer arguments.\n\n" + "@lisp\n" + "(logand) @result{} -1\n" + "(logand 7) @result{} 7\n" + "(logand #b111 #b011 #\b001) @result{} 1\n" + "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; @@ -828,12 +826,11 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise OR of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logior #b1100 #b1010) 2)\n" - " @result{} \"1110\"\n" + "Return the bitwise OR of the integer arguments.\n\n" + "@lisp\n" + "(logior) @result{} 0\n" + "(logior 7) @result{} 7\n" + "(logior #b000 #b001 #b011) @result{} 3\n" "@end lisp") #define FUNC_NAME s_scm_logior { @@ -914,12 +911,13 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, (SCM n1, SCM n2), - "Return the integer which is the bit-wise XOR of the two integer\n" - "arguments.\n" - "\n" - "@lisp\n" - "(number->string (logxor #b1100 #b1010) 2)\n" - " @result{} \"110\"\n" + "Return the bitwise XOR of the integer arguments. A bit is\n" + "set in the result if it is set in an odd number of arguments.\n" + "@lisp\n" + "(logxor) @result{} 0\n" + "(logxor 7) @result{} 7\n" + "(logxor #b000 #b001 #b011) @result{} 2\n" + "(logxor #b000 #b001 #b011 #b011) @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_logxor { From 67b7dd9ea9aad459d77785766da3a8e3607ce2ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Thu, 26 Jul 2001 05:31:57 +0000 Subject: [PATCH 13/39] Minor typo fix in NEWS. Examples are now built and tested on `make installcheck'. --- NEWS | 2 +- examples/ChangeLog | 61 +++++++++++++++++++++++++ examples/box-dynamic-module/Makefile.am | 15 ++++-- examples/box-dynamic/Makefile.am | 15 ++++-- examples/box-module/Makefile.am | 13 ++++-- examples/box/Makefile.am | 13 ++++-- examples/modules/Makefile.am | 5 +- examples/safe/Makefile.am | 5 +- examples/scripts/Makefile.am | 11 +++-- 9 files changed, 115 insertions(+), 25 deletions(-) diff --git a/NEWS b/NEWS index cd1fb1d6a..ea966c86d 100644 --- a/NEWS +++ b/NEWS @@ -55,7 +55,7 @@ same name. For safety reasons, #. evaluation is disabled by default. To re-enable it, set the fluid read-eval? to #t. For example: - (fluid-set read-eval? #t) + (fluid-set! read-eval? #t) but make sure you realize the potential security risks involved. With read-eval? enabled, reading a data file from an untrusted source can diff --git a/examples/ChangeLog b/examples/ChangeLog index d7a556d59..f70742449 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,64 @@ +2001-07-24 Martin Grabmueller + + All examples are now built and tested on `make installcheck' + rather than `make check'. + +2001-07-19 Martin Grabmueller + + * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am, + box-module/Makefile.am, box/Makefile.am: Use $(top_srcdir) to get + at GUILE_LOAD_PATH, and $(top_builddir) for the guile and + guile-config programs and for the link paths. Add check.test to + EXTRA_DIST. + + * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am, + box-module/Makefile.am, box/Makefile.am: Add -L../../qt to LIBS. + +2001-07-19 Rob Browning + + * box-module/.cvsignore: add .deps + + * box/.cvsignore: add .deps. + +2001-07-17 Martin Grabmueller + + * box-module/Makefile.am (TESTS): New variable. + Create `box' on `make all'. + + * box-module/check.test, box-dynamic-module/check.test, + * box-dynamic/check.test: New files. + + * box-dynamic/Makefile.am (libbox): Create box library on `make + all'. + (TESTS): New variable. + + * box/Makefile.am (TESTS): New variable. + Create `box' program on `make all', use freshly built Guile for + building. + + * box/check.test: New file. + + * modules/check.test, safe/check.test, scripts/check.test: Set + GUILE_LOAD_PATH to make the tests run without installed Guile. + +2001-07-16 Thien-Thi Nguyen + + * scripts/check.test: Add check for guile interpreter. + Fix bug: Use `$guile' everywhere. Thanks to Martin Grabmueller. + +2001-07-16 Martin Grabmueller + + * modules/check.test, safe/check.test: New files. + + * modules/Makefile.am (TESTS), safe/Makefile.am (TESTS): New + variables. + +2001-07-14 Thien-Thi Nguyen + + * scripts/check.test: New file. + + * Makefile.am (TESTS): New var. + 2001-07-14 Martin Grabmueller * modules/main: Use :renamer for specifying renaming procedure. diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am index 4d7df0210..665a7de54 100644 --- a/examples/box-dynamic-module/Makefile.am +++ b/examples/box-dynamic-module/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c box-module.scm box-mixed.scm +EXTRA_DIST = README box.c box-module.scm box-mixed.scm check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` libbox-module: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox-module.la + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox-module.la box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< + +installcheck: libbox-module + LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test + +CLEANFILES=libbox-module.la box.lo box.o diff --git a/examples/box-dynamic/Makefile.am b/examples/box-dynamic/Makefile.am index 7bb9f46c2..574eadb85 100644 --- a/examples/box-dynamic/Makefile.am +++ b/examples/box-dynamic/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` libbox: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(prefix)/lib -o libbox.la + sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox.la box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< \ No newline at end of file + sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< + +installcheck: libbox + LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test + +CLEANFILES=libbox.la box.lo box.o diff --git a/examples/box-module/Makefile.am b/examples/box-module/Makefile.am index 3e1f92032..3fe82e7cd 100644 --- a/examples/box-module/Makefile.am +++ b/examples/box-module/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` box: box.o $(CC) $< $(LIBS) -o box box.o: box.c - $(CC) $(CFLAGS) -c $< \ No newline at end of file + $(CC) $(CFLAGS) -c $< + +installcheck: box + LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test + +CLEANFILES=box box.o diff --git a/examples/box/Makefile.am b/examples/box/Makefile.am index 3e1f92032..3fe82e7cd 100644 --- a/examples/box/Makefile.am +++ b/examples/box/Makefile.am @@ -19,13 +19,18 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README box.c +EXTRA_DIST = README box.c check.test -CFLAGS=`guile-config compile` -LIBS=`guile-config link` +CFLAGS=`$(bindir)/guile-config compile` +LIBS=`$(bindir)/guile-config link` box: box.o $(CC) $< $(LIBS) -o box box.o: box.c - $(CC) $(CFLAGS) -c $< \ No newline at end of file + $(CC) $(CFLAGS) -c $< + +installcheck: box + LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test + +CLEANFILES=box box.o diff --git a/examples/modules/Makefile.am b/examples/modules/Makefile.am index 35988c545..a6a9e0e03 100644 --- a/examples/modules/Makefile.am +++ b/examples/modules/Makefile.am @@ -19,4 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main +EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test diff --git a/examples/safe/Makefile.am b/examples/safe/Makefile.am index cf41df73f..16c2f1687 100644 --- a/examples/safe/Makefile.am +++ b/examples/safe/Makefile.am @@ -19,4 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README safe untrusted.scm evil.scm +EXTRA_DIST = README safe untrusted.scm evil.scm check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test diff --git a/examples/scripts/Makefile.am b/examples/scripts/Makefile.am index ff6173086..3a82dad77 100644 --- a/examples/scripts/Makefile.am +++ b/examples/scripts/Makefile.am @@ -3,20 +3,23 @@ ## Copyright (C) 2001 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., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -EXTRA_DIST = README simple-hello.scm hello fact +EXTRA_DIST = README simple-hello.scm hello fact check.test + +installcheck: + srcdir=$(srcdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test From d315ea8ccc5aff59189f3133b517a92a97e5a9c3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 16:58:30 +0000 Subject: [PATCH 14/39] (GC_noop1): Moved into the same #if/#endif context where it is needed. --- libguile/gc_os_dep.c | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 2d5a19491..cc5af6837 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -62,20 +62,6 @@ typedef int GC_bool; # define VOLATILE #endif -#if 0 /* currently unused (as of 2001-07-12) */ - -/* Single argument version, robust against whole program analysis. */ -static void -GC_noop1(x) -word x; -{ - static VOLATILE word sink; - - sink = x; -} - -#endif - /* Machine dependent parameters. Some tuning parameters can be found */ /* near the top of gc_private.h. */ @@ -1773,6 +1759,16 @@ void *scm_get_stack_base() } return(result); } + + /* Single argument version, robust against whole program analysis. */ + static void + GC_noop1(x) + word x; + { + static VOLATILE word sink; + sink = x; + } + # endif #ifdef LINUX_STACKBOTTOM From 5b54c4daa124b0d9f9b984f0bf1733ac5ebba4d3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 16:58:55 +0000 Subject: [PATCH 15/39] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 369d1c4e7..38f7d3b1e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2001-07-26 Marius Vollmer + + * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context + where it is needed. + 2001-07-25 Gary Houston * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the From 904a077df1a670d386ca114ddb7a8e371684f655 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 21:40:18 +0000 Subject: [PATCH 16/39] * tags.h: Update tag system docs. (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP or SCM_NCONSP, respectively. * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c, objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above. * print.c (scm_iprin1): Remove printing of glocs. Do not try to tell glocs from structs. * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. * eval.c (scm_m_atbind): Make a list of variables, not glocs. (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables instead of with glocs. (EVALCAR): Do not test for glocs. (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race condition. (scm_unmemocar): Do not handle glocs. (scm_m_atfop): Memoize as a variable, not as a gloc. (scm_eval_args, scm_deval_args): Do not handle glocs. (scm_ceval, scm_deval): Likewise. * eval.h (SCM_XEVALCAR): Do not test for glocs. (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): Removed. * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed. * dynwind.c (scm_swap_bindings): Likewise. (scm_dowinds): Updated to recognize lists of variables instead of lists of glocs. * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments. --- libguile/__scm.h | 11 +-- libguile/debug.c | 41 +---------- libguile/debug.h | 2 - libguile/dynwind.c | 32 ++++---- libguile/eval.c | 176 ++++++++++---------------------------------- libguile/eval.h | 14 +--- libguile/gc.c | 110 ++++++++++----------------- libguile/goops.c | 4 +- libguile/modules.c | 2 +- libguile/objects.c | 5 +- libguile/print.c | 64 +++++++--------- libguile/procprop.c | 2 +- libguile/procs.c | 2 +- libguile/srcprop.c | 2 +- libguile/struct.c | 9 ++- libguile/struct.h | 7 +- libguile/tags.h | 109 ++++++++++++++------------- 17 files changed, 201 insertions(+), 391 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index fd67075af..2e1e3b611 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -100,11 +100,12 @@ /* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of * arguments is always checked for application of closures. If the * compile FLAG `SCM_RECKLESS' is #defined then they are not checked. - * Otherwise, number of argument checks for closures are made only when - * the function position (whose value is the closure) of a combination is - * not an ILOC or GLOC. When the function position of a combination is a - * symbol it will be checked only the first time it is evaluated because - * it will then be replaced with an ILOC or GLOC. + * Otherwise, number of argument checks for closures are made only + * when the function position (whose value is the closure) of a + * combination is not an ILOC or a variable (true?). When the + * function position of a combination is a symbol it will be checked + * only the first time it is evaluated because it will then be + * replaced with an ILOC or variable. */ #undef SCM_RECKLESS #define SCM_CAUTIOUS diff --git a/libguile/debug.c b/libguile/debug.c index 49cce42c7..d4a97e260 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -196,17 +196,6 @@ scm_make_memoized (SCM exp, SCM env) * specified, the top-level environment of the current module will * be assumed. All environments must match. * - * - procedure: make-gloc VARIABLE [ENV] - * - * Return a gloc, encapsulated in a memoized object. - * - * (Glocs can't exist in normal list structures, since they will - * be mistaken for structs.) - * - * - procedure: gloc? OBJECT - * - * Return #t if OBJECT is a memoized gloc. - * * - procedure: make-iloc FRAME BINDING CDRP * * Return an iloc referring to frame no. FRAME, binding @@ -252,32 +241,6 @@ scm_make_memoized (SCM exp, SCM env) #include "libguile/variable.h" #include "libguile/procs.h" -SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0, - (SCM var, SCM env), - "Create a gloc for variable @var{var} in the environment\n" - "@var{env}.") -#define FUNC_NAME s_scm_make_gloc -{ - SCM_VALIDATE_VARIABLE (1,var); - if (SCM_UNBNDP (env)) - env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); - else - SCM_VALIDATE_NULLORCONS (2,env); - return scm_make_memoized (SCM_PACK (SCM_UNPACK (var) + scm_tc3_cons_gloc), env); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a gloc.") -#define FUNC_NAME s_scm_gloc_p -{ - return - SCM_BOOL (SCM_MEMOIZEDP (obj) - && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, (SCM frame, SCM binding, SCM cdrp), "Return a new iloc with frame offset @var{frame}, binding\n" @@ -538,8 +501,8 @@ scm_m_start_stack (SCM exp, SCM env) #define FUNC_NAME s_start_stack { exp = SCM_CDR (exp); - if (!SCM_ECONSP (exp) - || !SCM_ECONSP (SCM_CDR (exp)) + if (!SCM_CONSP (exp) + || !SCM_CONSP (SCM_CDR (exp)) || !SCM_NULLP (SCM_CDDR (exp))) SCM_WRONG_NUM_ARGS (); return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); diff --git a/libguile/debug.h b/libguile/debug.h index 06a3133cb..c5b54a62c 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -209,8 +209,6 @@ extern SCM scm_make_debugobj (scm_t_debug_frame *debug); extern void scm_init_debug (void); #ifdef GUILE_DEBUG -extern SCM scm_make_gloc (SCM var, SCM env); -extern SCM scm_gloc_p (SCM obj); extern SCM scm_make_iloc (SCM frame, SCM binding, SCM cdrp); extern SCM scm_iloc_p (SCM obj); extern SCM scm_memcons (SCM car, SCM cdr, SCM env); diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 6a32797cc..889c0d4fb 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -185,15 +185,15 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, #endif static void -scm_swap_bindings (SCM glocs, SCM vals) +scm_swap_bindings (SCM vars, SCM vals) { SCM tmp; while (SCM_NIMP (vals)) { - tmp = SCM_GLOC_VAL (SCM_CAR (glocs)); - SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals)); + tmp = SCM_VARIABLE_REF (SCM_CAR (vars)); + SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals)); SCM_SETCAR (vals, tmp); - glocs = SCM_CDR (glocs); + vars = SCM_CDR (vars); vals = SCM_CDR (vals); } } @@ -219,13 +219,16 @@ scm_dowinds (SCM to, long delta) #endif { wind_key = SCM_CAR (wind_elt); - /* key = #t | symbol | thunk | list of glocs | list of fluids */ + /* key = #t | symbol | thunk | list of variables | list of fluids */ if (SCM_NIMP (wind_key)) { - if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - else if (SCM_TYP3 (wind_key) == scm_tc3_cons) - scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + } else if (SCM_GUARDSP (wind_key)) SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) @@ -254,10 +257,13 @@ scm_dowinds (SCM to, long delta) wind_key = SCM_CAR (wind_elt); if (SCM_NIMP (wind_key)) { - if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc) - scm_swap_bindings (wind_key, from); - else if (SCM_TYP3 (wind_key) == scm_tc3_cons) - scm_swap_fluids_reverse (wind_key, from); + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt)); + } else if (SCM_GUARDSP (wind_key)) SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); else if (SCM_TYP3 (wind_key) == scm_tc3_closure) diff --git a/libguile/eval.c b/libguile/eval.c index 1978b2632..ff681d86d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -156,10 +156,8 @@ char *alloca (); : SCM_CEVAL (SCM_CAR (x), env)) #define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \ - ? (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), env) \ - : SCM_GLOC_VAL (SCM_CAR (x))) \ - : EVALCELLCAR (x, env)) + ? SCM_EVALIM (SCM_CAR (x), env) \ + : EVALCELLCAR (x, env)) #define EXTEND_ENV SCM_EXTEND_ENV @@ -197,7 +195,7 @@ scm_ilookup (SCM iloc, SCM env) tree-code instructions. There shouldn't normally be a problem with memoizing local and - global variable references (into ilocs and glocs), because all + global variable references (into ilocs and variables), because all threads will mutate the code in *exactly* the same way and (if I read the C code correctly) it is not possible to observe a half-way mutated cons cell. The lookup procedure can handle this @@ -205,11 +203,11 @@ scm_ilookup (SCM iloc, SCM env) It is different with macro expansion, because macro expansion happens outside of the lookup procedure and can't be - undone. Therefore it can't cope with it. It has to indicate - failure when it detects a lost race and hope that the caller can - handle it. Luckily, it turns out that this is the case. + undone. Therefore the lookup procedure can't cope with it. It has + to indicate failure when it detects a lost race and hope that the + caller can handle it. Luckily, it turns out that this is the case. - An example to illustrate this: Suppose that the follwing form will + An example to illustrate this: Suppose that the following form will be memoized concurrently by two threads (let ((x 12)) x) @@ -226,13 +224,13 @@ scm_ilookup (SCM iloc, SCM env) But let's see what will happen when the race occurs while looking up the symbol "let" at the start of the form. It could happen that the second thread interrupts the lookup of the first thread and not - only substitutes a gloc for it but goes right ahead and replaces it - with the compiled form (#@let* (x 12) x). Now, when the first - thread completes its lookup, it would replace the #@let* with a - gloc pointing to the "let" binding, effectively reverting the form - to (let (x 12) x). This is wrong. It has to detect that it has - lost the race and the evaluator has to reconsider the changed form - completely. + only substitutes a variable for it but goes right ahead and + replaces it with the compiled form (#@let* (x 12) x). Now, when + the first thread completes its lookup, it would replace the #@let* + with a variable containing the "let" binding, effectively reverting + the form to (let (x 12) x). This is wrong. It has to detect that + it has lost the race and the evaluator has to reconsider the + changed form completely. This race condition could be resolved with some kind of traffic light (like mutexes) around scm_lookupcar, but I think that it is @@ -370,15 +368,13 @@ scm_lookupcar (SCM vloc, SCM genv, int check) completely. */ race: var = SCM_CAR (vloc); - if (SCM_ITAG3 (var) == scm_tc3_cons_gloc) - return SCM_GLOC_VAL_LOC (var); if (SCM_VARIABLEP (var)) return SCM_VARIABLE_LOC (var); #ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); #endif - /* We can't cope with anything else than glocs and ilocs. When + /* We can't cope with anything else than variables and ilocs. When a special form has been memoized (i.e. `let' into `#@let') we return NULL and expect the calling function to do the right thing. For the evaluator, this means going back and redoing @@ -415,15 +411,7 @@ scm_unmemocar (SCM form, SCM env) if (SCM_IMP (form)) return form; c = SCM_CAR (form); - if (SCM_ITAG3 (c) == scm_tc3_cons_gloc) - { - SCM sym = - scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c)); - if (SCM_EQ_P (sym, SCM_BOOL_F)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } - else if (SCM_VARIABLEP (c)) + if (SCM_VARIABLEP (c)) { SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); @@ -839,7 +827,7 @@ iqq (SCM form, SCM env, long depth) --depth; label: form = SCM_CDR (form); - SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), + SCM_ASSERT (SCM_CONSP (form) && SCM_NULLP (SCM_CDR (form)), form, SCM_ARG1, s_quasiquote); if (0 == depth) return evalcar (form, env); @@ -1120,7 +1108,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) var = scm_symbol_fref (SCM_CAR (x)); SCM_ASSYNT (SCM_VARIABLEP (var), "Symbol's function definition is void", NULL); - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc); + SCM_SETCAR (x, var); return x; } @@ -1146,7 +1134,7 @@ scm_m_atbind (SCM xorig, SCM env) x = SCM_CAR (x); while (SCM_NIMP (x)) { - SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc); + SCM_SETCAR (x, scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)); x = SCM_CDR (x); } return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); @@ -1291,7 +1279,7 @@ unmemocopy (SCM x, SCM env) #ifdef DEBUG_EXTENSIONS SCM p; #endif - if (SCM_NCELLP (x) || SCM_NECONSP (x)) + if (SCM_NCELLP (x) || SCM_NCONSP (x)) return x; #ifdef DEBUG_EXTENSIONS p = scm_whash_lookup (scm_source_whash, x); @@ -1459,7 +1447,7 @@ unmemocopy (SCM x, SCM env) env); } loop: - while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x)) + while (SCM_CELLP (x = SCM_CDR (x)) && SCM_CONSP (x)) { if (SCM_ISYMP (SCM_CAR (x))) /* skip body markers */ @@ -1528,40 +1516,17 @@ SCM scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; - while (!SCM_IMP (l)) + while (SCM_CONSP (l)) { -#ifdef SCM_CAUTIOUS - if (SCM_CONSP (l)) - { - if (SCM_IMP (SCM_CAR (l))) - res = SCM_EVALIM (SCM_CAR (l), env); - else - res = EVALCELLCAR (l, env); - } - else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = - SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; - if (vcell == 0) - res = SCM_CAR (l); /* struct planted in code */ - else - res = SCM_GLOC_VAL (SCM_CAR (l)); - } - else - goto wrongnumargs; -#else res = EVALCAR (l, env); -#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) - { - wrongnumargs: - scm_wrong_num_args (proc); - } + scm_wrong_num_args (proc); #endif return results; } @@ -1758,40 +1723,17 @@ SCM scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; - while (!SCM_IMP (l)) + while (SCM_CONSP (l)) { -#ifdef SCM_CAUTIOUS - if (SCM_CONSP (l)) - { - if (SCM_IMP (SCM_CAR (l))) - res = SCM_EVALIM (SCM_CAR (l), env); - else - res = EVALCELLCAR (l, env); - } - else if (SCM_TYP3 (l) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = - SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell]; - if (vcell == 0) - res = SCM_CAR (l); /* struct planted in code */ - else - res = SCM_GLOC_VAL (SCM_CAR (l)); - } - else - goto wrongnumargs; -#else res = EVALCAR (l, env); -#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) - { - wrongnumargs: - scm_wrong_num_args (proc); - } + scm_wrong_num_args (proc); #endif return *results; } @@ -2014,7 +1956,7 @@ dispatch: if (!SCM_CELLP (SCM_CAR (x))) { x = SCM_CAR (x); - RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) + RETURN (SCM_EVALIM (x, env)) } if (SCM_SYMBOLP (SCM_CAR (x))) @@ -2208,9 +2150,6 @@ dispatch: else t.lloc = scm_lookupcar (x, env, 1); break; - case scm_tc3_cons_gloc: - t.lloc = SCM_GLOC_VAL_LOC (proc); - break; #ifdef MEMOIZE_LOCALS case scm_tc3_imm24: t.lloc = scm_ilookup (proc, env); @@ -2309,8 +2248,8 @@ dispatch: arg2 = *scm_ilookup (proc, env); else if (SCM_NCONSP (proc)) { - if (SCM_NCELLP (proc)) - arg2 = SCM_GLOC_VAL (proc); + if (SCM_VARIABLEP (proc)) + arg2 = SCM_VARIABLE_REF (proc); else arg2 = *scm_lookupcar (SCM_CDR (x), env, 1); } @@ -2477,9 +2416,8 @@ dispatch: arg2 = SCM_CDAR (env); while (SCM_NIMP (arg2)) { - proc = SCM_GLOC_VAL (SCM_CAR (t.arg1)); - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), - SCM_CAR (arg2)); + proc = SCM_VARIABLE_REF (SCM_CAR (t.arg1)); + SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2)); SCM_SETCAR (arg2, proc); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); @@ -2499,8 +2437,7 @@ dispatch: arg2 = SCM_CDAR (env); while (SCM_NIMP (arg2)) { - SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), - SCM_CAR (arg2)); + SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2)); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); } @@ -2557,6 +2494,7 @@ dispatch: case scm_tc7_cclo: case scm_tc7_pws: case scm_tcs_subrs: + case scm_tcs_struct: RETURN (x); case scm_tc7_variable: @@ -2573,25 +2511,7 @@ dispatch: #endif break; #endif /* ifdef MEMOIZE_LOCALS */ - - case scm_tcs_cons_gloc: { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) { - /* This is a struct implanted in the code, not a gloc. */ - RETURN (x); - } else { - proc = SCM_GLOC_VAL (SCM_CAR (x)); - SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS - goto checkargs; -#endif -#endif - } - break; - } - case scm_tcs_cons_nimcar: orig_sym = SCM_CAR (x); if (SCM_SYMBOLP (orig_sym)) @@ -2733,7 +2653,7 @@ evapply: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2786,14 +2706,6 @@ evapply: else t.arg1 = EVALCELLCAR (x, env); } - else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) - t.arg1 = SCM_CAR (x); /* struct planted in code */ - else - t.arg1 = SCM_GLOC_VAL (SCM_CAR (x)); - } else goto wrongnumargs; #else @@ -2888,7 +2800,7 @@ evapply: env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto nontoplevel_cdrxbegin; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -2936,14 +2848,6 @@ evapply: else arg2 = EVALCELLCAR (x, env); } - else if (SCM_TYP3 (x) == scm_tc3_cons_gloc) - { - scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell]; - if (vcell == 0) - arg2 = SCM_CAR (x); /* struct planted in code */ - else - arg2 = SCM_GLOC_VAL (SCM_CAR (x)); - } else goto wrongnumargs; #else @@ -2992,7 +2896,7 @@ evapply: proc))), SCM_EOL)); #endif - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); @@ -3058,7 +2962,7 @@ evapply: } } #ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || SCM_NECONSP (x)) + if (SCM_IMP (x) || SCM_NCONSP (x)) goto wrongnumargs; #endif #ifdef DEVAL @@ -3206,7 +3110,7 @@ evapply: x = SCM_CODE (proc); goto nontoplevel_cdrxbegin; #endif /* DEVAL */ - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL @@ -3649,7 +3553,7 @@ tail: debug.vect[0].a.proc = proc; #endif goto tail; - case scm_tcs_cons_gloc: /* really structs, not glocs */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL diff --git a/libguile/eval.h b/libguile/eval.h index 418844c0a..18e245483 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -115,9 +115,7 @@ extern SCM scm_eval_options_interface (SCM setting); ? SCM_EVALIM2(x) \ : (*scm_ceval_ptr) ((x), (env))) #define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ - ? (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), env) \ - : SCM_GLOC_VAL (SCM_CAR (x))) \ + ? SCM_EVALIM (SCM_CAR (x), env) \ : (SCM_SYMBOLP (SCM_CAR (x)) \ ? *scm_lookupcar (x, env, 1) \ : (*scm_ceval_ptr) (SCM_CAR (x), env))) @@ -182,16 +180,6 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; -/* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a variable with a - * tag of 1. This is called a "gloc". - */ - -#define SCM_GLOC_VAR(x) (SCM_PACK(SCM_UNPACK(x)-scm_tc3_cons_gloc)) -#define SCM_GLOC_VAL(x) (SCM_VARIABLE_REF (SCM_GLOC_VAR (x))) -#define SCM_GLOC_SET_VAL(x, y) (SCM_VARIABLE_SET (SCM_GLOC_VAR (x), y)) -#define SCM_GLOC_VAL_LOC(x) (SCM_VARIABLE_LOC (SCM_GLOC_VAR (x))) - extern SCM * scm_ilookup (SCM iloc, SCM env); diff --git a/libguile/gc.c b/libguile/gc.c index 43d532dff..83b9263e6 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1257,63 +1257,40 @@ gc_mark_loop_first_time: RECURSE (SCM_SETTER (ptr)); ptr = SCM_PROCEDURE (ptr); goto_gc_mark_loop; - case scm_tcs_cons_gloc: + case scm_tcs_struct: { - /* Dirk:FIXME:: The following code is super ugly: ptr may be a - * struct or a gloc. If it is a gloc, the cell word #0 of ptr - * is the address of a scm_tc16_variable smob. If it is a - * struct, the cell word #0 of ptr is a pointer to a struct - * vtable data region. (The fact that these are accessed in - * the same way restricts the possibilites to change the data - * layout of structs or heap cells.) To discriminate between - * the two, it is guaranteed that the scm_vtable_index_vcell - * element of the prospective vtable is always zero. For a - * gloc, this location has the CDR of the variable smob, which - * is guaranteed to be non-zero. - */ - scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc; - scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */ - if (vtable_data [scm_vtable_index_vcell] != 0) + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; + scm_t_bits * vtable_data = (scm_t_bits *) word0; + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + long len = SCM_SYMBOL_LENGTH (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); + scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { - /* ptr is a gloc */ - SCM gloc_car = SCM_PACK (word0); - RECURSE (gloc_car); - ptr = SCM_CDR (ptr); - goto gc_mark_loop; - } - else - { - /* ptr is a struct */ - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - long len = SCM_SYMBOL_LENGTH (layout); - char * fields_desc = SCM_SYMBOL_CHARS (layout); - scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); - - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); - RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - long x; - - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - RECURSE (SCM_PACK (*struct_data)); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data++; x; --x, ++struct_data) - RECURSE (SCM_PACK (*struct_data)); - else - RECURSE (SCM_PACK (*struct_data)); - } - } - /* mark vtable */ - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto_gc_mark_loop; + RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); + RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); } + if (len) + { + long x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + RECURSE (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data++; x; --x, ++struct_data) + RECURSE (SCM_PACK (*struct_data)); + else + RECURSE (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto_gc_mark_loop; } break; case scm_tcs_closures: @@ -1748,28 +1725,15 @@ scm_gc_sweep () switch SCM_TYP7 (scmptr) { - case scm_tcs_cons_gloc: + case scm_tcs_struct: { - /* Dirk:FIXME:: Again, super ugly code: scmptr may be a - * struct or a gloc. See the corresponding comment in - * scm_gc_mark. + /* Structs need to be freed in a special order. + * This is handled by GC C hooks in struct.c. */ - scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr) - - scm_tc3_cons_gloc); - /* access as struct */ - scm_t_bits * vtable_data = (scm_t_bits *) word0; - if (vtable_data[scm_vtable_index_vcell] == 0) - { - /* Structs need to be freed in a special order. - * This is handled by GC C hooks in struct.c. - */ - SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); - scm_structs_to_free = scmptr; - continue; - } - /* fall through so that scmptr gets collected */ + SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); + scm_structs_to_free = scmptr; } - break; + continue; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: case scm_tcs_closures: diff --git a/libguile/goops.c b/libguile/goops.c index 8e147bea9..94e7d6847 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1313,7 +1313,7 @@ wrap_init (SCM class, SCM *m, long n) SCM_SET_STRUCT_GC_CHAIN (z, 0); SCM_SET_CELL_WORD_1 (z, m); SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class) - | scm_tc3_cons_gloc); + | scm_tc3_struct); return z; } @@ -2594,7 +2594,7 @@ scm_wrap_object (SCM class, void *data) SCM_NEWCELL2 (z); SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data)); SCM_SET_STRUCT_GC_CHAIN (z, 0); - SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc); + SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct); return z; } diff --git a/libguile/modules.c b/libguile/modules.c index 062e3f9ee..ed8fdfdda 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -627,7 +627,7 @@ scm_post_boot_init_modules () #define PERM(x) scm_permanent_object(x) SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); - scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); + scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct); resolve_module_var = PERM (scm_c_lookup ("resolve-module")); process_define_module_var = PERM (scm_c_lookup ("process-define-module")); diff --git a/libguile/objects.c b/libguile/objects.c index e920ac78d..424cd466e 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -168,8 +168,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; - case scm_tcs_cons_gloc: - /* must be a struct */ + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) return SCM_CLASS_OF (x); else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) @@ -204,7 +203,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_unknown; } - case scm_tc3_cons_gloc: + case scm_tc3_struct: case scm_tc3_tc7_1: case scm_tc3_tc7_2: case scm_tc3_closure: diff --git a/libguile/print.c b/libguile/print.c index 3873da422..6204a8738 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -397,7 +397,6 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { -taloop: switch (SCM_ITAG3 (exp)) { case scm_tc3_closure: @@ -451,39 +450,30 @@ taloop: scm_ipruk ("immediate", exp, port); } break; - case scm_tc3_cons_gloc: - /* gloc */ - scm_puts ("#@", port); - exp = scm_module_reverse_lookup (scm_current_module (), - SCM_GLOC_VAR (exp)); - goto taloop; case scm_tc3_cons: switch (SCM_TYP7 (exp)) { - case scm_tcs_cons_gloc: - - if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0) - { - ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) - { - SCM pwps, print = pstate->writingp ? g_write : g_display; - if (!print) - goto print_struct; - SCM_NEWSMOB (pwps, - scm_tc16_port_with_ps, - SCM_UNPACK (scm_cons (port, pstate->handle))); - scm_call_generic_2 (print, exp, pwps); - } - else - { - print_struct: - scm_print_struct (exp, port, pstate); - } - EXIT_NESTED_DATA (pstate); - break; - } - + case scm_tcs_struct: + { + ENTER_NESTED_DATA (pstate, exp, circref); + if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) + { + SCM pwps, print = pstate->writingp ? g_write : g_display; + if (!print) + goto print_struct; + SCM_NEWSMOB (pwps, + scm_tc16_port_with_ps, + SCM_UNPACK (scm_cons (port, pstate->handle))); + scm_call_generic_2 (print, exp, pwps); + } + else + { + print_struct: + scm_print_struct (exp, port, pstate); + } + EXIT_NESTED_DATA (pstate); + } + break; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: ENTER_NESTED_DATA (pstate, exp, circref); @@ -754,9 +744,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) } -/* Print a list. The list may be either a list of ordinary data, or it may be - a list that represents code. Lists that represent code may contain gloc - cells. +/* Print a list. */ void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) @@ -772,12 +760,12 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) O(depth * N) instead of O(N^2). */ hare = SCM_CDR (exp); tortoise = exp; - while (SCM_ECONSP (hare)) + while (SCM_CONSP (hare)) { if (SCM_EQ_P (hare, tortoise)) goto fancy_printing; hare = SCM_CDR (hare); - if (SCM_IMP (hare) || SCM_NECONSP (hare)) + if (SCM_IMP (hare) || SCM_NCONSP (hare)) break; hare = SCM_CDR (hare); tortoise = SCM_CDR (tortoise); @@ -785,7 +773,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* No cdr cycles intrinsic to this list */ scm_iprin1 (SCM_CAR (exp), port, pstate); - for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (exp = SCM_CDR (exp); SCM_CONSP (exp); exp = SCM_CDR (exp)) { register long i; @@ -814,7 +802,7 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; - for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) + for (; SCM_CONSP (exp); exp = SCM_CDR (exp)) { register unsigned long i; diff --git a/libguile/procprop.c b/libguile/procprop.c index d3d63a3dd..e6136527d 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -137,7 +137,7 @@ scm_i_procedure_arity (SCM proc) if (!SCM_NULLP (proc)) r = 1; break; - case scm_tcs_cons_gloc: + case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { r = 1; diff --git a/libguile/procs.c b/libguile/procs.c index 576ca91e6..78b703bca 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -198,7 +198,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, if (SCM_NIMP (obj)) switch (SCM_TYP7 (obj)) { - case scm_tcs_cons_gloc: + case scm_tcs_struct: if (!SCM_I_OPERATORP (obj)) break; case scm_tcs_closures: diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 9f2c89b31..651066135 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -218,7 +218,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS - else if (SCM_NECONSP (obj)) + else if (SCM_NCONSP (obj)) SCM_WRONG_TYPE_ARG (1, obj); #endif p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); diff --git a/libguile/struct.c b/libguile/struct.c index e4014a9d5..dfc183e42 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -402,8 +402,8 @@ scm_free_structs (void *dummy1 SCM_UNUSED, } else { - scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; - /* access as struct */ + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct; scm_t_bits * vtable_data = (scm_t_bits *) word0; scm_t_bits * data = SCM_STRUCT_DATA (obj); scm_t_struct_free free_struct_data @@ -470,7 +470,8 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_SET_CELL_WORD_1 (handle, data); SCM_SET_STRUCT_GC_CHAIN (handle, 0); scm_struct_init (handle, layout, data, tail_elts, init); - SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, + (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_struct); SCM_ALLOW_INTS; return handle; } @@ -551,7 +552,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_SET_STRUCT_GC_CHAIN (handle, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); - SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc); + SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_struct); SCM_ALLOW_INTS; return handle; } diff --git a/libguile/struct.h b/libguile/struct.h index 659052501..ed330818d 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -63,7 +63,7 @@ #define scm_struct_i_size -1 /* Instance size */ #define scm_struct_i_flags -1 /* Upper 12 bits used as flags */ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_vtable_index_vcell 1 /* An opaque word, managed by the garbage collector. */ +#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */ #define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */ #define scm_vtable_index_printer 3 /* A printer for this struct type. */ #define scm_vtable_offset_user 4 /* Where do user fields start? */ @@ -75,10 +75,9 @@ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); #define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation (no hidden words) */ -/* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */ -#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc)) +#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_struct)) #define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X)) -#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc)) +#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct)) #define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout])) #define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v)) diff --git a/libguile/tags.h b/libguile/tags.h index b40fbc754..5dec122fb 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -117,20 +117,24 @@ typedef signed long scm_t_signed_bits; * only (i.e., programmers must keep track of any SCM variables they * create that don't contain ordinary scheme values). * - * All immediates and non-immediates must have a 0 in bit 0. Only - * non-object values can have a 1 in bit 0. In some cases, bit 0 of a - * word in the heap is used for the GC tag so during garbage - * collection, that bit might be 1 even in an immediate or - * non-immediate value. In other cases, bit 0 of a word in the heap - * is used to tag a pointer to a GLOC (VM global variable address) or - * the header of a struct. But whenever an SCM variable holds a - * normal Scheme value, bit 0 is 0. + * All immediates and pointers to cells of non-immediates have a 0 in + * bit 0. All non-immediates that are not pairs have a 1 in bit 0 of + * the first word of their cell. This is how pairs are distinguished + * from other non-immediates; a pair can have a immediate in its car + * (thus a 0 in bit 0), or a pointer to the cell of a non-immediate + * (again, this pointer has a 0 in bit 0). * - * Immediates and non-immediates are distinguished by bits two and four. - * Immediate values must have a 1 in at least one of those bits. Does - * this (or any other detail of tagging) seem arbitrary? Try changing it! - * (Not always impossible but it is fair to say that many details of tags - * are mutually dependent). */ + * Immediates and non-immediates are distinguished by bits 1 and 2. + * Immediate values must have a 1 in at least one of those bits. + * Consequently, a pointer to a cell of a non-immediate must have + * zeros in bits 1 and 2. Together with the requirement from above + * that bit 0 must also be zero, this means that pointers to cells of + * non-immediates must have their three low bits all zero. This in + * turn means that cells must be aligned on a 8 byte boundary, which + * is just right for two 32bit numbers (surprise, surprise). Does + * this (or any other detail of tagging) seem arbitrary? Try changing + * it! (Not always impossible but it is fair to say that many details + * of tags are mutually dependent). */ #define SCM_IMP(x) (6 & SCM_UNPACK (x)) #define SCM_NIMP(x) (!SCM_IMP (x)) @@ -142,17 +146,17 @@ typedef signed long scm_t_signed_bits; * * * 0 Most objects except... - * 1 ...glocs and structs (this tag valid only in a SCM_CAR or - * in the header of a struct's data). + * 1 ... structs (this tag is valid only in the header + * of a struct's data, as with all odd tags). * * 00 heap addresses and many immediates (not integers) - * 01 glocs/structs, some tc7_ codes + * 01 structs, some tc7_ codes * 10 immediate integers * 11 various tc7_ codes including, tc16_ codes. * * * 000 heap address - * 001 glocs/structs + * 001 structs * 010 integer * 011 closure * 100 immediates @@ -191,33 +195,35 @@ typedef signed long scm_t_signed_bits; * with the 13 immediates above being some of the most interesting. * * Also noteworthy are the groups of 16 7-bit instructions implied by - * some of the 3-bit tags. For example, closure references consist - * of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit - * instructions, all ending 011, which are invoked by evaluating closures. + * some of the 3-bit tags. For example, closure references consist of + * an 8-byte aligned address tagged with 011. There are 16 identical + * 7-bit instructions, all ending 011, which are invoked by evaluating + * closures. * * In other words, if you hand the evaluator a closure, the evaluator - * treats the closure as a graph of virtual machine instructions. - * A closure is a pair with a pointer to the body of the procedure - * in the CDR and a pointer to the environment of the closure in the CAR. + * treats the closure as a graph of virtual machine instructions. A + * closure is a pair with a pointer to the body of the procedure in + * the CDR and a pointer to the environment of the closure in the CAR. * The environment pointer is tagged 011 which implies that the least - * significant 7 bits of the environment pointer also happen to be - * a virtual machine instruction we could call "SELF" (for self-evaluating - * object). + * significant 7 bits of the environment pointer also happen to be a + * virtual machine instruction we could call "SELF" (for + * self-evaluating object). * - * A less trivial example are the 16 instructions ending 000. If those - * bits tag the CAR of a pair, then evidently the pair is an ordinary - * cons pair and should be evaluated as a procedure application. The sixteen, - * 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier. - * For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY - * instruction will, as a side effect, overwrite that CAR with a new instruction - * that contains a cached address for the variable named by the symbol.) + * A less trivial example are the 16 instructions ending 000. If + * those bits tag the CAR of a pair, then evidently the pair is an + * ordinary cons pair and should be evaluated as a procedure + * application. The sixteen, 7-bit 000 instructions are all + * "NORMAL-APPLY" (Things get trickier. For example, if the CAR of a + * procedure application is a symbol, the NORMAL-APPLY instruction + * will, as a side effect, overwrite that CAR with a new instruction + * that contains a cached address for the variable named by the + * symbol.) * * Here is a summary of tags in the CAR of a non-immediate: * * HEAP CELL: G=gc_mark; 1 during mark, 0 other times. * * cons ..........SCM car..............0 ...........SCM cdr.............G - * gloc ..........SCM vcell..........001 ...........SCM cdr.............G * struct ..........void * type........001 ...........void * data.........G * closure ..........SCM code...........011 ...........SCM env.............G * tc7 ......24.bits of data...Gxxxx1S1 ..........void *data............ @@ -284,17 +290,6 @@ typedef signed long scm_t_signed_bits; #define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0)) #define SCM_NCONSP(x) (!SCM_CONSP (x)) - -/* SCM_ECONSP should be used instead of SCM_CONSP at places where GLOCS - * can be expected to occur. - */ -#define SCM_ECONSP(x) \ - (!SCM_IMP (x) \ - && (SCM_CONSP (x) \ - || (SCM_TYP3 (x) == 1 \ - && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0)))) -#define SCM_NECONSP(x) (!SCM_ECONSP (x)) - #define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) @@ -303,11 +298,11 @@ typedef signed long scm_t_signed_bits; /* See numbers.h for macros relating to immediate integers. */ -#define SCM_ITAG3(x) (7 & SCM_UNPACK (x)) -#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x)) -#define scm_tc3_cons 0 -#define scm_tc3_cons_gloc 1 -#define scm_tc3_int_1 2 +#define SCM_ITAG3(x) (7 & SCM_UNPACK (x)) +#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x)) +#define scm_tc3_cons 0 +#define scm_tc3_struct 1 +#define scm_tc3_int_1 2 #define scm_tc3_closure 3 #define scm_tc3_imm24 4 #define scm_tc3_tc7_1 5 @@ -497,8 +492,10 @@ extern char *scm_isymnames[]; /* defined in print.c */ -/* Dispatching aids: */ +/* Dispatching aids: + When switching on SCM_TYP7 of a SCM value, use these fake case + labels to catch types that use fewer than 7 bits for tagging. */ /* For cons pairs with immediate values in the CAR */ @@ -523,20 +520,22 @@ extern char *scm_isymnames[]; /* defined in print.c */ case 64:case 72:case 80:case 88:\ case 96:case 104:case 112:case 120 -/* A CONS_GLOC occurs in code. It's CAR is a pointer to the - * CDR of a variable. The low order bits of the CAR are 001. - * The CDR of the gloc is the code continuation. +/* For structs */ -#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ +#define scm_tcs_struct 1:case 9:case 17:case 25:\ case 33:case 41:case 49:case 57:\ case 65:case 73:case 81:case 89:\ case 97:case 105:case 113:case 121 +/* For closures + */ #define scm_tcs_closures 3:case 11:case 19:case 27:\ case 35:case 43:case 51:case 59:\ case 67:case 75:case 83:case 91:\ case 99:case 107:case 115:case 123 +/* For subrs + */ #define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr From a0f5718e1556066cc536a7871529dc077b70a594 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Jul 2001 21:40:52 +0000 Subject: [PATCH 17/39] *** empty log message *** --- libguile/ChangeLog | 43 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38f7d3b1e..c0267c7c4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,8 +1,49 @@ 2001-07-26 Marius Vollmer + "Glocs" have been removed. + + * tags.h: Update tag system docs. + (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses. + (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses. + (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP + or SCM_NCONSP, respectively. + + * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c, + objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses + of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above. + + * print.c (scm_iprin1): Remove printing of glocs. Do not try to + tell glocs from structs. + + * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs. + + * eval.c (scm_m_atbind): Make a list of variables, not glocs. + (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables + instead of with glocs. + (EVALCAR): Do not test for glocs. + (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race + condition. + (scm_unmemocar): Do not handle glocs. + (scm_m_atfop): Memoize as a variable, not as a gloc. + (scm_eval_args, scm_deval_args): Do not handle glocs. + (scm_ceval, scm_deval): Likewise. + + * eval.h (SCM_XEVALCAR): Do not test for glocs. + (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC): + Removed. + + * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed. + + * dynwind.c (scm_swap_bindings): Likewise. + (scm_dowinds): Updated to recognize lists of variables instead of + lists of glocs. + + * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments. + + * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context where it is needed. - + 2001-07-25 Gary Houston * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the From 024001c213e229f9a6ba0066184f59349559003a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Fri, 27 Jul 2001 16:11:13 +0000 Subject: [PATCH 18/39] Check in forgotten test scripts. --- examples/box-dynamic-module/check.test | 48 +++++++++++++++++++++++ examples/box-dynamic/check.test | 38 ++++++++++++++++++ examples/box-module/check.test | 38 ++++++++++++++++++ examples/box/check.test | 38 ++++++++++++++++++ examples/modules/check.test | 27 +++++++++++++ examples/safe/check.test | 40 +++++++++++++++++++ examples/scripts/check.test | 53 ++++++++++++++++++++++++++ 7 files changed, 282 insertions(+) create mode 100755 examples/box-dynamic-module/check.test create mode 100755 examples/box-dynamic/check.test create mode 100755 examples/box-module/check.test create mode 100755 examples/box/check.test create mode 100755 examples/modules/check.test create mode 100755 examples/safe/check.test create mode 100755 examples/scripts/check.test diff --git a/examples/box-dynamic-module/check.test b/examples/box-dynamic-module/check.test new file mode 100755 index 000000000..935176d20 --- /dev/null +++ b/examples/box-dynamic-module/check.test @@ -0,0 +1,48 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# +# ./box test #4 +# +$guile -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP +cat < # #) +(# # #) +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box-dynamic/check.test b/examples/box-dynamic/check.test new file mode 100755 index 000000000..c0923365c --- /dev/null +++ b/examples/box-dynamic/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box-module/check.test b/examples/box-module/check.test new file mode 100755 index 000000000..28a79d45b --- /dev/null +++ b/examples/box-module/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/box/check.test b/examples/box/check.test new file mode 100755 index 000000000..1909ffb7e --- /dev/null +++ b/examples/box/check.test @@ -0,0 +1,38 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +set -e + +# +# ./box test #1 +# +./box -c '(let ((b (make-box))) (display b) (newline))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box test #2 +# +./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box test #3 +# +./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# check.test ends here diff --git a/examples/modules/check.test b/examples/modules/check.test new file mode 100755 index 000000000..f7a789b69 --- /dev/null +++ b/examples/modules/check.test @@ -0,0 +1,27 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../../libguile/guile} + +if test "X$srcdir" = X; then + srcdir=. +fi + +set -e + +# +# ./main test +# +$guile -s $srcdir/main > TMP +cat < TMP +cat < TMP +cat < TMP +cat < TMP +echo "Hello, World!" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/hello --version > TMP +echo "hello 0.0.1" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/hello --help > TMP +cat < Date: Sun, 29 Jul 2001 20:39:38 +0000 Subject: [PATCH 19/39] (scm_vtable_index_vcell): Removed. Renumbered subsequent indices. --- libguile/struct.h | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/struct.h b/libguile/struct.h index ed330818d..ec5ae8cff 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -62,11 +62,13 @@ #define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ #define scm_struct_i_size -1 /* Instance size */ #define scm_struct_i_flags -1 /* Upper 12 bits used as flags */ + +/* These indices must correspond to required_vtable_fields in + struct.c. */ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */ -#define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */ -#define scm_vtable_index_printer 3 /* A printer for this struct type. */ -#define scm_vtable_offset_user 4 /* Where do user fields start? */ +#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable. */ +#define scm_vtable_index_printer 2 /* A printer for this struct type. */ +#define scm_vtable_offset_user 3 /* Where do user fields start? */ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); From 6902384eb94ed03d85de6a5892357dde6e7dee57 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:42:06 +0000 Subject: [PATCH 20/39] (scm_struct_vtable_p): Do not check vcell slot for zero. Use scm_vtable_index_layout instead of "0" when accessing said slot. (scm_init_struct): Remove vcell slot layout code from required_vtable_fields. --- libguile/struct.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index dfc183e42..37cc7422d 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -270,10 +270,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, mem = SCM_STRUCT_DATA (x); - if (mem[1] != 0) - return SCM_BOOL_F; - - return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[0]))); + return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[scm_vtable_index_layout]))); } #undef FUNC_NAME @@ -823,7 +820,7 @@ scm_init_struct () { scm_struct_table = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); - required_vtable_fields = scm_makfrom0str ("pruosrpw"); + required_vtable_fields = scm_makfrom0str ("prsrpw"); scm_permanent_object (required_vtable_fields); scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); From e93854046bdec349b6c09704ccca3b805ee30a81 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:43:05 +0000 Subject: [PATCH 21/39] (scm_si_redefined, scm_si_hashsets): Renumbered. --- libguile/objects.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/objects.h b/libguile/objects.h index 649d3fb1e..a7afb4aa2 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -173,8 +173,8 @@ struct scm_metaclass_operator { #define SCM_CLASSF_PURE_GENERIC (0x010 << 20) #define SCM_CLASSF_GOOPS_VALID (0x080 << 20) #define SCM_CLASSF_GOOPS (0x100 << 20) -#define scm_si_redefined 6 -#define scm_si_hashsets 7 +#define scm_si_redefined 5 +#define scm_si_hashsets 6 #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined])) From 7895b092c476aa9020d931c5deb69c3e6c4a1898 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:46:23 +0000 Subject: [PATCH 22/39] Renumbered slot indices. (SCM_CLASS_CLASS_LAYOUT): Removed vcell slot layout code. (scm_si_vcell): Removed. --- libguile/goops.h | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/libguile/goops.h b/libguile/goops.h index 574331144..d0b85c684 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -59,34 +59,33 @@ * scm_class_class */ -#define SCM_CLASS_CLASS_LAYOUT "pruosrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw" +#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw" #define scm_si_layout 0 /* the struct layout */ -#define scm_si_vcell 1 -#define scm_si_vtable 2 -#define scm_si_print 3 /* the struct print closure */ -#define scm_si_proc 4 -#define scm_si_setter 5 +#define scm_si_vtable 1 +#define scm_si_print 2 /* the struct print closure */ +#define scm_si_proc 3 +#define scm_si_setter 4 -#define scm_si_goops_fields 6 +#define scm_si_goops_fields 5 -/* Defined in libguile/objects.c: -#define scm_si_redefined 6 The class to which class was redefined. -#define scm_si_hashsets 7 +/* Defined in libguile/objects.h: +#define scm_si_redefined 5 The class to which class was redefined. +#define scm_si_hashsets 6 */ -#define scm_si_name 15 /* a symbol */ -#define scm_si_direct_supers 16 /* (class ...) */ -#define scm_si_direct_slots 17 /* ((name . options) ...) */ -#define scm_si_direct_subclasses 18 /* (class ...) */ -#define scm_si_direct_methods 19 /* (methods ...) */ -#define scm_si_cpl 20 /* (class ...) */ -#define scm_si_slotdef_class 21 -#define scm_si_slots 22 /* ((name . options) ...) */ -#define scm_si_name_access 23 -#define scm_si_keyword_access 24 -#define scm_si_nfields 25 /* an integer */ -#define scm_si_environment 26 /* The environment in which class is built */ -#define SCM_N_CLASS_SLOTS 27 +#define scm_si_name 14 /* a symbol */ +#define scm_si_direct_supers 15 /* (class ...) */ +#define scm_si_direct_slots 16 /* ((name . options) ...) */ +#define scm_si_direct_subclasses 17 /* (class ...) */ +#define scm_si_direct_methods 18 /* (methods ...) */ +#define scm_si_cpl 19 /* (class ...) */ +#define scm_si_slotdef_class 20 +#define scm_si_slots 21 /* ((name . options) ...) */ +#define scm_si_name_access 22 +#define scm_si_keyword_access 23 +#define scm_si_nfields 24 /* an integer */ +#define scm_si_environment 25 /* The environment in which class is built */ +#define SCM_N_CLASS_SLOTS 26 typedef struct scm_t_method { SCM generic_function; From c0227bcdb05bea15e0668eb24ec6343ec6eee131 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:46:37 +0000 Subject: [PATCH 23/39] (build_class_class_slots): Removed vcell slot definition. --- libguile/goops.c | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/goops.c b/libguile/goops.c index 94e7d6847..b813dad05 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -707,7 +707,6 @@ build_class_class_slots () { return scm_list_n ( scm_list_3 (sym_layout, k_class, scm_class_protected_read_only), - scm_list_3 (sym_vcell, k_class, scm_class_opaque), scm_list_3 (sym_vtable, k_class, scm_class_self), scm_list_1 (sym_print), scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque), From 8b958d72d10255c9f4fb77fe1ac6879afa3ecf5c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:48:41 +0000 Subject: [PATCH 24/39] (hashset-index): Renumbered, since the vcell slot of structs has been removed. --- oop/goops/dispatch.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index d766b637a..cd1c7e698 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -61,7 +61,7 @@ ;;; (define hashsets 8) -(define hashset-index 7) +(define hashset-index 6) (define hash-threshold 3) (define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold From 54866b6c2012368b0de9675b17a12bd08a7f31d4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 29 Jul 2001 20:48:52 +0000 Subject: [PATCH 25/39] *** empty log message *** --- libguile/ChangeLog | 22 ++++++++++++++++++++++ oop/ChangeLog | 5 +++++ 2 files changed, 27 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c0267c7c4..901e1b458 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2001-07-29 Marius Vollmer + + Removed vcell slot from structs. + + * struct.h (scm_vtable_index_vcell): Removed. Renumbered + subsequent indices. + + * struct.c (scm_struct_vtable_p): Do not check vcell slot for + zero. Use scm_vtable_index_layout instead of "0" when accessing + said slot. + (scm_init_struct): Remove vcell slot layout code from + required_vtable_fields. + + * objects.h (scm_si_redefined, scm_si_hashsets): Renumbered. + + * goops.c (build_class_class_slots): Removed vcell slot + definition. + + * goops.h: Renumbered slot indices. (SCM_CLASS_CLASS_LAYOUT): + Removed vcell slot layout code. + (scm_si_vcell): Removed. + 2001-07-26 Marius Vollmer "Glocs" have been removed. diff --git a/oop/ChangeLog b/oop/ChangeLog index 2e82f3a1c..ab927758c 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2001-07-29 Marius Vollmer + + * goops/dispatch.scm (hashset-index): Renumbered, since the vcell + slot of structs has been removed. + 2001-07-18 Martin Grabmueller * goops/util.scm: Updated copyright notice. From 6cf695375fe598182b1925a41f6dd9b1e279a11e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 18:25:14 +0000 Subject: [PATCH 26/39] * Use SCM_CONSP, not SCM_ECONSP. --- libguile/ChangeLog | 4 ++++ libguile/pairs.h | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 901e1b458..6cf02a0dd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2001-07-30 Dirk Herrmann + + * pairs.h (SCM_VALIDATE_PAIR): Use SCM_CONSP, not SCM_ECONSP. + 2001-07-29 Marius Vollmer Removed vcell slot from structs. diff --git a/libguile/pairs.h b/libguile/pairs.h index 6b808f886..ff6bddc5b 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -53,7 +53,7 @@ #if (SCM_DEBUG_PAIR_ACCESSES == 1) # include "libguile/struct.h" # define SCM_VALIDATE_PAIR(cell, expr) \ - ((!SCM_ECONSP (cell) ? scm_error_pair_access (cell), 0 : 0), (expr)) + ((!SCM_CONSP (cell) ? scm_error_pair_access (cell), 0 : 0), (expr)) #else # define SCM_VALIDATE_PAIR(cell, expr) (expr) #endif From 01f11e027e9978fe04e8cecb5ebffcd2eea8eccf Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 18:55:50 +0000 Subject: [PATCH 27/39] * Minor changes. --- libguile/ChangeLog | 12 ++++++++ libguile/eval.c | 71 ++++++++++++++++++++++------------------------ 2 files changed, 46 insertions(+), 37 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6cf02a0dd..3b1c32fbe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2001-07-30 Dirk Herrmann + + * eval.c (scm_lookupcar, scm_m_body, scm_m_lambda, unmemocopy, + scm_unmemocopy, scm_badargsp, scm_eval_body, CHECK_EQVISH, + SCM_CEVAL, scm_nconc2last, SCM_APPLY, scm_copy_tree): Prefer + !SCM_ over SCM_N. + + (scm_eval_body): Remove side effecting code from macro call. + + (SCM_CEVAL, SCM_APPLY): Remove goto statement and redundant + SCM_NIMP test. + 2001-07-30 Dirk Herrmann * pairs.h (SCM_VALIDATE_PAIR): Use SCM_CONSP, not SCM_ECONSP. diff --git a/libguile/eval.c b/libguile/eval.c index ff681d86d..f598f370d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -278,7 +278,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) al = SCM_CARLOC (env); for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { - if (SCM_NCONSP (fl)) + if (!SCM_CONSP (fl)) { if (SCM_EQ_P (fl, var)) { @@ -336,7 +336,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) goto errout; #ifndef SCM_RECKLESS - if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) + if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) { errout: /* scm_everr (vloc, genv,...) */ @@ -501,7 +501,7 @@ scm_m_body (SCM op, SCM xorig, const char *what) /* Retain possible doc string. */ if (!SCM_CONSP (SCM_CAR (xorig))) { - if (SCM_NNULLP (SCM_CDR(xorig))) + if (!SCM_NULLP (SCM_CDR(xorig))) return scm_cons (SCM_CAR (xorig), scm_m_body (op, SCM_CDR(xorig), what)); return xorig; @@ -673,11 +673,11 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) goto badforms; if (SCM_SYMBOLP (proc)) goto memlambda; - if (SCM_NCONSP (proc)) + if (!SCM_CONSP (proc)) goto badforms; while (SCM_NIMP (proc)) { - if (SCM_NCONSP (proc)) + if (!SCM_CONSP (proc)) { if (!SCM_SYMBOLP (proc)) goto badforms; @@ -690,7 +690,7 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); proc = SCM_CDR (proc); } - if (SCM_NNULLP (proc)) + if (!SCM_NULLP (proc)) { badforms: scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); @@ -1279,7 +1279,7 @@ unmemocopy (SCM x, SCM env) #ifdef DEBUG_EXTENSIONS SCM p; #endif - if (SCM_NCELLP (x) || SCM_NCONSP (x)) + if (!SCM_CELLP (x) || !SCM_CONSP (x)) return x; #ifdef DEBUG_EXTENSIONS p = scm_whash_lookup (scm_source_whash, x); @@ -1414,7 +1414,7 @@ unmemocopy (SCM x, SCM env) x = SCM_CDR (x); ls = scm_cons (scm_sym_define, z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED)); - if (SCM_NNULLP (env)) + if (!SCM_NULLP (env)) SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); break; } @@ -1459,7 +1459,7 @@ loop: } SCM_SETCDR (z, x); #ifdef DEBUG_EXTENSIONS - if (SCM_NFALSEP (p)) + if (!SCM_FALSEP (p)) scm_whash_insert (scm_source_whash, ls, p); #endif return ls; @@ -1469,7 +1469,7 @@ loop: SCM scm_unmemocopy (SCM x, SCM env) { - if (SCM_NNULLP (env)) + if (!SCM_NULLP (env)) /* Make a copy of the lowest frame to protect it from modifications by SCM_IM_DEFINE */ return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env))); @@ -1484,14 +1484,14 @@ scm_badargsp (SCM formals, SCM args) { while (SCM_NIMP (formals)) { - if (SCM_NCONSP (formals)) + if (!SCM_CONSP (formals)) return 0; if (SCM_IMP(args)) return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); } - return SCM_NNULLP (args) ? 1 : 0; + return !SCM_NULLP (args) ? 1 : 0; } #endif @@ -1536,8 +1536,8 @@ scm_eval_body (SCM code, SCM env) { SCM next; again: - next = code; - while (SCM_NNULLP (next = SCM_CDR (next))) + next = SCM_CDR (code); + while (!SCM_NULLP (next)) { if (SCM_IMP (SCM_CAR (code))) { @@ -1550,6 +1550,7 @@ scm_eval_body (SCM code, SCM env) else SCM_XEVAL (SCM_CAR (code), env); code = next; + next = SCM_CDR (code); } return SCM_XEVALCAR (code, env); } @@ -1755,7 +1756,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } while (0) #ifndef DEVAL -#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) +#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B))))) #endif /* DEVAL */ #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ @@ -1893,7 +1894,7 @@ dispatch: case SCM_BIT8(SCM_IM_AND): x = SCM_CDR (x); t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) if (SCM_FALSEP (EVALCAR (x, env))) { RETURN (SCM_BOOL_F); @@ -2001,7 +2002,7 @@ dispatch: { proc = SCM_CAR (x); t.arg1 = EVALCAR (proc, env); - if (SCM_NFALSEP (t.arg1)) + if (!SCM_FALSEP (t.arg1)) { x = SCM_CDR (proc); if (SCM_NULLP (x)) @@ -2059,7 +2060,7 @@ dispatch: case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); - if (SCM_NFALSEP (EVALCAR (x, env))) + if (!SCM_FALSEP (EVALCAR (x, env))) x = SCM_CDR (x); else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x)))) { @@ -2246,7 +2247,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); if (SCM_IMP (proc)) arg2 = *scm_ilookup (proc, env); - else if (SCM_NCONSP (proc)) + else if (!SCM_CONSP (proc)) { if (SCM_VARIABLEP (proc)) arg2 = SCM_VARIABLE_REF (proc); @@ -2377,7 +2378,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_T_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) + RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) case (SCM_ISYMNUM (SCM_IM_0_COND)): proc = SCM_CDR (x); @@ -2405,7 +2406,7 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_1_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) + RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? SCM_MAKINUM (1) : SCM_INUM0) @@ -2426,7 +2427,7 @@ dispatch: scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds); arg2 = x = SCM_CDR (x); - while (SCM_NNULLP (arg2 = SCM_CDR (arg2))) + while (!SCM_NULLP (arg2 = SCM_CDR (arg2))) { SIDEVAL (SCM_CAR (x), env); x = arg2; @@ -2733,18 +2734,16 @@ evapply: { RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)))); } - SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); - if (SCM_REALP (t.arg1)) + else if (SCM_REALP (t.arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1)))); } #ifdef SCM_BIGDIG - if (SCM_BIGP (t.arg1)) + else if (SCM_BIGP (t.arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1)))); } #endif - floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } @@ -2962,7 +2961,7 @@ evapply: } } #ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || SCM_NCONSP (x)) + if (SCM_IMP (x) || !SCM_CONSP (x)) goto wrongnumargs; #endif #ifdef DEVAL @@ -3269,7 +3268,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, SCM *lloc; SCM_VALIDATE_NONEMPTYLIST (1,lst); lloc = &lst; - while (SCM_NNULLP (SCM_CDR (*lloc))) + while (!SCM_NULLP (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); @@ -3395,7 +3394,7 @@ tail: args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)) case scm_tc7_subr_2: - SCM_ASRTGO (SCM_NNULLP (args) && SCM_NULLP (SCM_CDR (args)), + SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), wrongnumargs); args = SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)) @@ -3415,16 +3414,14 @@ tail: { RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); } - SCM_ASRTGO (SCM_NIMP (arg1), floerr); - if (SCM_REALP (arg1)) + else if (SCM_REALP (arg1)) { RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } #ifdef SCM_BIGDIG - if (SCM_BIGP (arg1)) + else if (SCM_BIGP (arg1)) RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))) #endif - floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } @@ -3440,8 +3437,8 @@ tail: RETURN (arg1) } case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NNULLP (args) - && SCM_NNULLP (SCM_CDR (args)) + SCM_ASRTGO (!SCM_NULLP (args) + && !SCM_NULLP (SCM_CDR (args)) && SCM_NULLP (SCM_CDDR (args)), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) @@ -3506,7 +3503,7 @@ tail: proc = SCM_CDR (SCM_CODE (proc)); again: arg1 = proc; - while (SCM_NNULLP (arg1 = SCM_CDR (arg1))) + while (!SCM_NULLP (arg1 = SCM_CDR (arg1))) { if (SCM_IMP (SCM_CAR (proc))) { @@ -3872,7 +3869,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); return ans; } - if (SCM_NCONSP (obj)) + if (!SCM_CONSP (obj)) return obj; ans = tl = scm_cons_source (obj, scm_copy_tree (SCM_CAR (obj)), From 3c9a524f01b3054b03c25638f8e29c533e8057f0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 30 Jul 2001 19:35:15 +0000 Subject: [PATCH 28/39] * Rewrote string->number stuff. --- libguile/ChangeLog | 33 ++ libguile/numbers.c | 1098 +++++++++++++++++++++++--------------------- libguile/numbers.h | 20 +- libguile/read.c | 47 +- 4 files changed, 649 insertions(+), 549 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3b1c32fbe..b21e6a6c6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,36 @@ +2001-07-30 Dirk Herrmann + + * numbers.c (DIGITS, scm_small_istr2int, scm_istr2int, + scm_istr2flo, scm_istring2number): Removed. + + (iflo2str, scm_real_p, scm_integer_p): Use SCM_ instead of + SCM_SLOPPY_. + + (t_exactness, t_radix, DIGIT2UINT, XDIGIT2UINT, mem2uinteger, + mem2decimal_from_point, mem2ureal, mem2complex, scm_i_mem2number): + Added. + + (scm_string_to_number): Use new number parser. + + (scm_exact_to_inexact): Replace dummy by a GPROC, which also + handles complex numbers. + + * numbers.h (NUMBERSH, SCM_NUMBERS_H): Rename H to + SCM__H. + + (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Prefer !SCM_ over + SCM_N. + + (scm_istr2int, scm_istr2flo, scm_istring2number): Removed. + + (scm_i_mem2number): Added. + + (scm_exact_to_inexact): Changed signature. + + * read.c (scm_lreadr): Perform the shortcut test for '+ and '- + here instead of within scm_i_mem2number. Call scm_i_mem2number + instead of scm_istr2int and scm_istring2number. + 2001-07-30 Dirk Herrmann * eval.c (scm_lookupcar, scm_m_body, scm_m_lambda, unmemocopy, diff --git a/libguile/numbers.c b/libguile/numbers.c index 0fc136cce..1a6ff53c1 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -43,6 +43,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -60,10 +61,6 @@ static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, in static SCM scm_divbigint (SCM x, long z, int sgn, int mode); -#define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' - - #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -2063,7 +2060,7 @@ static size_t iflo2str (SCM flt, char *str) { size_t i; - if (SCM_SLOPPY_REALP (flt)) + if (SCM_REALP (flt)) i = idbl2str (SCM_REAL_VALUE (flt), str); else { @@ -2229,518 +2226,573 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } /*** END nums->strs ***/ + /*** STRINGS -> NUMBERS ***/ +/* The following functions implement the conversion from strings to numbers. + * The implementation somehow follows the grammar for numbers as it is given + * in R5RS. Thus, the functions resemble syntactic units (, + * , ...) that are used to build up numbers in the grammar. Some + * points should be noted about the implementation: + * * Each function keeps a local index variable 'idx' that points at the + * current position within the parsed string. The global index is only + * updated if the function could parse the corresponding syntactic unit + * successfully. + * * Similarly, the functions keep track of indicators of inexactness ('#', + * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the + * global exactness information is only updated after each part has been + * successfully parsed. + * * Sequences of digits are parsed into temporary variables holding fixnums. + * Only if these fixnums would overflow, the result variables are updated + * using the standard functions scm_add, scm_product, scm_divide etc. Then, + * the temporary variables holding the fixnums are cleared, and the process + * starts over again. If for example fixnums were able to store five decimal + * digits, a number 1234567890 would be parsed in two parts 12345 and 67890, + * and the result was computed as 12345 * 100000 + 67890. In other words, + * only every five digits two bignum operations were performed. + */ + +enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; + +/* R5RS, section 7.1.1, lexical structure of numbers: . */ + +/* In non ASCII-style encodings the following macro might not work. */ +#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10) + static SCM -scm_small_istr2int (char *str, long len, long radix) +mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) { - register long n = 0, ln; - register int c; - register int i = 0; - int lead_neg = 0; - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - switch (*str) - { /* leading sign */ - case '-': - lead_neg = 1; - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } + unsigned int idx = *p_idx; + unsigned int hash_seen = 0; + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + SCM result; + char c; - do - { - switch (c = str[i++]) - { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - ln = n; - n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) - goto ovfl; - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } - while (i < len); - if (!lead_neg) - if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) - goto ovfl; - return SCM_MAKINUM (n); - ovfl: /* overflow scheme integer */ - return SCM_BOOL_F; -} - - - -SCM -scm_istr2int (char *str, long len, long radix) -{ - size_t j; - register size_t k, blen = 1; - size_t i = 0; - int c; - SCM res; - register SCM_BIGDIG *ds; - register unsigned long t2; - - if (0 >= len) - return SCM_BOOL_F; /* zero scm_length */ - - /* Short numbers we parse directly into an int, to avoid the overhead - of creating a bignum. */ - if (len < 6) - return scm_small_istr2int (str, len, radix); - - if (16 == radix) - j = 1 + (4 * len * sizeof (char)) / (SCM_BITSPERDIG); - else if (10 <= radix) - j = 1 + (84 * len * sizeof (char)) / (SCM_BITSPERDIG * 25); - else - j = 1 + (len * sizeof (char)) / (SCM_BITSPERDIG); - switch (str[0]) - { /* leading sign */ - case '-': - case '+': - if (++i == (unsigned) len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - res = scm_i_mkbig (j, '-' == str[0]); - ds = SCM_BDIGITS (res); - for (k = j; k--;) - ds[k] = 0; - do - { - switch (c = str[i++]) - { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accumulate; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accumulate: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - k = 0; - t2 = c; - moretodo: - while (k < blen) - { -/* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */ - t2 += ds[k] * radix; - ds[k++] = SCM_BIGLO (t2); - t2 = SCM_BIGDN (t2); - } - if (blen > j) - scm_num_overflow ("bignum"); - if (t2) - { - blen++; - goto moretodo; - } - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } - while (i < (unsigned) len); - if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (res = scm_i_big2inum (res, blen))) - return res; - if (j == blen) - return res; - return scm_i_adjbig (res, blen); -} - -SCM -scm_istr2flo (char *str, long len, long radix) -{ - register int c, i = 0; - double lead_sgn; - double res = 0.0, tmp = 0.0; - int flg = 0; - int point = 0; - SCM second; - - if (i >= len) - return SCM_BOOL_F; /* zero scm_length */ - - switch (*str) - { /* leading sign */ - case '-': - lead_sgn = -1.0; - i++; - break; - case '+': - lead_sgn = 1.0; - i++; - break; - default: - lead_sgn = 0.0; - } - if (i == len) - return SCM_BOOL_F; /* bad if lone `+' or `-' */ - - if (str[i] == 'i' || str[i] == 'I') - { /* handle `+i' and `-i' */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, lead_sgn); - } - do - { /* check initial digits */ - switch (c = str[i]) - { - case DIGITS: - c = c - '0'; - goto accum1; - case 'D': - case 'E': - case 'F': - if (radix == 10) - goto out1; /* must be exponent */ - case 'A': - case 'B': - case 'C': - c = c - 'A' + 10; - goto accum1; - case 'd': - case 'e': - case 'f': - if (radix == 10) - goto out1; - case 'a': - case 'b': - case 'c': - c = c - 'a' + 10; - accum1: - if (c >= radix) - return SCM_BOOL_F; /* bad digit for radix */ - res = res * radix + c; - flg = 1; /* res is valid */ - break; - default: - goto out1; - } - } - while (++i < len); - out1: - - /* if true, then we did see a digit above, and res is valid */ - if (i == len) - goto done; - - /* By here, must have seen a digit, - or must have next char be a `.' with radix==10 */ - if (!flg) - if (!(str[i] == '.' && radix == 10)) - return SCM_BOOL_F; - - while (str[i] == '#') - { /* optional sharps */ - res *= radix; - if (++i == len) - goto done; - } - - if (str[i] == '/') - { - while (++i < len) - { - switch (c = str[i]) - { - case DIGITS: - c = c - '0'; - goto accum2; - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - c = c - 'A' + 10; - goto accum2; - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - c = c - 'a' + 10; - accum2: - if (c >= radix) - return SCM_BOOL_F; - tmp = tmp * radix + c; - break; - default: - goto out2; - } - } - out2: - if (tmp == 0.0) - return SCM_BOOL_F; /* `slash zero' not allowed */ - if (i < len) - while (str[i] == '#') - { /* optional sharps */ - tmp *= radix; - if (++i == len) - break; - } - res /= tmp; - goto done; - } - - if (str[i] == '.') - { /* decimal point notation */ - if (radix != 10) - return SCM_BOOL_F; /* must be radix 10 */ - while (++i < len) - { - switch (c = str[i]) - { - case DIGITS: - point--; - res = res * 10.0 + c - '0'; - flg = 1; - break; - default: - goto out3; - } - } - out3: - if (!flg) - return SCM_BOOL_F; /* no digits before or after decimal point */ - if (i == len) - goto adjust; - while (str[i] == '#') - { /* ignore remaining sharps */ - if (++i == len) - goto adjust; - } - } - - switch (str[i]) - { /* exponent */ - case 'd': - case 'D': - case 'e': - case 'E': - case 'f': - case 'F': - case 'l': - case 'L': - case 's': - case 'S': - { - int expsgn = 1, expon = 0; - if (radix != 10) - return SCM_BOOL_F; /* only in radix 10 */ - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - switch (str[i]) - { - case '-': - expsgn = (-1); - case '+': - if (++i == len) - return SCM_BOOL_F; /* bad exponent */ - } - if (str[i] < '0' || str[i] > '9') - return SCM_BOOL_F; /* bad exponent */ - do - { - switch (c = str[i]) - { - case DIGITS: - expon = expon * 10 + c - '0'; - if (expon > SCM_MAXEXP) - scm_out_of_range ("string->number", SCM_MAKINUM (expon)); - break; - default: - goto out4; - } - } - while (++i < len); - out4: - point += expsgn * expon; - } - } - - adjust: - if (point >= 0) - while (point--) - res *= 10.0; - else -#ifdef _UNICOS - while (point++) - res *= 0.1; -#else - while (point++) - res /= 10.0; -#endif - - done: - /* at this point, we have a legitimate floating point result */ - if (lead_sgn == -1.0) - res = -res; - if (i == len) - return scm_make_real (res); - - if (str[i] == 'i' || str[i] == 'I') - { /* pure imaginary number */ - if (lead_sgn == 0.0) - return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) - return SCM_BOOL_F; /* `i' not last character */ - return scm_make_complex (0.0, res); - } - - switch (str[i++]) - { - case '-': - lead_sgn = -1.0; - break; - case '+': - lead_sgn = 1.0; - break; - case '@': - { /* polar input for complex number */ - /* get a `real' for scm_angle */ - second = scm_istr2flo (&str[i], (long) (len - i), radix); - if (!SCM_SLOPPY_INEXACTP (second)) - return SCM_BOOL_F; /* not `real' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `real' */ - tmp = SCM_REAL_VALUE (second); - return scm_make_complex (res * cos (tmp), res * sin (tmp)); - } - default: - return SCM_BOOL_F; - } - - /* at this point, last char must be `i' */ - if (str[len - 1] != 'i' && str[len - 1] != 'I') + if (idx == len) return SCM_BOOL_F; - /* handles `x+i' and `x-i' */ - if (i == (len - 1)) - return scm_make_complex (res, lead_sgn); - /* get a `ureal' for complex part */ - second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix); - if (!SCM_INEXACTP (second)) - return SCM_BOOL_F; /* not `ureal' */ - if (SCM_SLOPPY_COMPLEXP (second)) - return SCM_BOOL_F; /* not `ureal' */ - tmp = SCM_REAL_VALUE (second); - if (tmp < 0.0) - return SCM_BOOL_F; /* not `ureal' */ - return scm_make_complex (res, (lead_sgn * tmp)); + + c = mem[idx]; + if (!isxdigit (c)) + return SCM_BOOL_F; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + return SCM_BOOL_F; + + idx++; + result = SCM_MAKINUM (digit_value); + while (idx != len) + { + char c = mem[idx]; + if (isxdigit (c)) + { + if (hash_seen) + return SCM_BOOL_F; + digit_value = XDIGIT2UINT (c); + if (digit_value >= radix) + return SCM_BOOL_F; + } + else if (c == '#') + { + hash_seen = 1; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / radix < shift) + { + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + shift = radix; + add = digit_value; + } + else + { + shift = shift * radix; + add = add * radix + digit_value; + } + }; + + if (shift > 1) + result = scm_product (result, SCM_MAKINUM (shift)); + if (add > 0) + result = scm_sum (result, SCM_MAKINUM (add)); + + *p_idx = idx; + if (hash_seen) + *p_exactness = INEXACT; + + return result; } +/* R5RS, section 7.1.1, lexical structure of numbers: . Only + * covers the parts of the rules that start at a potential point. The value + * of the digits up to the point have been parsed by the caller and are given + * in variable prepoint. The content of *p_exactness indicates, whether a + * hash has already been seen in the digits before the point. + */ + +/* In non ASCII-style encodings the following macro might not work. */ +#define DIGIT2UINT(d) ((d) - '0') + +static SCM +mem2decimal_from_point (SCM prepoint, const char* mem, size_t len, + unsigned int *p_idx, enum t_exactness *p_exactness) +{ + unsigned int idx = *p_idx; + enum t_exactness x = *p_exactness; + SCM big_shift = SCM_MAKINUM (1); + SCM big_add = SCM_MAKINUM (0); + SCM result; + + if (idx == len) + return prepoint; + + if (mem[idx] == '.') + { + scm_t_bits shift = 1; + scm_t_bits add = 0; + unsigned int digit_value; + + idx++; + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + if (x == INEXACT) + return SCM_BOOL_F; + else + digit_value = DIGIT2UINT (c); + } + else if (c == '#') + { + x = INEXACT; + digit_value = 0; + } + else + break; + + idx++; + if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + big_add = scm_product (big_add, SCM_MAKINUM (shift)); + if (add > 0) + big_add = scm_sum (big_add, SCM_MAKINUM (add)); + + shift = 10; + add = digit_value; + } + else + { + shift = shift * 10; + add = add * 10 + digit_value; + } + }; + + if (add > 0) + { + big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); + big_add = scm_product (big_add, SCM_MAKINUM (shift)); + big_add = scm_sum (big_add, SCM_MAKINUM (add)); + } + + /* We've seen a decimal point, thus the value is implicitly inexact. */ + x = INEXACT; + } + + big_add = scm_divide (big_add, big_shift); + result = scm_sum (prepoint, big_add); + + if (idx != len) + { + int sign = 1; + unsigned int start; + char c; + int exponent; + SCM e; + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + + switch (mem[idx]) + { + case 'd': case 'D': + case 'e': case 'E': + case 'f': case 'F': + case 'l': case 'L': + case 's': case 'S': + idx++; + start = idx; + c = mem[idx]; + if (c == '-') + { + idx++; + sign = -1; + c = mem[idx]; + } + else if (c == '+') + { + idx++; + sign = 1; + c = mem[idx]; + } + else + sign = 1; + + if (!isdigit (c)) + return SCM_BOOL_F; + + idx++; + exponent = DIGIT2UINT (c); + while (idx != len) + { + char c = mem[idx]; + if (isdigit (c)) + { + idx++; + if (exponent <= SCM_MAXEXP) + exponent = exponent * 10 + DIGIT2UINT (c); + } + else + break; + } + + if (exponent > SCM_MAXEXP) + { + size_t exp_len = idx - start; + SCM exp_string = scm_mem2string (&mem[start], exp_len); + SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); + scm_out_of_range ("string->number", exp_num); + } + + e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent)); + if (sign == 1) + result = scm_product (result, e); + else + result = scm_divide (result, e); + + /* We've seen an exponent, thus the value is implicitly inexact. */ + x = INEXACT; + + break; + + default: + break; + } + } + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; + + return result; +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2ureal (const char* mem, size_t len, unsigned int *p_idx, + unsigned int radix, enum t_exactness *p_exactness) +{ + unsigned int idx = *p_idx; + + if (idx == len) + return SCM_BOOL_F; + + if (mem[idx] == '.') + { + if (radix != 10) + return SCM_BOOL_F; + else if (idx + 1 == len) + return SCM_BOOL_F; + else if (!isdigit (mem[idx + 1])) + return SCM_BOOL_F; + else + return mem2decimal_from_point (SCM_MAKINUM (0), mem, len, + p_idx, p_exactness); + } + else + { + enum t_exactness x = EXACT; + SCM uinteger; + SCM result; + + uinteger = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (uinteger)) + return SCM_BOOL_F; + + if (idx == len) + result = uinteger; + else if (mem[idx] == '/') + { + SCM divisor; + + idx++; + + divisor = mem2uinteger (mem, len, &idx, radix, &x); + if (SCM_FALSEP (divisor)) + return SCM_BOOL_F; + + result = scm_divide (uinteger, divisor); + } + else if (radix == 10) + { + result = mem2decimal_from_point (uinteger, mem, len, &idx, &x); + if (SCM_FALSEP (result)) + return SCM_BOOL_F; + } + else + result = uinteger; + + *p_idx = idx; + if (x == INEXACT) + *p_exactness = x; + + return result; + } +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +static SCM +mem2complex (const char* mem, size_t len, unsigned int idx, + unsigned int radix, enum t_exactness *p_exactness) +{ + char c; + int sign = 0; + SCM ureal; + + if (idx == len) + return SCM_BOOL_F; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; + } + + if (idx == len) + return SCM_BOOL_F; + + ureal = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (ureal)) + { + /* input must be either +i or -i */ + + if (sign == 0) + return SCM_BOOL_F; + + if (mem[idx] == 'i' || mem[idx] == 'I') + { + idx++; + if (idx != len) + return SCM_BOOL_F; + + return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign)); + } + else + return SCM_BOOL_F; + } + else + { + if (sign == -1) + ureal = scm_difference (ureal, SCM_UNDEFINED); + + if (idx == len) + return ureal; + + c = mem[idx]; + switch (c) + { + case 'i': case 'I': + /* either +i or -i */ + + idx++; + if (sign == 0) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + return scm_make_rectangular (SCM_MAKINUM (0), ureal); + + case '@': + /* polar input: @. */ + + idx++; + if (idx == len) + return SCM_BOOL_F; + else + { + int sign; + SCM angle; + SCM result; + + c = mem[idx]; + if (c == '+') + { + idx++; + sign = 1; + } + else if (c == '-') + { + idx++; + sign = -1; + } + else + sign = 1; + + angle = mem2ureal (mem, len, &idx, radix, p_exactness); + if (SCM_FALSEP (angle)) + return SCM_BOOL_F; + if (idx != len) + return SCM_BOOL_F; + + if (sign == -1) + angle = scm_difference (angle, SCM_UNDEFINED); + + result = scm_make_polar (ureal, angle); + return result; + } + case '+': + case '-': + /* expecting input matching [+-]?i */ + + idx++; + if (idx == len) + return SCM_BOOL_F; + else + { + int sign = (c == '+') ? 1 : -1; + SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness); + SCM result; + + if (SCM_FALSEP (imag)) + imag = SCM_MAKINUM (sign); + + if (idx == len) + return SCM_BOOL_F; + if (mem[idx] != 'i' && mem[idx] != 'I') + return SCM_BOOL_F; + + idx++; + if (idx != len) + return SCM_BOOL_F; + + if (sign == -1) + imag = scm_difference (imag, SCM_UNDEFINED); + result = scm_make_rectangular (ureal, imag); + return result; + } + default: + return SCM_BOOL_F; + } + } +} + + +/* R5RS, section 7.1.1, lexical structure of numbers: */ + +enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16}; SCM -scm_istring2number (char *str, long len, long radix) +scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) { - int i = 0; - char ex = 0; - char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ - SCM res; - if (len == 1) - if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ - return SCM_BOOL_F; + unsigned int idx = 0; + unsigned int radix = NO_RADIX; + enum t_exactness forced_x = NO_EXACTNESS; + enum t_exactness implicit_x = EXACT; + SCM result; - while ((len - i) >= 2 && str[i] == '#' && ++i) - switch (str[i++]) - { - case 'b': - case 'B': - if (rx_p++) - return SCM_BOOL_F; - radix = 2; - break; - case 'o': - case 'O': - if (rx_p++) - return SCM_BOOL_F; - radix = 8; - break; - case 'd': - case 'D': - if (rx_p++) - return SCM_BOOL_F; - radix = 10; - break; - case 'x': - case 'X': - if (rx_p++) - return SCM_BOOL_F; - radix = 16; - break; - case 'i': - case 'I': - if (ex_p++) - return SCM_BOOL_F; - ex = 2; - break; - case 'e': - case 'E': - if (ex_p++) - return SCM_BOOL_F; - ex = 1; - break; - default: - return SCM_BOOL_F; - } - - switch (ex) + /* R5RS, section 7.1.1, lexical structure of numbers: */ + while (idx + 2 < len && mem[idx] == '#') { - case 1: - return scm_istr2int (&str[i], len - i, radix); - case 0: - res = scm_istr2int (&str[i], len - i, radix); - if (!SCM_FALSEP (res)) - return res; - case 2: - return scm_istr2flo (&str[i], len - i, radix); + switch (mem[idx + 1]) + { + case 'b': case 'B': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DUAL; + break; + case 'd': case 'D': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = DEC; + break; + case 'i': case 'I': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = INEXACT; + break; + case 'e': case 'E': + if (forced_x != NO_EXACTNESS) + return SCM_BOOL_F; + forced_x = EXACT; + break; + case 'o': case 'O': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = OCT; + break; + case 'x': case 'X': + if (radix != NO_RADIX) + return SCM_BOOL_F; + radix = HEX; + break; + default: + return SCM_BOOL_F; + } + idx += 2; + } + + /* R5RS, section 7.1.1, lexical structure of numbers: */ + if (radix == NO_RADIX) + result = mem2complex (mem, len, idx, default_radix, &implicit_x); + else + result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x); + + if (SCM_FALSEP (result)) + return SCM_BOOL_F; + + switch (forced_x) + { + case EXACT: + if (SCM_INEXACTP (result)) + /* FIXME: This may change the value. */ + return scm_inexact_to_exact (result); + else + return result; + case INEXACT: + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + case NO_EXACTNESS: + default: + if (implicit_x == INEXACT) + { + if (SCM_INEXACTP (result)) + return result; + else + return scm_exact_to_inexact (result); + } + else + return result; } - return SCM_BOOL_F; } @@ -2760,12 +2812,14 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, int base; SCM_VALIDATE_STRING (1, string); SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); - answer = scm_istring2number (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string), - base); + answer = scm_i_mem2number (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string), + base); return scm_return_first (answer, string); } #undef FUNC_NAME + + /*** END strs->nums ***/ @@ -2860,7 +2914,7 @@ SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, return SCM_BOOL_T; } else if (SCM_IMP (x)) { return SCM_BOOL_F; - } else if (SCM_SLOPPY_REALP (x)) { + } else if (SCM_REALP (x)) { return SCM_BOOL_T; } else if (SCM_BIGP (x)) { return SCM_BOOL_T; @@ -2884,9 +2938,9 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, return SCM_BOOL_F; if (SCM_BIGP (x)) return SCM_BOOL_T; - if (!SCM_SLOPPY_INEXACTP (x)) + if (!SCM_INEXACTP (x)) return SCM_BOOL_F; - if (SCM_SLOPPY_COMPLEXP (x)) + if (SCM_COMPLEXP (x)) return SCM_BOOL_F; r = SCM_REAL_VALUE (x); if (r == floor (r)) @@ -3860,17 +3914,6 @@ scm_round (double x) } - -SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact); -/* Convert the number @var{x} to its inexact representation.\n" - */ -double -scm_exact_to_inexact (double z) -{ - return z; -} - - SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); /* "Round the number @var{x} towards minus infinity." */ @@ -4113,6 +4156,23 @@ scm_angle (SCM z) } +SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact); +/* Convert the number @var{x} to its inexact representation.\n" + */ +SCM +scm_exact_to_inexact (SCM z) +{ + if (SCM_INUMP (z)) + return scm_make_real ((double) SCM_INUM (z)); + else if (SCM_BIGP (z)) + return scm_make_real (scm_i_big2dbl (z)); + else if (SCM_INEXACTP (z)) + return z; + else + SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact); +} + + SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, (SCM z), "Return an exact number that is numerically closest to @var{z}.") diff --git a/libguile/numbers.h b/libguile/numbers.h index 7a6d6d7f1..05c2b4b21 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef NUMBERSH -#define NUMBERSH +#ifndef SCM_NUMBERS_H +#define SCM_NUMBERS_H /* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -56,7 +56,7 @@ * * SCM_INUMP applies only to values known to be Scheme objects. * In particular, SCM_INUMP (SCM_CAR (x)) is valid only if x is known - * to be a SCM_CONSP. If x is only known to be a SCM_NIMP, + * to be a SCM_CONSP. If x is only known to be a non-immediate, * SCM_INUMP (SCM_CAR (x)) can give wrong answers. */ @@ -123,9 +123,9 @@ #define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) #define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real) #define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex) -#define SCM_INEXACTP(x) (SCM_NIMP (x) && SCM_TYP16S (x) == scm_tc16_real) -#define SCM_REALP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_real) -#define SCM_COMPLEXP(x) (SCM_NIMP (x) && SCM_TYP16 (x) == scm_tc16_complex) +#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_TYP16S (x) == scm_tc16_real) +#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real) +#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex) #define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real) #define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x)) @@ -264,9 +264,7 @@ extern SCM scm_number_to_string (SCM x, SCM radix); extern int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate); extern int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate); extern int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate); -extern SCM scm_istr2int (char *str, long len, long radix); -extern SCM scm_istr2flo (char *str, long len, long radix); -extern SCM scm_istring2number (char *str, long len, long radix); +extern SCM scm_i_mem2number (const char *mem, size_t len, unsigned int radix); extern SCM scm_string_to_number (SCM str, SCM radix); extern SCM scm_make_real (double x); extern SCM scm_make_complex (double x, double y); @@ -297,7 +295,6 @@ extern double scm_acosh (double x); extern double scm_atanh (double x); extern double scm_truncate (double x); extern double scm_round (double x); -extern double scm_exact_to_inexact (double z); extern SCM scm_sys_expt (SCM z1, SCM z2); extern SCM scm_sys_atan2 (SCM z1, SCM z2); extern SCM scm_make_rectangular (SCM z1, SCM z2); @@ -306,6 +303,7 @@ extern SCM scm_real_part (SCM z); extern SCM scm_imag_part (SCM z); extern SCM scm_magnitude (SCM z); extern SCM scm_angle (SCM z); +extern SCM scm_exact_to_inexact (SCM z); extern SCM scm_inexact_to_exact (SCM z); extern SCM scm_trunc (SCM x); extern SCM scm_i_dbl2big (double d); @@ -355,7 +353,7 @@ extern unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos, extern void scm_init_numbers (void); -#endif /* NUMBERSH */ +#endif /* SCM_NUMBERS_H */ /* Local Variables: diff --git a/libguile/read.c b/libguile/read.c index 131999f46..0387c293d 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -416,8 +416,13 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) return SCM_MAKE_CHAR (c); if (c >= '0' && c < '8') { - p = scm_istr2int (SCM_STRING_CHARS (*tok_buf), (long) j, 8); - if (!SCM_FALSEP (p)) + /* Dirk:FIXME:: This type of character syntax is not R5RS + * compliant. Further, it should be verified that the constant + * does only consist of octal digits. Finally, it should be + * checked whether the resulting fixnum is in the range of + * characters. */ + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 8); + if (SCM_INUMP (p)) return SCM_MAKE_CHAR (SCM_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) @@ -503,27 +508,31 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) SCM_STRING_CHARS (*tok_buf)[j] = 0; return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); - case'0':case '1':case '2':case '3':case '4': - case '5':case '6':case '7':case '8':case '9': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '.': case '-': case '+': num: - j = scm_read_token (c, tok_buf, port, 0); - p = scm_istring2number (SCM_STRING_CHARS (*tok_buf), (long) j, 10L); - if (!SCM_FALSEP (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_getc (port) == '(')) - { - scm_ungetc ('(', port); - c = SCM_STRING_CHARS (*tok_buf)[1]; - goto callshrp; - } - SCM_MISC_ERROR ("unknown # object", SCM_EOL); - } - goto tok; + j = scm_read_token (c, tok_buf, port, 0); + if (j == 1 && (c == '+' || c == '-')) + /* Shortcut: Detected symbol '+ or '- */ + goto tok; + + p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 10); + if (!SCM_FALSEP (p)) + return p; + if (c == '#') + { + if ((j == 2) && (scm_getc (port) == '(')) + { + scm_ungetc ('(', port); + c = SCM_STRING_CHARS (*tok_buf)[1]; + goto callshrp; + } + SCM_MISC_ERROR ("unknown # object", SCM_EOL); + } + goto tok; case ':': if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) From 88c4ba2aefd9175068e479d87d6e69e83c9c08d5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 31 Jul 2001 14:08:04 +0000 Subject: [PATCH 29/39] * boot-9.scm (process-define-module): Bug fixed. --- ice-9/ChangeLog | 4 ++++ ice-9/boot-9.scm | 10 +++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 449f5327f..e37b870bf 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2001-07-31 Keisuke Nishida + + * boot-9.scm (process-define-module): Bug fixed. + 2001-07-24 Marius Vollmer * syncase.scm (psyncomp): Removed, it is now in diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d1ac9a7f1..67e20c523 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1747,14 +1747,14 @@ (unrecognized kws)) (let* ((interface-args (cadr kws)) (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) 'use-syntax) - (or (symbol? (car spec)) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) (error "invalid module name for use-syntax" - spec)) + (car interface-args))) (set-module-transformer! module - (module-ref interface (car - (last-pair (car interface-args))) + (module-ref interface + (car (last-pair (car interface-args))) #f))) (loop (cddr kws) (cons interface reversed-interfaces) From 9be745030e215de6a0ee5e14e0d1e5c0398c704f Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Tue, 31 Jul 2001 21:42:24 +0000 Subject: [PATCH 30/39] * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly accounting for the (char-set-union cs2...) in the spec. i.e., (char-set-diff+intersection a) -> copy-of-a, empty-set and the following are equivalent: (char-set-diff+intersection a (char-set #\a) (char-set #\b)) (char-set-diff+intersection a (char-set #\a #\b)) (scm_char_set_xor_x): disabled the side-effecting code, since it gives inconsistent results to scm_char_set_xor for the case (char-set-xor! a a a). (scm_char_set_diff_plus_intersection_x): added cs2 argument, since two arguments are compulsory in final spec. also similar changes as for scm_char_set_diff_plus_intersection. * srfi-14.h (scm_char_set_diff_plus_intersection_x): added cs2. --- srfi/ChangeLog | 18 +++++++++++++++ srfi/srfi-14.c | 59 +++++++++++++++++++++++++++++++++++++------------- srfi/srfi-14.h | 2 +- 3 files changed, 63 insertions(+), 16 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index b287451b2..109ff9940 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,21 @@ +2001-07-31 Gary Houston + + * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly + accounting for the (char-set-union cs2...) in the spec. i.e., + (char-set-diff+intersection a) -> copy-of-a, empty-set + and the following are equivalent: + (char-set-diff+intersection a (char-set #\a) (char-set #\b)) + (char-set-diff+intersection a (char-set #\a #\b)) + + (scm_char_set_xor_x): disabled the side-effecting code, since it + gives inconsistent results to scm_char_set_xor for the case + (char-set-xor! a a a). + + (scm_char_set_diff_plus_intersection_x): added cs2 argument, since + two arguments are compulsory in final spec. also similar changes + as for scm_char_set_diff_plus_intersection. + * srfi-14.h (scm_char_set_diff_plus_intersection_x): added cs2. + 2001-07-22 Gary Houston * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 8a7a7321a..52d9419e3 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1194,22 +1194,25 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 SCM_VALIDATE_REST_ARGUMENT (rest); res1 = scm_char_set_copy (cs1); - res2 = scm_char_set_copy (cs1); + res2 = make_char_set (FUNC_NAME); p = (long *) SCM_SMOB_DATA (res1); q = (long *) SCM_SMOB_DATA (res2); while (!SCM_NULLP (rest)) { int k; SCM cs = SCM_CAR (rest); + long *r; + SCM_VALIDATE_SMOB (c, cs, charset); c++; - rest = SCM_CDR (rest); + r = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < LONGS_PER_CHARSET; k++) { - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; } + rest = SCM_CDR (rest); } return scm_values (scm_list_2 (res1, res2)); } @@ -1322,6 +1325,15 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, "Return the exclusive-or of all argument character sets.") #define FUNC_NAME s_scm_char_set_xor_x { + /* a side-effecting variant should presumably give consistent results: + (define a (char-set #\a)) + (char-set-xor a a a) -> char set #\a + (char-set-xor! a a a) -> char set #\a + */ + return scm_char_set_xor (scm_cons (cs1, rest)); + +#if 0 + /* this would give (char-set-xor! a a a) -> empty char set. */ int c = 2; long * p; @@ -1341,41 +1353,58 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; } return cs1; +#endif } #undef FUNC_NAME -SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1, - (SCM cs1, SCM rest), +SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, + (SCM cs1, SCM cs2, SCM rest), "Return the difference and the intersection of all argument\n" "character sets.") #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x { - int c = 2; - SCM res2; + int c = 3; long * p, * q; + int k; SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_SMOB (2, cs2, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - res2 = scm_char_set_copy (cs1); p = (long *) SCM_SMOB_DATA (cs1); - q = (long *) SCM_SMOB_DATA (res2); + q = (long *) SCM_SMOB_DATA (cs2); + if (p == q) + { + /* (char-set-diff+intersection! a a ...): can't share storage, + but we know the answer without checking for further + arguments. */ + return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); + } + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + long t = p[k]; + + p[k] &= ~q[k]; + q[k] = t & q[k]; + } while (!SCM_NULLP (rest)) { - int k; SCM cs = SCM_CAR (rest); + long *r; + SCM_VALIDATE_SMOB (c, cs, charset); c++; - rest = SCM_CDR (rest); + r = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < LONGS_PER_CHARSET; k++) { - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - q[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; } + rest = SCM_CDR (rest); } - return scm_values (scm_list_2 (cs1, res2)); + return scm_values (scm_list_2 (cs1, cs2)); } #undef FUNC_NAME diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 02e74f765..3989aadcc 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -111,6 +111,6 @@ SCM scm_char_set_union_x (SCM cs1, SCM rest); SCM scm_char_set_intersection_x (SCM cs1, SCM rest); SCM scm_char_set_difference_x (SCM cs1, SCM rest); SCM scm_char_set_xor_x (SCM cs1, SCM rest); -SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM rest); +SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); #endif /* SCM_SRFI_14_H */ From 8c914f6b696392a0e451e060cab9c66ca00f25d7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 05:09:30 +0000 Subject: [PATCH 31/39] In boilerplate, use -l$0. Thanks to Daniel Skarda. --- scripts/PROGRAM | 2 +- scripts/README | 2 +- scripts/display-commentary | 2 +- scripts/doc-snarf | 2 +- scripts/generate-autoload | 2 +- scripts/punify | 2 +- scripts/read-scheme-source | 2 +- scripts/snarf-check-and-output-texi | 2 +- scripts/use2dot | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index 3511ccdfc..69a655949 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; PROGRAM --- Does something diff --git a/scripts/README b/scripts/README index c1a3ef998..56dd286fb 100644 --- a/scripts/README +++ b/scripts/README @@ -65,7 +65,7 @@ Programs must follow the "executable module" convention, documented here: #!/bin/sh main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')' - exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" + exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# Following these conventions allows the program file to be used as module diff --git a/scripts/display-commentary b/scripts/display-commentary index 1eeb842d8..21ce2c03a 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; display-commentary --- As advertized diff --git a/scripts/doc-snarf b/scripts/doc-snarf index 941682e78..5b72fc5f8 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; doc-snarf --- Extract documentation from source files diff --git a/scripts/generate-autoload b/scripts/generate-autoload index 83fa1f3f2..942822ead 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; generate-autoload --- Display define-module form with autoload info diff --git a/scripts/punify b/scripts/punify index 1cc318fb6..699f3e2ff 100755 --- a/scripts/punify +++ b/scripts/punify @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts punify)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; punify --- Display Scheme code w/o unnecessary comments / whitespace diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 48e96058a..1a9c0e59b 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index e3c84f540..bc1287b38 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)" -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; snarf-check-and-output-texi --- called by the doc snarfer. diff --git a/scripts/use2dot b/scripts/use2dot index d2cb64695..6f2901107 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')' -exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;; use2dot --- Display module dependencies as a DOT specification From 9ebd6e62811219fdbcb04efff439ff67116ce920 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 05:10:12 +0000 Subject: [PATCH 32/39] *** empty log message *** --- scripts/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index b25efc2f2..0a8dab25a 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,11 @@ +2001-08-01 Thien-Thi Nguyen + + * PROGRAM, README, display-commentary, doc-snarf, + generate-autoload, punify, read-scheme-source, + snarf-check-and-output-texi, use2dot: + In boilerplate, use -l$0. + Thanks to Daniel Skarda. + 2001-07-22 Thien-Thi Nguyen * generate-autoload (autoload-info): From bba2d1908ab2104ad6de36a105466ce2936f274f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 09:57:01 +0000 Subject: [PATCH 33/39] (run-test-exception): Add special handling for `error'-generated exceptions, which pass key `misc-error' and leave messages unformatted. --- test-suite/lib.scm | 79 ++++++++++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 34 deletions(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 1084e641d..a5a44fa8a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,16 +1,16 @@ ;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001 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 ;;;; 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -37,7 +37,7 @@ ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts - make-log-reporter + make-log-reporter full-reporter user-reporter format-test-name) @@ -75,12 +75,12 @@ ;;;; ;;;; Convenience macros for tests expected to pass or fail ;;;; -;;;; * (pass-if name body) is a short form for +;;;; * (pass-if name body) is a short form for ;;;; (run-test name #t (lambda () body)) -;;;; * (expect-fail name body) is a short form for +;;;; * (expect-fail name body) is a short form for ;;;; (run-test name #f (lambda () body)) ;;;; -;;;; For example: +;;;; For example: ;;;; ;;;; (pass-if "integer addition" (= 2 (+ 1 1))) ;;;; @@ -118,23 +118,23 @@ ;;;; - Test names can be compared with EQUAL?. ;;;; - Test names can be reliably stored and retrieved with the standard WRITE ;;;; and READ procedures; doing so preserves their identity. -;;;; +;;;; ;;;; For example: -;;;; +;;;; ;;;; (pass-if "simple addition" (= 4 (+ 2 2))) -;;;; +;;;; ;;;; In that case, the test name is the list ("simple addition"). ;;;; ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish ;;;; a prefix for the names of all tests whose results are reported ;;;; within their dynamic scope. For example: -;;;; +;;;; ;;;; (begin ;;;; (with-test-prefix "basic arithmetic" ;;;; (pass-if "addition" (= (+ 2 2) 4)) ;;;; (pass-if "subtraction" (= (- 4 2) 2))) ;;;; (pass-if "multiplication" (= (* 2 2) 4))) -;;;; +;;;; ;;;; In that example, the three test names are: ;;;; ("basic arithmetic" "addition"), ;;;; ("basic arithmetic" "subtraction"), and @@ -142,7 +142,7 @@ ;;;; ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends ;;;; a new element to the current prefix: -;;;; +;;;; ;;;; (with-test-prefix "arithmetic" ;;;; (with-test-prefix "addition" ;;;; (pass-if "integer" (= (+ 2 2) 4)) @@ -150,7 +150,7 @@ ;;;; (with-test-prefix "subtraction" ;;;; (pass-if "integer" (= (- 2 2) 0)) ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) -;;;; +;;;; ;;;; The four test names here are: ;;;; ("arithmetic" "addition" "integer") ;;;; ("arithmetic" "addition" "complex") @@ -160,7 +160,7 @@ ;;;; To print a name for a human reader, we DISPLAY its elements, ;;;; separated by ": ". So, the last set of test names would be ;;;; reported as: -;;;; +;;;; ;;;; arithmetic: addition: integer ;;;; arithmetic: addition: complex ;;;; arithmetic: subtraction: integer @@ -173,16 +173,16 @@ ;;;; REPORTERS -;;;; +;;;; ;;;; A reporter is a function which we apply to each test outcome. ;;;; Reporters can log results, print interesting results to the ;;;; standard output, collect statistics, etc. -;;;; +;;;; ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and ;;;; possibly additional arguments depending on RESULT; its return value ;;;; is ignored. RESULT has one of the following forms: ;;;; -;;;; pass - The test named TEST passed. +;;;; pass - The test named TEST passed. ;;;; Additional arguments are ignored. ;;;; upass - The test named TEST passed unexpectedly. ;;;; Additional arguments are ignored. @@ -195,7 +195,7 @@ ;;;; tested because something else went wrong. ;;;; Additional arguments are ignored. ;;;; untested - The test named TEST was not actually performed, for -;;;; example because the test case is not complete yet. +;;;; example because the test case is not complete yet. ;;;; Additional arguments are ignored. ;;;; unsupported - The test named TEST requires some feature that is not ;;;; available in the configured testing environment. @@ -259,16 +259,16 @@ (throw 'unresolved))) (lambda (key . args) (case key - ((pass) + ((pass) (report (if expect-pass 'pass 'upass) test-name)) - ((fail) + ((fail) (report (if expect-pass 'fail 'xfail) test-name)) - ((unresolved untested unsupported) + ((unresolved untested unsupported) (report key test-name)) - ((quit) + ((quit) (report 'unresolved test-name) (quit)) - (else + (else (report 'error test-name (cons key args)))))) (set! test-running #f)))) (set! run-test local-run-test)) @@ -287,10 +287,21 @@ (lambda () (stack-catch (car exception) (lambda () (thunk) #f) - (lambda (key proc message . rest) - (if (not (string-match (cdr exception) message)) - (apply throw key proc message rest) - #t)))))) + (lambda (key proc message . rest) + (cond + ;; handle explicit key + ((string-match (cdr exception) message) + #t) + ;; handle `(error ...)' which uses `misc-error' for key and doesn't + ;; yet format the message and args (we have to do it here). + ((and (eq? 'misc-error (car exception)) + (list? rest) + (string-match (cdr exception) + (apply simple-format #f message (car rest)))) + #t) + ;; unhandled; throw again + (else + (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. (defmacro pass-if-exception (name exception body . rest) @@ -344,7 +355,7 @@ ;;;; REPORTERS -;;;; +;;;; ;;; The global list of reporters. (define reporters '()) @@ -385,7 +396,7 @@ ;;;; User reporters write interesting test results to the standard output. ;;; The complete list of possible test results. -(define result-tags +(define result-tags '((pass "PASS" "passes: ") (fail "FAIL" "failures: ") (upass "UPASS" "unexpected passes: ") @@ -396,7 +407,7 @@ (error "ERROR" "errors: "))) ;;; The list of important test results. -(define important-result-tags +(define important-result-tags '(fail upass unresolved error)) ;;; Display a single test result in formatted form to the given port @@ -426,9 +437,9 @@ (list (lambda (result name . args) (let ((pair (assq result counts))) - (if pair + (if pair (set-cdr! pair (+ 1 (cdr pair))) - (error "count-reporter: unexpected test result: " + (error "count-reporter: unexpected test result: " (cons result (cons name args)))))) (lambda () (append counts '()))))) @@ -436,7 +447,7 @@ ;;; Print a count reporter's results nicely. Pass this function the value ;;; returned by a count reporter's RESULTS procedure. (define (print-counts results . port?) - (let ((port (if (pair? port?) + (let ((port (if (pair? port?) (car port?) (current-output-port)))) (newline port) From 9b974335964eb26d0920b368ba717dd98c9af1b9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 1 Aug 2001 10:01:51 +0000 Subject: [PATCH 34/39] *** empty log message *** --- AUTHORS | 4 ++++ test-suite/ChangeLog | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/AUTHORS b/AUTHORS index b4ec70fa5..c1dd0b3ed 100644 --- a/AUTHORS +++ b/AUTHORS @@ -234,6 +234,10 @@ In the subdirectory doc, changes to: intro.texi preface.texi scheme-modules.texi scheme-procedures.texi scheme-scheduling.texi +In the subdirectory test-suite, changes to: + guile-test lib.scm +In the subdirectory test-suite/tests, changes to: + exceptions.test eval.test Robert Merkel: In the subdirectory doc, co-wrote: diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0aa2ad502..90bab7d41 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2001-08-01 Thien-Thi Nguyen + + * lib.scm (run-test-exception): Add special handling for + `error'-generated exceptions, which pass key `misc-error' and + leave messages unformatted. + 2001-07-18 Martin Grabmueller * tests/alist.test, tests/bit-operations.test, From 29aa75ea12ceca938d699d3383d7e2e48fd4a1d4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 1 Aug 2001 16:50:34 +0000 Subject: [PATCH 35/39] Wrote more informative change log. --- ice-9/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e37b870bf..93d053506 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,6 +1,7 @@ 2001-07-31 Keisuke Nishida - * boot-9.scm (process-define-module): Bug fixed. + * boot-9.scm (process-define-module): Fixed a bug that did not + handle :use-syntax correctly. 2001-07-24 Marius Vollmer From ccbd262bd13991093e10044785c61a50e4e22a30 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:27:59 +0000 Subject: [PATCH 36/39] (scm_char_alphabetic_p, scm_char_numeric_p, scm_char_whitespace_p, scm_char_upper_case_p, scm_char_lower_case_p, scm_char_is_both_p): Do not require characters to fulfill isascii in addition to the primary predicate. --- libguile/chars.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 229da4b35..469514715 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -186,7 +186,7 @@ SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, #define FUNC_NAME s_scm_char_alphabetic_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isalpha(SCM_CHAR(chr))); + return SCM_BOOL(isalpha(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -197,7 +197,7 @@ SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, #define FUNC_NAME s_scm_char_numeric_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isdigit(SCM_CHAR(chr))); + return SCM_BOOL(isdigit(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -208,7 +208,7 @@ SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, #define FUNC_NAME s_scm_char_whitespace_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isspace(SCM_CHAR(chr))); + return SCM_BOOL(isspace(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -221,7 +221,7 @@ SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, #define FUNC_NAME s_scm_char_upper_case_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && isupper(SCM_CHAR(chr))); + return SCM_BOOL(isupper(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -233,7 +233,7 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, #define FUNC_NAME s_scm_char_lower_case_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && islower(SCM_CHAR(chr))); + return SCM_BOOL(islower(SCM_CHAR(chr))); } #undef FUNC_NAME @@ -247,7 +247,7 @@ SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, #define FUNC_NAME s_scm_char_is_both_p { SCM_VALIDATE_CHAR (1,chr); - return SCM_BOOL(isascii(SCM_CHAR(chr)) && (isupper(SCM_CHAR(chr)) || islower(SCM_CHAR(chr)))); + return SCM_BOOL((isupper(SCM_CHAR(chr)) || islower(SCM_CHAR(chr)))); } #undef FUNC_NAME From 915bd26388c4f2196daf8f756b0615f44597d8f3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:28:29 +0000 Subject: [PATCH 37/39] Added `--disable-linuxthreads' option and do not define GUILE_PTHREAD_COMPAT nor link with -lpthread when it is given. Thanks to Cris Cramer! --- configure.in | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index 69656d4a6..532f0ccfc 100644 --- a/configure.in +++ b/configure.in @@ -558,8 +558,12 @@ if test "${THREAD_PACKAGE}" != "" ; then AC_DEFINE(GUILE_ISELECT, 1) fi - ## Workaround for linuxthreads (currently disabled) - if test $host_os = linux-gnu; then + AC_ARG_ENABLE(linuxthreads, + [ --disable-linuxthreads disable linuxthreads workaround],, + enable_linuxthreads=yes) + + ## Workaround for linuxthreads (optionally disabled) + if test $host_os = linux-gnu -a "$enable_linuxthreads" = yes; then AC_DEFINE(GUILE_PTHREAD_COMPAT, 1) AC_CHECK_LIB(pthread, main) fi From c1151355d21fd050541198e31eafb098f119b7a6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 1 Aug 2001 21:28:45 +0000 Subject: [PATCH 38/39] *** empty log message *** --- ChangeLog | 6 + INSTALL | 425 --------------------------------------------- libguile/ChangeLog | 8 + 3 files changed, 14 insertions(+), 425 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1bd7fc4e2..e537d6951 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2001-08-01 Marius Vollmer + + * configure.in: Added `--disable-linuxthreads' option and do not + define GUILE_PTHREAD_COMPAT nor link with -lpthread when it is + given. Thanks to Cris Cramer! + 2001-07-23 Marius Vollmer * Makefile.am (SUBDIRS): Build libguile before ice-9. diff --git a/INSTALL b/INSTALL index fedf6dfb1..e69de29bb 100644 --- a/INSTALL +++ b/INSTALL @@ -1,425 +0,0 @@ -Guile Installation Guide -Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. - - Permission is granted to anyone to make or distribute verbatim copies - of this document as received, in any medium, provided that the - copyright notice and permission notice are preserved, - and that the distributor grants the recipient permission - for further redistribution as permitted by this notice. - - Permission is granted to distribute modified versions - of this document, or of portions of it, - under the above conditions, provided also that they - carry prominent notices stating who last changed them, - and that any new or changed statements about the activities - of the Free Software Foundation are approved by the Foundation. - - -Brief Installation Instructions =========================================== - -To build Guile on unix, there are two basic steps: - - 1. Type "./configure", to configure the package for your system. - 2. Type "make", to build the package. - -Generic instructions for configuring and compiling GNU distributions -are included below. (For instructions how to install SLIB, the scheme -procedure library, see below.) - - -Guile can use a number of external packages such as `readline' when -they are available. Guile expects to be able to find these packages -in the default compiler setup, it does not try to make any special -arrangements itself. For example, for the `readline' package, Guile -expects to be able to find the include file , -without passing any special `-I' options to the compiler. - -If you installed an external package, and you used the --prefix -installation option to install it somewhere else than /usr/local, you -must arrange for your compiler to find it by default. If that -compiler is gcc, one convenient way of making such arrangements is to -use the --with-local-prefix option during installation, naming the -same directory as you used in the --prefix option of the package. In -particular, it is not good enough to use the same --prefix option when -you install gcc and the package; you need to use the ---with-local-prefix option as well. See the gcc documentation for -more details. - - -Special Instructions For Some Systems ===================================== - -We would like Guile to build on all systems using the simple -instructions above, but it seems that a few systems still need special -treatment. If you can send us fixes for these problems, we'd be -grateful. - -SunOS 4.1: Guile's shared library support seems to be confused, but - hey; shared libraries are confusing. You may need to configure - Guile with a command like: - ./configure --disable-shared - For more information on `--disable-shared', see below, "Flags - Accepted by Configure". - -HP/UX: GCC 2.7.2 (and maybe other versions) have trouble creating - shared libraries if they depend on any non-shared libraries. GCC - seems to have other problems as well. To work around this, we - suggest you configure Guile to use the system's C compiler: - CC=cc ./configure - -NetBSD: Perry Metzger says, "Guile will build under NetBSD only using - gmake -- the native make will not work. (gmake is in our package - system, so this will not be a problem when we packagize 1.3.)" - - -Flags Accepted by Configure =============================================== - -If you run the configure script with no arguments, it should examine -your system and set things up appropriately. However, there are a few -switches specific to Guile you may find useful in some circumstances. - - ---enable-maintainer-mode - - If you have automake, autoconf, and libtool installed on your - system, this switch causes configure to generate Makefiles which - know how to automatically regenerate configure scripts, makefiles, - and headers, when they are out of date. The HACKING file says which - versions of those tools you will need. - - ---with-threads --- Build with thread support - - Build a Guile executable and library that supports cooperative - threading. If you use this switch, Guile will also build and - install the QuickThreads non-preemptive threading library, - libqthreads, which you will need to link into your programs after - libguile. When you use `guile-config', you will pick up all - neccessary linker flags automatically. - - Cooperative threads are not yet thoroughly tested; once they are, - they will be enabled by default. The interaction with blocking I/O - is pretty ad hoc at the moment. In our experience, bugs in the - thread support do not affect you if you don't actually use threads. - - ---with-modules --- Specify statically linked `modules' - - Guile can dynamically load `plugin modules' during runtime, using - facilities provided by libtool. Not all platforms support this, - however. On these platforms, you can statically link the plugin - modules into libguile when Guile itself is build. XXX - how does - one specify the modules? - - ---enable-deprecated=LEVEL --- Control the inclusion of deprecated features. - - You can select between different behaviours via the LEVEL argument: - a value of "no" will omit all deprecated features and you will get - "undefined reference", "variable unbound" or similar errors when you - try to use them. All other values will include all deprecated - features. The LEVEL argument is used to determine the default value - for the environment variable GUILE_WARN_DEPRECATED. See the README - for more information. - - The default is to get a vague warning at program exit if deprecated - features were used: - - --enable-deprecated=yes - --enable-deprecated=summary - - To get a detailed warning at first use of a deprecated feature: - - --enable-deprecated=detailed - - To get no warnings: - - --enable-deprecated=shutup - - To omit deprecated features completely and irrevokably: - - --enable-deprecated=no - - ---disable-shared --- Do not build shared libraries. ---disable-static --- Do not build static libraries. - - Normally, both static and shared libraries will be built if your - system supports them. - - ---enable-debug-freelist --- Enable freelist debugging. - - This enables a debugging version of SCM_NEWCELL(), and also - registers an extra primitive, the setter - `gc-set-debug-check-freelist!'. - - Configure with the --enable-debug-freelist option to enable the - gc-set-debug-check-freelist! primitive, and then use: - - (gc-set-debug-check-freelist! #t) # turn on checking of the freelist - (gc-set-debug-check-freelist! #f) # turn off checking - - Checking of the freelist forces a traversal of the freelist and a - garbage collection before each allocation of a cell. This can slow - down the interpreter dramatically, so the setter should be used to - turn on this extra processing only when necessary. - - ---enable-debug-malloc --- Enable malloc debugging. - - Include code for debugging of calls to scm_must_malloc/realloc/free. - - Checks that - - 1. objects freed by scm_must_free has been mallocated by scm_must_malloc - 2. objects reallocated by scm_must_realloc has been allocated by - scm_must_malloc - 3. reallocated objects are reallocated with the same what string - - But, most importantly, it records the number of allocated objects of - each kind. This is useful when searching for memory leaks. - - A Guile compiled with this option provides the primitive - `malloc-stats' which returns an alist with pairs of kind and the - number of objects of that kind. - - ---enable-guile-debug --- Include internal debugging functions ---disable-arrays --- omit array and uniform array support ---disable-posix --- omit posix interfaces ---disable-networking --- omit networking interfaces ---disable-regex --- omit regular expression interfaces - - -Using Guile Without Installing It ========================================= - -If you want to run Guile without installing it, set the environment -variable `GUILE_LOAD_PATH' to a colon-separated list of directories, -including the directory containing this INSTALL file. If you used a -separate build directory, you'll need to include the build directory -in the path as well. - -For example, suppose the Guile distribution unpacked into a directory -called `/home/jimb/guile-snap' (so the full name of this INSTALL file -would be `/home/jimb/guile-snap/INSTALL'). Then you might say, if -you're using Bash or any other Bourne shell variant, - - export GUILE_LOAD_PATH=/home/jimb/guile-snap - -or if you're using CSH or one of its variants: - - setenv GUILE_LOAD_PATH /home/jimb/guile-snap - - -Installing SLIB =========================================================== - -In order to use SLIB from Guile you basically only need to put the -`slib' directory _in_ one of the directories on Guile's load path. - -The standard installation is: - - 1. Obtain slib from http://www-swiss.ai.mit.edu/~jaffer/SLIB.html - - 2. Put it in Guile's data directory, that is the directory printed when - you type - - guile-config info pkgdatadir - - at the shell prompt. This is normally `/usr/local/share/guile', so the - directory will normally have full path `/usr/local/share/guile/slib'. - - 3. Start guile as a user with write access to the data directory and type - - (use-modules (ice-9 slib)) - - at the Guile prompt. This will generate the slibcat catalog next to - the slib directory. - -SLIB's `require' is provided by the Guile module (ice-9 slib). - -Example: - - (use-modules (ice-9 slib)) - (require 'primes) - (prime? 7) - - -Generic Instructions for Building Auto-Configured Packages ================ - - The `configure' shell script attempts to guess correct values for -various system-dependent variables used during compilation. It uses -those values to create a `Makefile' in each directory of the package. -It may also create one or more `.h' files containing system-dependent -definitions. Finally, it creates a shell script `config.status' that -you can run in the future to recreate the current configuration, a file -`config.cache' that saves the results of its tests to speed up -reconfiguring, and a file `config.log' containing compiler output -(useful mainly for debugging `configure'). - - 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 -diffs or instructions to the address given in the `README' so they can -be considered for the next release. If at some point `config.cache' -contains results you don't want to keep, you may remove or edit it. - - The file `configure.in' is used to create `configure' by a program -called `autoconf'. You only need `configure.in' 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. - - Running `configure' takes awhile. While running, it prints some - messages telling which features it is checking for. - - 2. Type `make' to compile the package. - - 3. Optionally, type `make check' to run any self-tests that come with - the package. - - 4. Type `make install' to install the programs and any data files and - documentation. - - 5. You can remove the program binaries and object files from the - source code directory by typing `make clean'. To also remove the - files that `configure' created (so you can compile the package for - a different kind of computer), type `make distclean'. There is - also a `make maintainer-clean' target, but that is intended mainly - for the package's developers. If you use it, you may have to get - all sorts of other programs in order to regenerate files that came - with the distribution. - -Compilers and Options -===================== - - Some systems require unusual options for compilation or linking that -the `configure' script does not know about. You can give `configure' -initial values for variables by setting them in the environment. Using -a Bourne-compatible shell, you can do that on the command line like -this: - CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure - -Or on systems that have the `env' program, you can do it like this: - env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure - -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 -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 supports 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. - -Installation Names -================== - - By default, `make install' will install the package's files in -`/usr/local/bin', `/usr/local/man', etc. You can specify an -installation prefix other than `/usr/local' by giving `configure' the -option `--prefix=PATH'. - - You can specify separate installation prefixes for -architecture-specific files and architecture-independent files. If you -give `configure' the option `--exec-prefix=PATH', the package will use -PATH as the prefix for installing programs and libraries. -Documentation and other data files will still use the regular prefix. - - In addition, if you use an unusual directory layout you can give -options like `--bindir=PATH' to specify different values for particular -kinds of files. Run `configure --help' for a list of the directories -you can set and what kinds of files go in them. - - If the package supports it, you can cause programs to be installed -with an extra prefix or suffix on their names by giving `configure' the -option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. - -Optional Features -================= - - Some packages pay attention to `--enable-FEATURE' options to -`configure', where FEATURE indicates an optional part of the package. -They may also pay attention to `--with-PACKAGE' options, where PACKAGE -is something like `gnu-as' or `x' (for the X Window System). The -`README' should mention any `--enable-' and `--with-' options that the -package recognizes. - - For packages that use the X Window System, `configure' can usually -find the X include and library files automatically, but if it doesn't, -you can use the `configure' options `--x-includes=DIR' and -`--x-libraries=DIR' to specify their locations. - -Specifying the System Type -========================== - - There may be some features `configure' can not figure out -automatically, but needs to determine by the type of host the package -will run on. Usually `configure' can figure that out, but if it prints -a message saying it can not guess the host type, give it the -`--host=TYPE' option. TYPE can either be a short name for the system -type, such as `sun4', or a canonical name with three fields: - CPU-COMPANY-SYSTEM - -See the file `config.sub' for the possible values of each field. If -`config.sub' isn't included in this package, then this package doesn't -need to know the host type. - - If you are building compiler tools for cross-compiling, you can also -use the `--target=TYPE' option to select the type of system they will -produce code for and the `--build=TYPE' option to select the type of -system on which you are compiling the package. - -Sharing Defaults -================ - - If you want to set default values for `configure' scripts to share, -you can create a site shell script called `config.site' that gives -default values for variables like `CC', `cache_file', and `prefix'. -`configure' looks for `PREFIX/share/config.site' if it exists, then -`PREFIX/etc/config.site' if it exists. Or, you can set the -`CONFIG_SITE' environment variable to the location of the site script. -A warning: not all `configure' scripts look for a site script. - -Operation Controls -================== - - `configure' recognizes the following options to control how it -operates. - -`--cache-file=FILE' - Use and save the results of the tests in FILE instead of - `./config.cache'. Set FILE to `/dev/null' to disable caching, for - debugging `configure'. - -`--help' - Print a summary of the options to `configure', and exit. - -`--quiet' -`--silent' -`-q' - Do not print messages saying which checks are being made. To - suppress all normal output, redirect it to `/dev/null' (any error - messages will still be shown). - -`--srcdir=DIR' - Look for the package's source code in directory DIR. Usually - `configure' can determine that directory automatically. - -`--version' - Print the version of Autoconf used to generate the `configure' - script, and exit. - -`configure' also accepts some other, not widely useful, options. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b21e6a6c6..8570e57db 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2001-08-01 Marius Vollmer + + * chars.c (scm_char_alphabetic_p, scm_char_numeric_p, + scm_char_whitespace_p, scm_char_upper_case_p, + scm_char_lower_case_p, scm_char_is_both_p): Do not require + characters to fulfill isascii in addition to the primary + predicate. + 2001-07-30 Dirk Herrmann * numbers.c (DIGITS, scm_small_istr2int, scm_istr2int, From 3cc2e575a65ab38e312c42ff7e5f66257d5cf670 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 2 Aug 2001 10:13:03 +0000 Subject: [PATCH 39/39] Initial revision --- test-suite/tests/getopt-long.test | 95 +++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 test-suite/tests/getopt-long.test diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test new file mode 100644 index 000000000..1d1658a09 --- /dev/null +++ b/test-suite/tests/getopt-long.test @@ -0,0 +1,95 @@ +;;;; getopt-long.test --- optional long arg processing -*- scheme -*- +;;;; Thien-Thi Nguyen --- August 2001 +;;;; +;;;; Copyright (C) 2001 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 +;;;; 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (test-suite lib) + (ice-9 getopt-long) + (ice-9 regex)) + +(define exception:option-predicate-failed + (cons 'misc-error "^option predicate failed")) + +(with-test-prefix "specifying predicate" + + (define (test1 . args) + (getopt-long args `((test (value #t) + (predicate ,(lambda (x) + (string-match "^[0-9]+$" x))))))) + + (pass-if "valid arg" + (equal? (test1 "foo" "bar" "--test=123") + '((() "bar") (test . "123")))) + + (pass-if-exception "invalid arg" + exception:option-predicate-failed + (test1 "foo" "bar" "--test=foo")) + + (pass-if-exception "option has no arg" + exception:option-predicate-failed + (test1 "foo" "bar")) + + ) + +(with-test-prefix "not specifying predicate" + + (define (test2 . args) + (getopt-long args `((test (value #t))))) + + (pass-if "option has arg" + (equal? (test2 "foo" "bar" "--test=foo") + '((() "bar") (test . "foo")))) + + (pass-if "option has no arg" + (equal? (test2 "foo" "bar") + '((() "bar")))) + + ) + +(with-test-prefix "value optional" + + (define (test3 . args) + (getopt-long args '((foo (value optional) (single-char #\f)) + (bar)))) + + (pass-if "long option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "--foo" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "-f" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo', long option `bar', no args" + (equal? (test3 "prg" "-f" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `foo', long option `bar', no args" + (equal? (test3 "prg" "--foo" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `bar', short option `foo', no args" + (equal? (test3 "prg" "--bar" "-f") + '((()) (foo . #t) (bar . #t)))) + + (pass-if "long option `bar', long option `foo', no args" + (equal? (test3 "prg" "--bar" "--foo") + '((()) (foo . #t) (bar . #t)))) + ) + +;;; getopt-long.test ends here