From 6812c28f98d9768df0bc84fe0322a05aba093afd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:06:43 +0000 Subject: [PATCH 01/41] (top_builddir_absolute): New AC_SUBST var. (AC_CONFIG_FILES): Add am/Makefile, pre-inst-guile. (AC_CONFIG_COMMANDS): Also chmod +x pre-inst-guile. --- configure.in | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/configure.in b/configure.in index 671b490ed..8b42424cd 100644 --- a/configure.in +++ b/configure.in @@ -239,7 +239,7 @@ dnl Check for Winsock and other functionality on Win32 (*not* CygWin) dnl EXTRA_DEFS="" if test "$MINGW32" = "yes" ; then - AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1, + AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1, [Define if you have the header file.])]) AC_CHECK_LIB(ws2_32, main) LIBOBJS="$LIBOBJS win32-uname.o win32-dirent.o" @@ -683,8 +683,13 @@ AC_SUBST(LIBLOBJS) AC_SUBST(EXTRA_DOT_DOC_FILES) AC_SUBST(EXTRA_DOT_X_FILES) +dnl See also top_builddir in info node: (libtool)AC_PROG_LIBTOOL +top_builddir_absolute=`pwd` +AC_SUBST(top_builddir_absolute) + AC_CONFIG_FILES([ Makefile + am/Makefile libguile/Makefile libguile/guile-snarf libguile/guile-doc-snarf @@ -720,7 +725,8 @@ AC_CONFIG_FILES([ examples/safe/Makefile test-suite/Makefile check-guile - guile-tools]) + guile-tools + pre-inst-guile]) AC_CONFIG_COMMANDS(default, [ chmod +x libguile/guile-snarf \ @@ -728,7 +734,8 @@ AC_CONFIG_COMMANDS(default, libguile/guile-func-name-check \ libguile/guile-snarf-docs \ check-guile \ - guile-tools]) + guile-tools \ + pre-inst-guile]) AC_OUTPUT From 22087438a8b32ae3178d9b1a0e6abfdad9167c04 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:12:06 +0000 Subject: [PATCH 02/41] (top_builddir): Use AC_SUBST var `top_builddir_absolute'. (guile): Look for pre-inst-guile in $top_builddir. --- check-guile.in | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/check-guile.in b/check-guile.in index 547a93753..5b280601d 100644 --- a/check-guile.in +++ b/check-guile.in @@ -12,19 +12,17 @@ set -e # this script runs in the top-level build-dir. -top_builddir=`pwd` +top_builddir=@top_builddir_absolute@ top_srcdir=@top_srcdir@ TEST_SUITE_DIR=${top_srcdir}/test-suite if [ x"$1" = x-i ] ; then guile=$2 - guile_opts= shift shift else - guile=${top_srcdir}/pre-inst-guile - guile_opts="${top_builddir}" + guile=${top_builddir}/pre-inst-guile fi GUILE_LOAD_PATH=$TEST_SUITE_DIR @@ -43,7 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then @LN_S@ libguile/guile-procedures.txt . fi -exec $guile $guile_opts \ +exec $guile \ -e main -s "$TEST_SUITE_DIR/guile-test" \ --test-suite "$TEST_SUITE_DIR/tests" \ --log-file check-guile.log "$@" From 450ca06e8465983dbe11e4bd0a40de6db179a2a9 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:13:23 +0000 Subject: [PATCH 03/41] (EXTRA_DIST): Remove pre-inst-guile, pre-inst-guile.am. --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 99206df0c..ea26d8692 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,7 +30,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS TODO \ - $(ACLOCAL) acconfig.h BUGS pre-inst-guile pre-inst-guile.am + $(ACLOCAL) acconfig.h BUGS TESTS = check-guile From 931022f87bb3377c321bb2cde8a64fb094d8f6bb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:16:57 +0000 Subject: [PATCH 04/41] Update usage comment; nfc. --- check-guile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/check-guile.in b/check-guile.in index 5b280601d..9142fcff8 100644 --- a/check-guile.in +++ b/check-guile.in @@ -1,7 +1,7 @@ #! /bin/sh # Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS] -# If `-i GUILE-INTERPRETER' is omitted, use ${top_srcdir}/pre-inst-guile. -# See test-suite/guile-test for documentation on GUILE-TEST-ARGS. +# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/pre-inst-guile. +# See ${top_srcdir}/test-suite/guile-test for documentation on GUILE-TEST-ARGS. # # Example invocations: # ./check-guile From 3ed414c87504b6e4d992e4f39cef47f1111e5f73 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:18:01 +0000 Subject: [PATCH 05/41] *** empty log message *** --- ChangeLog | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/ChangeLog b/ChangeLog index 3f0f22c58..213103986 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2002-02-26 Thien-Thi Nguyen + + * pre-inst-guile.in: New file. + + * pre-inst-guile, pre-inst-guile.am: bye bye + + * configure.in (top_builddir_absolute): New AC_SUBST var. + (AC_CONFIG_FILES): Add am/Makefile, pre-inst-guile. + (AC_CONFIG_COMMANDS): Also chmod +x pre-inst-guile. + + * check-guile.in (top_builddir): Use AC_SUBST var + `top_builddir_absolute'. + (guile): Look for pre-inst-guile in $top_builddir. + + * Makefile.am (EXTRA_DIST): Remove pre-inst-guile, + pre-inst-guile.am. + 2002-02-24 Rob Browning * GUILE-VERSION: move all but guile-readline library versioning From 03b823a4ae52f53cefe32989876302c774344d9d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:25:02 +0000 Subject: [PATCH 06/41] Update "include" instructions. --- devel/build/pre-inst-guile.text | 47 --------------------------------- 1 file changed, 47 deletions(-) diff --git a/devel/build/pre-inst-guile.text b/devel/build/pre-inst-guile.text index 5e9a24b37..e69de29bb 100644 --- a/devel/build/pre-inst-guile.text +++ b/devel/build/pre-inst-guile.text @@ -1,47 +0,0 @@ -THEORY - - The pre-installed guile interpreter can be used if has access to - the proper shared libraries and scheme modules, which can be - arranged by tweaking GUILE_LOAD_PATH and LTDL_LIBRARY_PATH env - vars, respectively. - - -GENERAL PRACTICE - - To invoke the guile interpreter before installing it (and its - support files), call ${top_srcdir}/pre-inst-guile w/ first arg - ${top_builddir}, where you would normally call guile. - - Similarly, for scripts/* (normally found by guile-tools), set - env var GUILE to the above combination. - - See commentary in ${top_srcdir}/pre-inst-guile for more info. - - -SPECIFIC PRACTICE - - Include the following line in any Makefile.am with rules that - need to call the pre-installed guile interpreter: - - include $(top_srcdir)/pre-inst-guile.am - - This causes Automake to include a makefile fragment that defines - two vars: `preinstguile' and `preinstguiletool'. The following - examples show how these vars are used: - - display-sum5: - $(preinstguile) -c '(display (+ 1 2 3 4 5))' - - display-deps-dotty: - $(preinstguiletool)/use2dot *.scm - - Note the particular syntax of `preinstguiletool' usage. - - -KNOWN USAGE - - check-guile.in - doc/ref/Makefile.am - libguile/Makefile.am - ice-9/Makefile.am - scripts/Makefile.am From 58ed8bc61ceaa2dbb40b08650ac9ae9eedc8495b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:28:51 +0000 Subject: [PATCH 07/41] Update path to pre-inst-guile automake frag. --- doc/ref/Makefile.am | 2 +- ice-9/Makefile.am | 2 +- libguile/Makefile.am | 2 +- scripts/Makefile.am | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 3cb3888dc..5935dc7fc 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -37,7 +37,7 @@ guile_TEXINFOS = preface.texi intro.texi program.texi scheme-intro.texi \ ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS) -include $(top_srcdir)/pre-inst-guile.am +include $(top_srcdir)/am/pre-inst-guile # Automated snarfing diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 2c36a76ac..721d08200 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -47,7 +47,7 @@ if MAINTAINER_MODE # on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'. # In other words, to bootstrap this file, you need to do something like: # GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp -include $(top_srcdir)/pre-inst-guile.am +include $(top_srcdir)/am/pre-inst-guile psyntax.pp: psyntax.ss $(preinstguile) -s $(srcdir)/compile-psyntax.scm \ $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 1fe1d47ad..504152619 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -208,7 +208,7 @@ error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -include $(top_srcdir)/pre-inst-guile.am +include $(top_srcdir)/am/pre-inst-guile alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) snarf2checkedtexi = $(preinstguiletool)/snarf-check-and-output-texi diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 270120800..e3cb57e0d 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -42,7 +42,7 @@ EXTRA_DIST = $(scripts_sources) list: @echo $(scripts_sources) -include $(top_srcdir)/pre-inst-guile.am +include $(top_srcdir)/am/pre-inst-guile overview: $(scripts_sources) @echo '----------------------------' From 327d4dd38f22fb1ef48906068f9b95b15fba6052 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:32:34 +0000 Subject: [PATCH 08/41] doc/ref/ChangeLog --- devel/vm/ior/ior.text | 665 ----------------------------------------- doc/ref/ChangeLog | 4 + emacs/patch.el | 8 + ice-9/ChangeLog | 4 + libguile/ChangeLog | 4 + oop/goops/dispatch.scm | 61 ++-- qthreads.m4 | 156 ---------- scripts/ChangeLog | 4 + 8 files changed, 62 insertions(+), 844 deletions(-) diff --git a/devel/vm/ior/ior.text b/devel/vm/ior/ior.text index 9730de55d..e69de29bb 100644 --- a/devel/vm/ior/ior.text +++ b/devel/vm/ior/ior.text @@ -1,665 +0,0 @@ -*** -*** These notes about the design of a new type of Scheme interpreter -*** "Ior" are cut out from various emails from early spring 2000. -*** -*** MDJ 000817 -*** - -Generally, we should try to make a design which is clean and -minimalistic in as many respects as possible. For example, even if we -need more primitives than those in R5RS internally, I don't think -these should be made available to the user in the core, but rather be -made available *through* libraries (implementation in core, -publication via library). - -The suggested working name for this project is "Ior" (Swedish name for -the donkey in "Winnie the Pooh" :). If, against the odds, we really -would succeed in producing an Ior, and we find it suitable, we could -turn it into a Guile 2.0 (or whatever). (The architecture still -allows for support of the gh interface and uses conservative GC (Hans -Böhm's, in fact).) - - Beware now that I'm just sending over my original letter, which is - just a sketch of the more detailed, but cryptic, design notes I made - originally, which are, in turn, not as detailed as the design has - become now. :) - - Please also excuse the lack of structure. I shouldn't work on this at - all right now. Choose for yourselves if you want to read this - unstructured information or if you want to wait until I've structured - it after end of January. - -But then I actually have to blurt out the basic idea of my -architecture already now. (I had hoped to present you with a proper -and fairly detailed spec, but I won't be able to complete such a spec -quickly.) - - -The basic idea is this: - -* Don't waste time on non-computation! - -Why waste a lot of time on type-checks, unboxing and boxing of data? -Neither of these actions do any computations! - -I'd like both interpreter and compiled code to work directly with data -in raw, native form (integers represented as 32bit longs, inexact -numbers as doubles, short strings as bytes in a word, longer strings -as a normal pointer to malloced memory, bignums are just pointers to a -gmp (GNU MultiPrecision library) object, etc.) - -* Don't we need to dispatch on type to know what to do? - -But don't we need to dispatch on the type in order to know how to -compute with the data? E.g., `display' does entirely different -computations on a and a . ( is an integer -between -2^31 and 2^31-1.) - -The answer is *no*, not in 95% of all cases. The main reason is that -the interpreter does type analysis while converting closures to -bytecode, and knows already when _calling_ `display' what type it's -arguments has. This means that the bytecode compiler can choose a -suitable _version_ of `display' which handles that particular type. - - - -This type analysis is greatly simplified by the fact that just as the -type analysis _results_ in the type of the argument in the call to -`display', and, thus, we can select the correct _version_ of -`display', the closure byte-code itself will only be one _version_ of -the closure with the types of its arguments fixed at the start of the -analysis. - -As you already have understood by now, the basic architecture is that -all procedures are generic functions, and the "versions" I'm speaking -about is a kind of methods. Let's call them "branches" by now. - -For example: - -(define foo - (lambda (x) - ... - (display x) - ...) - -may result in the following two branches: - -1. [-foo] = - (branch ((x )) - ... - ([-display] x) - ...) - -2. [-foo] = - (branch ((x )) - ... - ([-display] x) - ...) - -and a new closure - -(define bar - (lambda (x y) - ... - (foo x) - ...)) - -results in - -[--bar] = - (branch ((x ) (y )) - ... - ([-foo] x) - ...) - -Note how all type dispatch is eliminated in these examples. - -As a further reinforcement to the type analysis, branches will not -only have typed parameters but also have return types. This means -that the type of a branch will look like - - x ... x --> - -In essence, the entire system will be very ML-like internally, and we -can benefit from the research done on ML-compilation. - -However, we now get three major problems to confront: - -1. In the Scheme language not all situations can be completely type - analyzed. - -2. In particular, for some operations, even if the types of the - parameters are well defined, we can't determine the return type - generically. For example, [--+] may have return - type _or_ . - -3. Even if we can do a complete analysis, some closures will generate - a combinatoric explosion of branches. - - -Problem 1: Incomplete analysis - -We introduce a new type . This data type has type and -contents - -struct ior_boxed_t { - ior_type *type; /* pointer to class struct */ - void *data; /* generic field, may also contain immediate objects - */ -} - -For example, a boxed fixnum 4711 has type and contents -{ , 4711 }. The boxed type essentially corresponds to Guile's -SCM type. It's just that the 1 or 3 or 7 or 16-bit type tag has been -replaced with a 32-bit type tag (the pointer to the class structure -describing the type of the object). - -This is more inefficient than the SCM type system, but it's no problem -since it won't be used in 95% of all cases. The big advantage -compared to SCM's type system is that it is so simple and uniform. - -I should note here that while SCM and Guile are centered around the -cell representation and all objects either _are_ cells or have a cell -handle, objects in ior will more look like mallocs. This is the -reason why I planned to start with Böhm's GC which has C pointers as -object handles. But it is of course still possible to use a heap, or, -preferably several heaps for different kinds of objects. (Böhm's GC -has multiple heaps for different sizes of objects.) If we write a -custom GC, we can increase speed further. - - -Problem 3 (yes, I skipped :) Combinatoric explosion - -We simply don't generate all possible branches. In the interpreter we -generate branches "just-too-late" (well, it's normally called "lazy -compilation" or "just-in-time", but if it was "in-time", the procedure -would already be compiled when it was needed, right? :) as when Guile -memoizes or when a Java machine turns byte-codes into machine code, or -as when GOOPS turns methods into cmethods for that matter. - -Have noticed that branches (although still without return type -information) already exist in GOOPS? They are currently called -"cmethods" and are generated on demand from the method code and put -into the GF cache during evaluation of GOOPS code. :-) (I have not -utilized this fully yet. I plan to soon use this method compilation -(into branches) to eliminate almost all type dispatch in calls to -accessors.) - -For the compiler, we use profiling information, just as the modern GCC -scheduler, or else relies on some type analysis (if a procedure says -(+ x y), x is not normally a but rather some subclass of -) and some common sense (it's usually more important to -generate branches than branches). - -The rest of the cases can be handled by -branches. We can, for -example, have a: - -[--bar] = - (branch ((x ) (y )) - ... - ([-foo] x) - ...) - -[-foo] will use an efficient type dispatch mechanism (for -example akin to the GOOPS one) to select the right branch of -`display'. - - -Problem 2: Ambiguous return type - -If the return type of a branch is ambiguous, we simply define the -return type as , and box data at the point in the branch where -it can be decided which type of data we will return. This is how -things can be handled in the general case. However, we might be able -to handle things in a more neat way, at least in some cases: - -During compilation to byte code, we'll probably use an intermediate -representation in continuation passing style. We might even use a -subtype of branches reprented as continuations (not a heavy -representation, as in Guile and SCM, but probably not much more than a -function pointer). This is, for example, one way of handling tail -recursion, especially mutual tail recursion. - -One case where we would like to try really hard not to box data is -when fixnums "overflow into" bignums. - -Let's say that the branch [--bar] contains a form - - (+ x y) - -where the type analyzer knows that x and y are fixnums. We then split -the branch right after the form and let it fork into two possible -continuation branches bar1 and bar2: - -[The following is only pseudo code. It can be made efficient on the C - level. We can also use the asm compiler directive in conditional - compilation for GCC on i386. We could even let autoconf/automake - substitute an architecture specific solution for multiple - architectures, but still support a C level default case.] - - (if (sum-over/underflow? x y) - (bar1 (fixnum->bignum x) (fixnum->bignum y) ...) - (bar2 x y ...)) - -bar1 begins with the evaluation of the form - - ([--+] x y) - -while bar 2 begins with - - ([--+] x y) - -Note that the return type of each of these forms is unambiguous. - - -Now some random points from the design: - -* The basic concept in Ior is the class. A type is a concrete class. - Classes which are subclasses of are concrete, otherwise they - are abstract. - -* A procedure is a collection of methods. Each method can have - arbitrary number of parameters of arbitrary class (not type). - -* The type of a method is the tuple of it's argument classes. - -* The type of a procedure is the set of it's method types. - -But the most important new concept is the branch. -Regard the procedure: - -(define (half x) - (quotient x 2)) - -The procedure half will have the single method - - (method ((x )) - (quotient x 2)) - -When `(half 128)' is called the Ior evaluator will create a new branch -during the actual evaluation. I'm now going to extend the branch -syntax by adding a second list of formals: the continuations of the -branch. - -* The type of a branch is namely the tuple of the tuple of it's - argument types (not classes!) and the tuple of it's continuation - argument types. The branch generated above will be: - - (branch ((x ) ((c )) - (c (quotient x 2))) - - If the method - - (method ((x ) (y )) - (quotient (+ x 1) y)) - - is called with arguments 1 and 2 it results in the branch - - (branch ((x ) (y )) ((c1 ) (c2 )) - (quotient (+ x 1 c3) 2)) - - where c3 is: - - (branch ((x ) (y )) ((c )) - (quotient (+ (fixnum->bignum x) 1) 2) - -The generated branches are stored in a cache in the procedure object. - - -But wait a minute! What about variables and data structures? - -In essence, what we do is that we fork up all data paths so that they -can be typed: We put the type tags on the _data paths_ instead of on -the data itself. You can look upon the "branches" as tubes of -information where the type tag is attached to the tube instead of on -what passes through it. - -Variables and data structures are part of the "tubes", so they need to -be typed. For example, the generic pair looks like: - -(define-class () - car-type - car - cdr-type - cdr) - -But note that since car and cdr are generic procedures, we can let -more efficient pairs exist in parallel, like - -(define-class () - (car (class )) - (cdr (class ))) - -Note that instances of this last type only takes two words of memory! -They are easy to use too. We can't use `cons' or `list' to create -them, since these procedures can't assume immutability, but we don't -need to specify the type in our program. Something like - - (const-cons 1 x) - -where x is in the data flow path tagged as , or - - (const-list 1 2 3) - - -Some further notes: - -* The concepts module and instance are the same thing. Using other - modules means 1. creating a new module class which inherits the - classes of the used modules and 2. instantiating it. - -* Module definitions and class definitions are equivalent but - different syntactic sugar adapted for each kind of use. - -* (define x 1) means: create an instance variable which is itself a - subclass of with initial value 1 (which is an instance of - ). - - -The interpreter is a mixture between a stack machine and a register -machine. The evaluator looks like this... :) - - /* the interpreter! */ - if (!setjmp (ior_context->exit_buf)) -#ifndef i386_GCC - while (1) -#endif - (*ior_continue) (IOR_MICRO_OP_ARGS); - -The branches are represented as an array of pointers to micro -operations. In essence, the evaluator doesn't exist in itself, but is -folded out over the entire implementation. This allows for an extreme -form of modularity! - -The i386_GCC is a machine specific optimization which avoids all -unnecessary popping and pushing of the CPU stack (which is different -from the Ior data stack). - -The execution environment consists of - -* a continue register similar to the program counter in the CPU -* a data stack (where micro operation arguments and results are stored) -* a linked chain of environment frames (but look at exception below!) -* a dynamic context - -I've written a small baby Ior which uses Guile's infrastructure. -Here's the context from that baby Ior: - -typedef struct ior_context_t { - ior_data_t *env; /* rest of environment frames */ - ior_cont_t save_continue; /* saves or represents continuation */ - ior_data_t *save_env; /* saves or represents environment */ - ior_data_t *fluids; /* array of fluids (use GC_malloc!) */ - int n_fluids; - int fluids_size; - /* dynwind chain is stored directly in the environment, not in context */ - jmp_buf exit_buf; - IOR_SCM guile_protected; /* temporary */ -} ior_context_t; - -There's an important exception regarding the lowest environment -frame. That frame isn't stored in a separate block on the heap, but -on Ior's data stack. Frames are copied out onto the heap when -necessary (for example when closures "escape"). - - -Now a concrete example: - -Look at: - -(define sum - (lambda (from to res) - (if (= from to) - res - (sum (+ 1 from) to (+ from res))))) - -This can be rewritten into CPS (which captures a lot of what happens -during flow analysis): - -(define sum - (lambda (from to res c1) - (let ((c2 (lambda (limit?) - (let ((c3 (lambda () - (c1 res))) - (c4 (lambda () - (let ((c5 (lambda (from+1) - (let ((c6 (lambda (from+res) - (sum from+1 to from+res c1)))) - (_+ from res c6))))) - (_+ 1 from c5))))) - (_if limit? c3 c4))))) - (_= from to c2)))) - -Finally, after branch expansion, some optimization, code generation, -and some optimization again, we end up with the byte code for the two -branches (here marked by labels `sum' and `sumbig'): - - c5 - (ref -3) - (shift -1) - (+ c4big) - ;; c4 - (shift -2) - (+ 1 sumbig) - ;; c6 - sum - (shift 3) - (ref2 -3) - ;; c2 - (if!= c5) - ;; c3 - (ref -1) - ;; c1 - (end) - - c5big - (ref -3) - (shift -1) - (+ ) - c4big - (shift -2) - (+ 1) - ;; c6 - sumbig - (shift 3) - (ref2 -3) - ;; c2 - (= ) - (if! c5big) - ;; c3 - (ref -1) - ;; c1 - (end) - -Let's take a closer look upon the (+ 1 sumbig) micro -operation. The generated assembler from the Ior C source + machine -specific optimizations for i386_GCC looks like this (with some rubbish -deleted): - -ior_int_int_sum_intbig: - movl 4(%ebx),%eax ; fetch arg 2 - addl (%ebx),%eax ; fetch arg 1 and do the work! - jo ior_big_sum_int_int ; dispatch to other branch on overflow - movl %eax,(%ebx) ; store result in first environment frame - addl $8,%esi ; increment program counter - jmp (%esi) ; execute next opcode - -ior_big_sum_int_int: - -To clearify: This is output from the C compiler. I added the comments -afterwards. - -The source currently looks like this: - -IOR_MICRO_BRANCH_2_2 ("+", int, big, sum, int, int, 1, 0) -{ - int res = IOR_ARG (int, 0) + IOR_ARG (int, 1); - IOR_JUMP_OVERFLOW (res, ior_big_sum_int_int); - IOR_NEXT2 (z); -} - -where the macros allow for different definitions depending on if we -want to play pure ANSI or optimize for a certain machine/compiler. - -The plan is actually to write all source in the Ior language and write -Ior code to translate the core code into bootstrapping C code. - -Please note that if i386_GCC isn't defined, we run plain portable ANSI C. - - -Just one further note: - -In Ior, there are three modes of evaluation - -1. evaluating and type analyzing (these go in parallel) -2. code generation -3. executing byte codes - -It is mode 3 which is really fast in Ior. - -You can look upon your program as a web of branch segments where one -branch segment can be generated from fragments of many closures. Mode -switches doesn't occur at the procedure borders, but at "growth -points". I don't have time to define them here, but they are based -upon the idea that the continuation together with the type signature -of the data flow path is unique. - -We normally run in mode 3. When we come to a source growth point -(essentially an apply instruction) for uncompiled code we "dive out" -of mode 3 into mode 1 which starts to eval/analyze code until we come -to a "sink". When we reach the "sink", we have enough information -about the data path to do code generation, so we backtrack to the -source growth point and grow the branch between source and sink. -Finally, we "dive into" mode 3! - -So, code generation doesn't respect procedure borders. We instead get -a very neat kind of inlining, which, e.g., means that it is OK to use -closures instead of macros in many cases. ----------------------------------------------------------------------- -Ior and module system -===================== - -How, exactly, should the module system of Ior look like? - -There is this general issue of whether to have a single-dispatch or -multi-dispatch system. Personally, I see that Scheme already use -multi-dispatch. Compare (+ 1.0 2) and (+ 1 2.0). - -As you've seen if you've read the notes about Ior design, efficiency -is not an issue here, since almost all dispatch will be eliminated -anyway. - -Also, note an interesting thing: GOOPS actually has a special, -implicit, argument to all of it's methods: the lexical environment. -It would be very ugly to add a second, special, argument to this. - -Of course, the theoreticians have already recognised this, and in many -systems, the implicit argument (the object) and the environment for -the method is the same thing. - -I think we should especially take impressions from Matthias Blume's -module/object system. - -The idea, now, for Ior (remember that everything about Ior is -negotiable between us) is that a module is a type, as well as an -instance of that type. The idea is that we basically keep the GOOPS -style of methods, with the implicit argument being the module object -(or some other lexical environment, in a chain with the module as -root). - -Let's say now that module C uses modules A and B. Modules A and B -both exports the procedure `foo'. But A:foo and B:foo as different -sets of methods. - -What does this mean? Well, it obviously means that the procedure -`foo' in module C is a subtype of A:foo and B:foo. Note how this is -similar in structure to slot inheritance: When class C is created with -superclasses A and B, the properties of a slot in C are created -through slot inheritance. One way of interpreting variable foo in -module A is as a slot with init value foo. Through the MOP, we can -specify that procedure slot inheritance in a module class implies -creation of new init values through inheritance. - -This may look like a kludge, and perhaps it is, and, sure, we are not -going to accept any kludges in Ior. But, it might actually not be a -kludge... - -I think it is commonly accepted by computer scientists that a module, -and/or at least a module interface is a type. Again, this type can be -seen as the set of types of the functions in the interface. The types -of our procedures are the set of branch types the provide. It is then -natural that a module using two other modules create new procedure -types by folding. - -This thing would become less cloudy (yes, this is a cloudy part of my -reasoning; I meant previously that the interpreter itself is now -clear) if module interfaces were required to be explicitly types. - -Actually, this would fit much better together with the rest of Ior's -design. On one hand, we might be free to introduce such a restriction -(compiler writers would applaud it), since R5RS hasn't specified any -module system. On the other hand, it might be strange to require -explicit typing when Scheme is fundamentally implicitly types... - -We also have to consider that a module has an "inward" face, which is -one type, and possibly many "outward" faces, which are different -types. (Compare the idea of "interfaces" in Scheme48.) - -It thus, seems that, while a module can truly be an Ior class, the -reverse should probably not hold in the general case... - -Unless - - instance <-> module proper - class of the instance <-> "inward interface" - superclasses <-> "outward interfaces + inward uses" - -...hmm, is this possible to reconcile with Rees' object system? - -Please think about these issues. We should try to end up with a -beautiful and consistent object/module system. - ----------------------------------------------------------------------- - -Here's a difficult problem in Ior's design: - -Let's say that we have a mutable data structure, like an ordinary -list. Since, in Ior, the type tag (which is really a pointer to a -class structure) is stored separately from the data, it is thinkable -that another thread modifies the location in the list between when our -thread reads the type tag and when it reads the data. - -The reading of type and data must be made atomic in some way. -Probably, some kind of locking of the heap is required. It's just -that it may cause a lot of overhead to look the heap at every *read* -from a mutable data structure. - -Look how much trouble those set!-operations cause! Not only does it -force us to store type tags for each car and cdr in the list, but it -also forces a lot of explicit dispatch to be done, and causes troubles -in a threaded system... - ----------------------------------------------------------------------- - -Jim Blandy writes: - -> We also should try to make less work for the GC, by avoiding consing -> up local environments until they're closed over. - -Did the texts which I sent to you talk about Ior's solution? - -It basically is: Use *two* environment "arguments" to the evaluator -(in Ior, they aren't arguments but registers): - -* One argument is a pointer to the "top" of an environment stack. - This is used in the "inner loop" for very efficient access to - in-between results. The "top" segment of the environment stack is - also regarded as the first environment frame in the lexical - environment. ("top" is bottom on a stack which grows downwards) - -* The other argument points to a structure holding the evaluation - context. In this context, there is a pointer to the chain of the - rest of the environment frames. Note that since frames are just - blocks of SCM values, you can very efficiently "release" a frame - into the heap by block copying it (remember that Ior uses Boehms GC; - this is how we allocate the block). diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index f07a7ee11..5f18640a3 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2002-02-26 Thien-Thi Nguyen + + * Makefile.am: Update path to pre-inst-guile automake frag. + 2002-02-24 Rob Browning * .cvsignore: add autoconf-macros.texi. diff --git a/emacs/patch.el b/emacs/patch.el index af8c45dfc..868310a80 100644 --- a/emacs/patch.el +++ b/emacs/patch.el @@ -45,6 +45,9 @@ ;;; Code: (require 'cl) +(require 'update-changelog) ; for stitching + +;; outgoing (defvar patch-greeting "hello guile maintainers,\n\n" "*String to insert at beginning of patch mail.") @@ -95,4 +98,9 @@ (patch-changelog-skeleton) "\n\n\n" (make-string 72 ?_) "\n"))) +;; incoming + + + + ;;; patch.el ends here diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index a41923c83..8f3a73b38 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2002-02-26 Thien-Thi Nguyen + + * Makefile.am: Update path to pre-inst-guile automake frag. + 2002-02-24 Rob Browning * syncase.scm (gensym): redefine locally so we can control it's diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5a3072f23..a3704cbe0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2002-02-26 Thien-Thi Nguyen + + * Makefile.am: Update path to pre-inst-guile automake frag. + 2002-02-25 Dirk Herrmann * gc.c (scm_gc_sweep): Make it compile even when deprecated diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index 749cf9273..137def45b 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -1,15 +1,17 @@ +;;;; oop/goop/dispatch.scm --- provide `memoize-method!' + ;;;; 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, @@ -38,7 +40,7 @@ ;;;; If you write modifications of your own for GUILE, it is your choice ;;;; whether to permit this exception to apply to your modifications. ;;;; If you do not wish that, delete this exception notice. -;;;; +;;;; (define-module (oop goops dispatch) @@ -235,7 +237,26 @@ (define (lookup-create-cmethod gf args) (no-applicable-method (car args) (cadr args)))) -(define (memoize-method! gf args exp) +(define method-cache-install! + (letrec ((first-n + (lambda (ls n) + (if (or (zero? n) (null? ls)) + '() + (cons (car ls) (first-n (cdr ls) (- n 1))))))) + (lambda (insert! exp args applicable) + (let* ((specializers (method-specializers (car applicable))) + (n-specializers + (if (list? specializers) + (length specializers) + (+ 1 (slot-ref (method-cache-generic-function exp) + 'n-specialized))))) + (let* ((types (map class-of (first-n args n-specializers))) + (entry+cmethod (compute-entry-with-cmethod applicable types))) + (insert! exp (car entry+cmethod)) ; entry = types + cmethod + (cdr entry+cmethod) ; cmethod + ))))) + +(define (memoize-method!-uninstrumented gf args exp) (if (not (slot-ref gf 'used-by)) (slot-set! gf 'used-by '())) (let ((applicable ((if (eq? gf compute-applicable-methods) @@ -271,23 +292,17 @@ (set-car! args gf) (lookup-create-cmethod no-applicable-method args))))) +(define -memoize-method!-stats #f) + +(define (memoize-method! gf args exp) + (memoize-method!-uninstrumented gf args exp)) + (set-procedure-property! memoize-method! 'system-procedure #t) -(define method-cache-install! - (letrec ((first-n - (lambda (ls n) - (if (or (zero? n) (null? ls)) - '() - (cons (car ls) (first-n (cdr ls) (- n 1))))))) - (lambda (insert! exp args applicable) - (let* ((specializers (method-specializers (car applicable))) - (n-specializers - (if (list? specializers) - (length specializers) - (+ 1 (slot-ref (method-cache-generic-function exp) - 'n-specialized))))) - (let* ((types (map class-of (first-n args n-specializers))) - (entry+cmethod (compute-entry-with-cmethod applicable types))) - (insert! exp (car entry+cmethod)) ; entry = types + cmethod - (cdr entry+cmethod) ; cmethod - ))))) +;;; +;;; Memoization Reflection +;;; + + + +;;; oop/goop/dispatch.scm ends here diff --git a/qthreads.m4 b/qthreads.m4 index 585892c01..e69de29bb 100644 --- a/qthreads.m4 +++ b/qthreads.m4 @@ -1,156 +0,0 @@ -dnl Autoconf macros for configuring the QuickThreads package -dnl Jim Blandy --- July 1998 -dnl -dnl Copyright (C) 1998, 1999 Free Software Foundation, Inc. -dnl -dnl This file is part of GUILE. -dnl -dnl GUILE is free software; you can redistribute it and/or modify -dnl it under the terms of the GNU General Public License as -dnl published by the Free Software Foundation; either version 2, or -dnl (at your option) any later version. -dnl -dnl GUILE is distributed in the hope that it will be useful, but -dnl WITHOUT ANY WARRANTY; without even the implied warranty of -dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -dnl GNU General Public License for more details. -dnl -dnl You should have received a copy of the GNU General Public -dnl License along with GUILE; see the file COPYING. If not, write -dnl to the Free Software Foundation, Inc., 59 Temple Place, Suite -dnl 330, Boston, MA 02111-1307 USA - - - -dnl QTHREADS_CONFIGURE configures the QuickThreads package. The QT -dnl sources should be in $srcdir/qt. If configuration succeeds, this -dnl macro creates the appropriate symlinks in the qt object directory, -dnl and sets the following variables, used in building libqthreads.a: -dnl QTHREAD_LTLIBS --- set to libqthreads.la if configuration -dnl succeeds, or the empty string if configuration fails. -dnl qtmd_h, qtmds_s, qtmdc_c, qtdmdb_s --- the names of the machine- -dnl dependent source files. -dnl qthread_asflags --- flags to pass to the compiler when processing -dnl assembly-language files. -dnl -dnl It also sets the following variables, which describe how clients -dnl can link against libqthreads.a: -dnl THREAD_PACKAGE --- set to "QT" if configuration succeeds, or -dnl the empty string if configuration fails. -dnl THREAD_LIBS_LOCAL --- linker options for use in this source tree -dnl THREAD_LIBS_INSTALLED --- linker options for use after this package -dnl is installed -dnl It would be nice if all thread configuration packages for Guile -dnl followed the same conventions. -dnl -dnl All of the above variables will be substituted into Makefiles in -dnl the usual autoconf fashion. -dnl -dnl We distinguish between THREAD_LIBS_LOCAL and -dnl THREAD_LIBS_INSTALLED because the thread library might be in -dnl this tree, and be built using libtool. This means that: -dnl 1) when building other executables in this tree, one must -dnl pass the relative path to the ../libfoo.la file, but -dnl 2) once the whole package has been installed, users should -dnl link using -lfoo. -dnl Normally, we only care about the first case, but since the -dnl guile-config script needs to give users all the flags they need -dnl to link programs against guile, the GUILE_WITH_THREADS macro -dnl needs to supply the second piece of information as well. -dnl -dnl This whole thing is a little confused about what ought to be -dnl done in the top-level configure script, and what ought to be -dnl taken care of in the subdirectory. For example, qtmds_s and -dnl friends really ought not to be even mentioned in the top-level -dnl configure script, but here they are. - -AC_DEFUN([QTHREADS_CONFIGURE],[ - AC_REQUIRE([AC_PROG_LN_S]) - - AC_MSG_CHECKING(QuickThreads configuration) - - changequote(,)dnl We use [ and ] in a regexp in the case - - THREAD_PACKAGE=QT - qthread_asflags='' - case "$host" in - i[3456]86-*-*) - port_name=i386 - qtmd_h=md/i386.h - qtmds_s=md/i386.s - qtmdc_c=md/null.c - qtdmdb_s= - case "$host" in - *-*-netbsd* ) - ## NetBSD needs to be told to pass the assembly code through - ## the C preprocessor. Other GCC installations seem to do - ## this by default, but NetBSD's doesn't. We could get the - ## same effect by giving the file a name ending with .S - ## instead of .s, but I don't see how to tell automake to do - ## that. - qthread_asflags='-x assembler-with-cpp' - ;; - esac - ;; - mips-sgi-irix[56]*) - port_name=irix - qtmd_h=md/mips.h - qtmds_s=md/mips-irix5.s - qtmdc_c=md/null.c - qtdmdb_s=md/mips_b.s - ;; - mips-*-*) - port_name=mips - qtmd_h=md/mips.h - qtmds_s=md/mips.s - qtmdc_c=md/null.c - qtdmdb_s=md/mips_b.s - ;; - sparc-*-sunos*) - port_name=sparc-sunos - qtmd_h=md/sparc.h - qtmds_s=md/_sparc.s - qtmdc_c=md/null.c - qtdmdb_s=md/_sparc_b.s - ;; - sparc-*-*) - port_name=sparc - qtmd_h=md/sparc.h - qtmds_s=md/sparc.s - qtmdc_c=md/null.c - qtdmdb_s=md/sparc_b.s - ;; - alpha*-*-*) - port_name=alpha - qtmd_h=md/axp.h - qtmds_s=md/axp.s - qtmdc_c=md/null.c - qtdmdb_s=md/axp_b.s - ;; - *) - echo "Unknown configuration; threads package disabled" - THREAD_PACKAGE="" - ;; - esac - changequote([, ]) - - # Did configuration succeed? - if test -n "$THREAD_PACKAGE"; then - AC_MSG_RESULT($port_name) - QTHREAD_LTLIBS=libqthreads.la - THREAD_LIBS_LOCAL="../qt/libqthreads.la" - THREAD_LIBS_INSTALLED="-lqthreads" - else - AC_MSG_RESULT(none; disabled) - fi - - AC_SUBST(QTHREAD_LTLIBS) - AC_SUBST(qtmd_h) - AC_SUBST(qtmds_s) - AC_SUBST(qtmdc_c) - AC_SUBST(qtdmdb_s) - AC_SUBST(qthread_asflags) - AC_SUBST(THREAD_PACKAGE) - AC_SUBST(THREAD_LIBS_LOCAL) - AC_SUBST(THREAD_LIBS_INSTALLED) -]) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index d6484894c..912000ea8 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,7 @@ +2002-02-26 Thien-Thi Nguyen + + * Makefile.am: Update path to pre-inst-guile automake frag. + 2002-02-22 Thien-Thi Nguyen * api-diff: New script. From b39eac3a5a81d29f9bd7ded41f4d52464caa247a Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:38:53 +0000 Subject: [PATCH 09/41] Revert to 1.6 (1.7 was an accidental checkin). --- oop/goops/dispatch.scm | 53 +++++++++++++++--------------------------- 1 file changed, 19 insertions(+), 34 deletions(-) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index 137def45b..8f9cb2c1e 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -1,5 +1,3 @@ -;;;; oop/goop/dispatch.scm --- provide `memoize-method!' - ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -237,26 +235,7 @@ (define (lookup-create-cmethod gf args) (no-applicable-method (car args) (cadr args)))) -(define method-cache-install! - (letrec ((first-n - (lambda (ls n) - (if (or (zero? n) (null? ls)) - '() - (cons (car ls) (first-n (cdr ls) (- n 1))))))) - (lambda (insert! exp args applicable) - (let* ((specializers (method-specializers (car applicable))) - (n-specializers - (if (list? specializers) - (length specializers) - (+ 1 (slot-ref (method-cache-generic-function exp) - 'n-specialized))))) - (let* ((types (map class-of (first-n args n-specializers))) - (entry+cmethod (compute-entry-with-cmethod applicable types))) - (insert! exp (car entry+cmethod)) ; entry = types + cmethod - (cdr entry+cmethod) ; cmethod - ))))) - -(define (memoize-method!-uninstrumented gf args exp) +(define (memoize-method! gf args exp) (if (not (slot-ref gf 'used-by)) (slot-set! gf 'used-by '())) (let ((applicable ((if (eq? gf compute-applicable-methods) @@ -292,17 +271,23 @@ (set-car! args gf) (lookup-create-cmethod no-applicable-method args))))) -(define -memoize-method!-stats #f) - -(define (memoize-method! gf args exp) - (memoize-method!-uninstrumented gf args exp)) - (set-procedure-property! memoize-method! 'system-procedure #t) -;;; -;;; Memoization Reflection -;;; - - - -;;; oop/goop/dispatch.scm ends here +(define method-cache-install! + (letrec ((first-n + (lambda (ls n) + (if (or (zero? n) (null? ls)) + '() + (cons (car ls) (first-n (cdr ls) (- n 1))))))) + (lambda (insert! exp args applicable) + (let* ((specializers (method-specializers (car applicable))) + (n-specializers + (if (list? specializers) + (length specializers) + (+ 1 (slot-ref (method-cache-generic-function exp) + 'n-specialized))))) + (let* ((types (map class-of (first-n args n-specializers))) + (entry+cmethod (compute-entry-with-cmethod applicable types))) + (insert! exp (car entry+cmethod)) ; entry = types + cmethod + (cdr entry+cmethod) ; cmethod + ))))) From 4eecfeb7961a4b4fb909670dd22f67795336a600 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:57:54 +0000 Subject: [PATCH 10/41] Comment grammar fixes; nfc. --- ice-9/boot-9.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 1aee82d60..36fc11470 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -634,7 +634,7 @@ (debug-enable 'debug) (debug-enable 'backtrace) (read-enable 'positions)) - + (define (load-user-init) (let* ((home (or (getenv "HOME") (false-if-exception (passwd:dir (getpwuid (getuid)))) @@ -1633,7 +1633,7 @@ (eq? (car (last-pair use-list)) the-scm-module)) (set-module-uses! module (reverse (cdr (reverse use-list))))))) -;; Return a module that is a interface to the module designated by +;; Return a module that is an interface to the module designated by ;; NAME. ;; ;; `resolve-interface' takes two keyword arguments: @@ -1645,7 +1645,7 @@ ;; is the name in the used module and SEEN is the name in the using ;; module. Note that SEEN is also passed through RENAMER, below. The ;; default is to select all bindings. If you specify no selection but -;; a renamer, only the bindings that already exists in the used module +;; a renamer, only the bindings that already exist in the used module ;; are made available in the interface. Bindings that are added later ;; are not picked up. ;; From d51b42e28b4135545b5e5932b5a55210328fa706 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:58:58 +0000 Subject: [PATCH 11/41] *** empty log message *** --- ice-9/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8f3a73b38..ce38693c6 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -2,6 +2,9 @@ * Makefile.am: Update path to pre-inst-guile automake frag. + * boot-9.scm: Comment grammar fixes; nfc. + Thanks to Christopher Cramer. + 2002-02-24 Rob Browning * syncase.scm (gensym): redefine locally so we can control it's From edb810bb84ca1198d4ff34712877ee681b15c5fb Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Wed, 27 Feb 2002 15:41:01 +0000 Subject: [PATCH 12/41] 2002-02-27 Stefan Jahn * Makefile.am (SUBDIRS): Added the `am' directory. 2002-02-27 Stefan Jahn * gh.texi (scm transition summary): Documented some more gh equivalents and removed appropriate FIXME's. 2002-02-27 Stefan Jahn * Makefile.am (EXTRA_DIST): Added the `LIBGUILEREADLINE-VERSION' file. 2002-02-27 Stefan Jahn * convert.i.c, convert.c: Better range checking. * inet_aton.c, fports.c: Commented the inclusion of . * deprecation.c (vsnprintf): Define to `_vsnprintf' for Windows (MinGW). --- ChangeLog | 4 + Makefile.am | 2 +- doc/ref/ChangeLog | 5 + doc/ref/gh.texi | 14 +-- guile-readline/ChangeLog | 5 + guile-readline/Makefile.am | 2 +- libguile/ChangeLog | 9 ++ libguile/convert.c | 145 ++++++++++++++-------------- libguile/convert.i.c | 191 +++++++++++++++++++++---------------- libguile/deprecation.c | 5 + libguile/fports.c | 3 +- libguile/inet_aton.c | 1 + 12 files changed, 223 insertions(+), 163 deletions(-) diff --git a/ChangeLog b/ChangeLog index 213103986..b0c352451 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2002-02-27 Stefan Jahn + + * Makefile.am (SUBDIRS): Added the `am' directory. + 2002-02-26 Thien-Thi Nguyen * pre-inst-guile.in: New file. diff --git a/Makefile.am b/Makefile.am index ea26d8692..5ea356b15 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,7 @@ SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ - scripts srfi doc examples test-suite lang + scripts srfi doc examples test-suite lang am bin_SCRIPTS = guile-tools diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 5f18640a3..61e661d61 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2002-02-27 Stefan Jahn + + * gh.texi (scm transition summary): Documented some more + gh equivalents and removed appropriate FIXME's. + 2002-02-26 Thien-Thi Nguyen * Makefile.am: Update path to pre-inst-guile automake frag. diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 9b2e9850e..1cadc168a 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -929,16 +929,16 @@ Use @code{scm_str2symbol} instead. [FIXME: inconsistent naming, should be @code{scm_str02symbol}.] @item @code{gh_ints2scm} and @code{gh_doubles2scm} -No direct scm equivalent. [FIXME] +Use @code{scm_c_ints2scm} and @code{scm_c_doubles2scm} instead. @item @code{gh_chars2byvect} and @code{gh_shorts2svect} -No direct scm equivalent. [FIXME] +Use @code{scm_c_chars2byvect} and @code{scm_c_shorts2svect} instead. @item @code{gh_longs2ivect} and @code{gh_ulongs2uvect} -No direct scm equivalent. [FIXME] +Use @code{scm_c_longs2ivect} and @code{scm_c_ulongs2uvect} instead. @item @code{gh_floats2fvect} and @code{gh_doubles2dvect} -No direct scm equivalent. [FIXME] +Use @code{scm_c_floats2fvect} and @code{scm_c_doubles2dvect} instead. @item @code{gh_scm2bool} Use @code{SCM_NFALSEP} instead. @@ -993,13 +993,13 @@ instead. With the additional @var{str} argument the user can pass a pre-allocated memory chunk or leave it passing NULL. @item @code{gh_scm2chars} -No direct scm equivalent. [FIXME] +Use @code{scm_c_scm2chars} instead. @item @code{gh_scm2shorts} and @code{gh_scm2longs} -No direct scm equivalent. [FIXME] +Use @code{scm_c_shorts2scm} and @code{scm_c_longs2scm} instead. @item @code{gh_scm2floats} and @code{gh_scm2doubles} -No direct scm equivalent. [FIXME] +Use @code{scm_c_floats2scm} and @code{scm_c_doubles2scm} instead. @item @code{gh_boolean_p} Use the @code{SCM_BOOLP} macro instead, or replace @code{gh_boolean_p diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 29491889e..5e6503db0 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2002-02-27 Stefan Jahn + + * Makefile.am (EXTRA_DIST): Added the `LIBGUILEREADLINE-VERSION' + file. + 2002-02-25 Thien-Thi Nguyen * configure.in (LIBGUILEREADLINE-VERSION): diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index bf5b0ba75..c8cb59eff 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -50,7 +50,7 @@ SUFFIXES = .x $(GUILE_SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -EXTRA_DIST = $(ice9_DATA) +EXTRA_DIST = $(ice9_DATA) LIBGUILEREADLINE-VERSION ETAGS_ARGS = $(ice9_DATA) MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a3704cbe0..ae93bdc1d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2002-02-27 Stefan Jahn + + * convert.i.c, convert.c: Better range checking. + + * inet_aton.c, fports.c: Commented the inclusion of . + + * deprecation.c (vsnprintf): Define to `_vsnprintf' for + Windows (MinGW). + 2002-02-26 Thien-Thi Nguyen * Makefile.am: Update path to pre-inst-guile automake frag. diff --git a/libguile/convert.c b/libguile/convert.c index cbec8fa2a..d6606d555 100644 --- a/libguile/convert.c +++ b/libguile/convert.c @@ -56,91 +56,90 @@ #include #endif -#define CTYPE char -#define SCM2CTYPES_FN "scm_c_scm2chars" -#define SCM2CTYPES scm_c_scm2chars -#define CTYPES2SCM_FN "scm_c_chars2scm" -#define CTYPES2SCM scm_c_chars2scm -#define CTYPEFIXABLE +#define CTYPE char +#define SIZEOF_CTYPE 1 +#define SCM2CTYPES_FN "scm_c_scm2chars" +#define SCM2CTYPES scm_c_scm2chars +#define CTYPES2SCM_FN "scm_c_chars2scm" +#define CTYPES2SCM scm_c_chars2scm #define CTYPES2UVECT_FN "scm_c_chars2byvect" -#define CTYPES2UVECT scm_c_chars2byvect -#define UVECTTYPE scm_tc7_byvect -#define CTYPEMIN -128 -#define CTYPEMAX +255 -#define ARRAYTYPE1 scm_tc7_byvect -#define STRINGTYPE +#define CTYPES2UVECT scm_c_chars2byvect +#define UVECTTYPE scm_tc7_byvect +#define ARRAYTYPE scm_tc7_byvect #include "convert.i.c" -#define CTYPE short -#define SCM2CTYPES_FN "scm_c_scm2shorts" -#define SCM2CTYPES scm_c_scm2shorts -#define CTYPES2SCM_FN "scm_c_shorts2scm" -#define CTYPES2SCM scm_c_shorts2scm -#define CTYPEFIXABLE +#define CTYPE short +#define SIZEOF_CTYPE SIZEOF_SHORT +#define SCM2CTYPES_FN "scm_c_scm2shorts" +#define SCM2CTYPES scm_c_scm2shorts +#define CTYPES2SCM_FN "scm_c_shorts2scm" +#define CTYPES2SCM scm_c_shorts2scm #define CTYPES2UVECT_FN "scm_c_shorts2svect" -#define CTYPES2UVECT scm_c_shorts2svect -#define UVECTTYPE scm_tc7_svect -#define CTYPEMIN -32768 -#define CTYPEMAX +65535 -#define ARRAYTYPE1 scm_tc7_svect +#define CTYPES2UVECT scm_c_shorts2svect +#define UVECTTYPE scm_tc7_svect +#define ARRAYTYPE scm_tc7_svect #include "convert.i.c" -#define CTYPE int -#define SCM2CTYPES_FN "scm_c_scm2ints" -#define SCM2CTYPES scm_c_scm2ints -#define CTYPES2SCM_FN "scm_c_ints2scm" -#define CTYPES2SCM scm_c_ints2scm -#define CTYPES2UVECT_FN "scm_c_ints2ivect" -#define CTYPES2UVECT scm_c_ints2ivect -#define UVECTTYPE scm_tc7_ivect -#define CTYPES2UVECT_FN2 "scm_c_uints2uvect" -#define CTYPES2UVECT2 scm_c_uints2uvect -#define UVECTTYPE2 scm_tc7_uvect -#define ARRAYTYPE1 scm_tc7_ivect -#define ARRAYTYPE2 scm_tc7_uvect +#define CTYPE int +#define SIZEOF_CTYPE SIZEOF_INT +#define SCM2CTYPES_FN "scm_c_scm2ints" +#define SCM2CTYPES scm_c_scm2ints +#define CTYPES2SCM_FN "scm_c_ints2scm" +#define CTYPES2SCM scm_c_ints2scm +#define CTYPES2UVECT_FN "scm_c_ints2ivect" +#define CTYPES2UVECT scm_c_ints2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN_OPTIONAL "scm_c_uints2uvect" +#define CTYPES2UVECT_OPTIONAL scm_c_uints2uvect +#define UVECTTYPE_OPTIONAL scm_tc7_uvect +#define ARRAYTYPE scm_tc7_ivect +#define ARRAYTYPE_OPTIONAL scm_tc7_uvect #include "convert.i.c" -#define CTYPE long -#define SCM2CTYPES_FN "scm_c_scm2longs" -#define SCM2CTYPES scm_c_scm2longs -#define CTYPES2SCM_FN "scm_c_longs2scm" -#define CTYPES2SCM scm_c_longs2scm -#define CTYPES2UVECT_FN "scm_c_longs2ivect" -#define CTYPES2UVECT scm_c_longs2ivect -#define UVECTTYPE scm_tc7_ivect -#define CTYPES2UVECT_FN2 "scm_c_ulongs2uvect" -#define CTYPES2UVECT2 scm_c_ulongs2uvect -#define UVECTTYPE2 scm_tc7_uvect -#define ARRAYTYPE1 scm_tc7_ivect -#define ARRAYTYPE2 scm_tc7_uvect +#define CTYPE long +#define SIZEOF_CTYPE SIZEOF_LONG +#define SCM2CTYPES_FN "scm_c_scm2longs" +#define SCM2CTYPES scm_c_scm2longs +#define CTYPES2SCM_FN "scm_c_longs2scm" +#define CTYPES2SCM scm_c_longs2scm +#define CTYPES2UVECT_FN "scm_c_longs2ivect" +#define CTYPES2UVECT scm_c_longs2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN_OPTIONAL "scm_c_ulongs2uvect" +#define CTYPES2UVECT_OPTIONAL scm_c_ulongs2uvect +#define UVECTTYPE_OPTIONAL scm_tc7_uvect +#define ARRAYTYPE scm_tc7_ivect +#define ARRAYTYPE_OPTIONAL scm_tc7_uvect #include "convert.i.c" -#define CTYPE float -#define SCM2CTYPES_FN "scm_c_scm2floats" -#define SCM2CTYPES scm_c_scm2floats -#define CTYPES2SCM_FN "scm_c_floats2scm" -#define CTYPES2SCM scm_c_floats2scm -#define CTYPES2UVECT_FN "scm_c_floats2fvect" -#define CTYPES2UVECT scm_c_floats2fvect -#define UVECTTYPE scm_tc7_fvect -#define ARRAYTYPE1 scm_tc7_fvect -#define ARRAYTYPE2 scm_tc7_dvect -#define FLOATTYPE1 float -#define FLOATTYPE2 double +#define CTYPE float +#define SIZEOF_CTYPE 0 +#define SCM2CTYPES_FN "scm_c_scm2floats" +#define SCM2CTYPES scm_c_scm2floats +#define CTYPES2SCM_FN "scm_c_floats2scm" +#define CTYPES2SCM scm_c_floats2scm +#define CTYPES2UVECT_FN "scm_c_floats2fvect" +#define CTYPES2UVECT scm_c_floats2fvect +#define UVECTTYPE scm_tc7_fvect +#define ARRAYTYPE scm_tc7_fvect +#define ARRAYTYPE_OPTIONAL scm_tc7_dvect +#define FLOATTYPE float +#define FLOATTYPE_OPTIONAL double #include "convert.i.c" -#define CTYPE double -#define SCM2CTYPES_FN "scm_c_scm2doubles" -#define SCM2CTYPES scm_c_scm2doubles -#define CTYPES2SCM_FN "scm_c_doubles2scm" -#define CTYPES2SCM scm_c_doubles2scm -#define CTYPES2UVECT_FN "scm_c_doubles2dvect" -#define CTYPES2UVECT scm_c_doubles2dvect -#define UVECTTYPE scm_tc7_dvect -#define ARRAYTYPE1 scm_tc7_dvect -#define ARRAYTYPE2 scm_tc7_fvect -#define FLOATTYPE1 double -#define FLOATTYPE2 float +#define CTYPE double +#define SIZEOF_CTYPE 0 +#define SCM2CTYPES_FN "scm_c_scm2doubles" +#define SCM2CTYPES scm_c_scm2doubles +#define CTYPES2SCM_FN "scm_c_doubles2scm" +#define CTYPES2SCM scm_c_doubles2scm +#define CTYPES2UVECT_FN "scm_c_doubles2dvect" +#define CTYPES2UVECT scm_c_doubles2dvect +#define UVECTTYPE scm_tc7_dvect +#define ARRAYTYPE scm_tc7_dvect +#define ARRAYTYPE_OPTIONAL scm_tc7_fvect +#define FLOATTYPE double +#define FLOATTYPE_OPTIONAL float #include "convert.i.c" /* diff --git a/libguile/convert.i.c b/libguile/convert.i.c index 7ab0eae25..80a0c30ff 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -5,8 +5,8 @@ /* Convert a vector, weak vector, (if possible string, substring), list - or uniform vector into an C array. If result array in argument 2 is - NULL, malloc() a new one. If out of memory, return NULL. */ + or uniform vector into an C array. If the result array in argument 2 + is NULL, malloc() a new one. If out of memory, return NULL. */ #define FUNC_NAME SCM2CTYPES_FN CTYPE * SCM2CTYPES (SCM obj, CTYPE *data) @@ -17,40 +17,58 @@ SCM2CTYPES (SCM obj, CTYPE *data) SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)), obj, SCM_ARG1, FUNC_NAME); + /* list conversion */ if (SCM_NFALSEP (scm_list_p (obj))) { + /* traverse the given list and validate the range of each member */ SCM list = obj; for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++) { val = SCM_CAR (list); -#if defined (CTYPEMIN) && defined (CTYPEMAX) +#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS + /* check integer ranges */ if (SCM_INUMP (val)) { - long v = SCM_INUM (val); - SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + scm_t_signed_bits v = SCM_INUM (val); + CTYPE c = (CTYPE) v; + SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); } - else -#elif defined (FLOATTYPE1) - if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) + /* check big number ranges */ + else if (SCM_BIGP (val)) + { + scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME); + CTYPE c = (CTYPE) v; + SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); + } + else + /* check float types */ +#elif defined (FLOATTYPE) + /* real values, big numbers and immediate values are valid + for float conversions */ + if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) #else - if (!SCM_INUMP (val) && !SCM_BIGP (val)) -#endif - SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + if (!SCM_BIGP (val) && !SCM_INUMP (val)) +#endif /* FLOATTYPE */ + SCM_WRONG_TYPE_ARG (SCM_ARG1, val); } - if (data == NULL) - data = (CTYPE *) malloc (n * sizeof (CTYPE)); - if (data == NULL) - return NULL; + /* allocate new memory if necessary */ + if (data == NULL) + { + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; + } + + /* traverse the list once more and convert each member */ list = obj; for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++) { val = SCM_CAR (list); if (SCM_INUMP (val)) - data[i] = SCM_INUM (val); + data[i] = (CTYPE) SCM_INUM (val); else if (SCM_BIGP (val)) data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); -#ifdef FLOATTYPE1 +#if defined (FLOATTYPE) else data[i] = (CTYPE) SCM_REAL_VALUE (val); #endif @@ -58,33 +76,52 @@ SCM2CTYPES (SCM obj, CTYPE *data) return data; } + /* other conversions */ switch (SCM_TYP7 (obj)) { + /* vectors and weak vectors */ case scm_tc7_vector: case scm_tc7_wvect: n = SCM_VECTOR_LENGTH (obj); + /* traverse the given vector and validate each member */ for (i = 0; i < n; i++) { val = SCM_VELTS (obj)[i]; - -#if defined (CTYPEMIN) && defined (CTYPEMAX) +#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS + /* check integer ranges */ if (SCM_INUMP (val)) { - long v = SCM_INUM (val); - SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + scm_t_signed_bits v = SCM_INUM (val); + CTYPE c = (CTYPE) v; + SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); } + /* check big number ranges */ + else if (SCM_BIGP (val)) + { + scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME); + CTYPE c = (CTYPE) v; + SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); + } else -#elif defined (FLOATTYPE1) - if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) + /* check float types */ +#elif defined (FLOATTYPE) + /* real values, big numbers and immediate values are valid + for float conversions */ + if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) #else - if (!SCM_INUMP (val) && !SCM_BIGP (val)) -#endif - SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + if (!SCM_BIGP (val) && !SCM_INUMP (val)) +#endif /* FLOATTYPE */ + SCM_WRONG_TYPE_ARG (SCM_ARG1, val); } + + /* allocate new memory if necessary */ if (data == NULL) - data = (CTYPE *) malloc (n * sizeof (CTYPE)); - if (data == NULL) - return NULL; + { + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; + } + + /* traverse the vector once more and convert each member */ for (i = 0; i < n; i++) { val = SCM_VELTS (obj)[i]; @@ -92,7 +129,7 @@ SCM2CTYPES (SCM obj, CTYPE *data) data[i] = (CTYPE) SCM_INUM (val); else if (SCM_BIGP (val)) data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); -#ifdef FLOATTYPE1 +#if defined (FLOATTYPE) else data[i] = (CTYPE) SCM_REAL_VALUE (val); #endif @@ -100,37 +137,43 @@ SCM2CTYPES (SCM obj, CTYPE *data) break; #ifdef HAVE_ARRAYS - case ARRAYTYPE1: -#ifdef ARRAYTYPE2 - case ARRAYTYPE2: + /* array conversions (uniform vectors) */ + case ARRAYTYPE: +#ifdef ARRAYTYPE_OPTIONAL + case ARRAYTYPE_OPTIONAL: #endif n = SCM_UVECTOR_LENGTH (obj); + + /* allocate new memory if necessary */ if (data == NULL) - data = (CTYPE *) malloc (n * sizeof (CTYPE)); - if (data == NULL) - return NULL; -#ifdef FLOATTYPE2 - if (SCM_TYP7 (obj) == ARRAYTYPE2) + { + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; + } + +#ifdef FLOATTYPE_OPTIONAL + /* float <-> double conversions */ + if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL) { for (i = 0; i < n; i++) - data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i]; + data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i]; } else #endif + /* copy whole array */ memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); break; #endif /* HAVE_ARRAYS */ -#ifdef STRINGTYPE +#if SIZEOF_CTYPE == 1 case scm_tc7_string: n = SCM_STRING_LENGTH (obj); if (data == NULL) - data = (CTYPE *) malloc (n * sizeof (CTYPE)); - if (data == NULL) - return NULL; + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); break; -#endif /* STRINGTYPE */ +#endif default: SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); @@ -150,32 +193,34 @@ CTYPES2UVECT (const CTYPE *data, long n) { char *v; - SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); - v = scm_gc_malloc (sizeof (CTYPE) * n, "vector"); + v = scm_gc_malloc (n * sizeof (CTYPE), "uvect"); memcpy (v, data, n * sizeof (CTYPE)); return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); } #undef FUNC_NAME -#ifdef UVECTTYPE2 -#define FUNC_NAME CTYPES2UVECT_FN2 +#ifdef UVECTTYPE_OPTIONAL +#define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL SCM -CTYPES2UVECT2 (const unsigned CTYPE *data, long n) +CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n) { char *v; SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); - v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector"); + v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect"); memcpy (v, data, n * sizeof (unsigned CTYPE)); - return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v); + return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL), + (scm_t_bits) v); } #undef FUNC_NAME -#endif /* UVECTTYPE2 */ +#endif /* UVECTTYPE_OPTIONAL */ #endif /* HAVE_ARRAYS */ + /* Converts a C array into a vector. */ #define FUNC_NAME CTYPES2SCM_FN SCM @@ -189,13 +234,10 @@ CTYPES2SCM (const CTYPE *data, long n) v = scm_c_make_vector (n, SCM_UNSPECIFIED); velts = SCM_VELTS (v); for (i = 0; i < n; i++) -#ifdef FLOATTYPE1 +#ifdef FLOATTYPE velts[i] = scm_make_real ((double) data[i]); -#elif defined (CTYPEFIXABLE) - velts[i] = SCM_MAKINUM (data[i]); #else - velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) : - scm_i_long2big (data[i])); + velts[i] = SCM_MAKINUM (data[i]); #endif return v; } @@ -209,33 +251,22 @@ CTYPES2SCM (const CTYPE *data, long n) #undef CTYPE #undef CTYPES2UVECT #undef CTYPES2UVECT_FN -#ifdef CTYPEFIXABLE -#undef CTYPEFIXABLE -#endif #undef UVECTTYPE -#ifdef UVECTTYPE2 -#undef CTYPES2UVECT2 -#undef CTYPES2UVECT_FN2 -#undef UVECTTYPE2 +#ifdef UVECTTYPE_OPTIONAL +#undef CTYPES2UVECT_OPTIONAL +#undef CTYPES2UVECT_FN_OPTIONAL +#undef UVECTTYPE_OPTIONAL #endif -#ifdef CTYPEMIN -#undef CTYPEMIN +#undef SIZEOF_CTYPE +#undef ARRAYTYPE +#ifdef ARRAYTYPE_OPTIONAL +#undef ARRAYTYPE_OPTIONAL #endif -#ifdef CTYPEMAX -#undef CTYPEMAX +#ifdef FLOATTYPE +#undef FLOATTYPE #endif -#undef ARRAYTYPE1 -#ifdef ARRAYTYPE2 -#undef ARRAYTYPE2 -#endif -#ifdef FLOATTYPE1 -#undef FLOATTYPE1 -#endif -#ifdef FLOATTYPE2 -#undef FLOATTYPE2 -#endif -#ifdef STRINGTYPE -#undef STRINGTYPE +#ifdef FLOATTYPE_OPTIONAL +#undef FLOATTYPE_OPTIONAL #endif /* diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 17f3641dc..55a82aa4f 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -51,6 +51,11 @@ #include "libguile/strings.h" #include "libguile/ports.h" +/* Windows defines. */ +#ifdef __MINGW32__ +#define vsnprintf _vsnprintf +#endif + #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/libguile/fports.c b/libguile/fports.c index e4e34700f..882405cec 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -69,7 +69,8 @@ size_t fwrite (); #include #include "libguile/iselect.h" -/* Some defines for Windows. */ + +/* Some defines for Windows (native port, not Cygwin). */ #ifdef __MINGW32__ # include # include diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c index f8e92541f..fe43d6eb2 100644 --- a/libguile/inet_aton.c +++ b/libguile/inet_aton.c @@ -39,6 +39,7 @@ static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93"; #include #ifdef __MINGW32__ +/* Include for MinGW only. Cygwin will have the latter. */ #include #else #include From ba040a71a0ea8f7e2eabdbfe994062005943cbef Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Thu, 28 Feb 2002 00:23:08 +0000 Subject: [PATCH 13/41] * extension/dynamic-root.text: example Scheme code. --- devel/ChangeLog | 84 ------------------------------ devel/extension/dynamic-root.text | 86 ------------------------------- 2 files changed, 170 deletions(-) diff --git a/devel/ChangeLog b/devel/ChangeLog index 70ffefe55..e69de29bb 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,84 +0,0 @@ -2002-02-05 Thien-Thi Nguyen - - * build/pre-inst-guile.text: Initial revision. - -2001-12-04 Gary Houston - - * some discussion in extension/dynamic-root.text. - -2001-11-28 Gary Houston - - * added extension directory and extension/dynamic-root.text with - a description of the problem. - -2001-11-14 Thien-Thi Nguyen - - * policy/api.text: Initial revision. - -2001-11-12 mvo - - * translation/lisp-and-scheme.text: - *** empty log message *** - -2001-07-07 mvo - - * policy/goals.text: Sneak in the translators... - -2001-06-27 Thien-Thi Nguyen - - * README: Remove tasks.text. - - * tasks.text: Bye bye (contents folded into ../TODO). - -2001-05-08 Martin Grabmueller - - * modules/module-snippets.texi: Fixed a lot of typos and clarified - some points. Thanks to Neil for the typo+questions patch! - -2001-05-07 Martin Grabmueller - - * modules/module-snippets.texi: New file, documenting the module - system. Placed in `devel' for review purposes. - -2001-03-16 Martin Grabmueller - - * modules: New directory. - - * modules/module-layout.text: New file. - -2000-08-26 Mikael Djurfeldt - - * strings: New directory. - - * strings/sharedstr.text (sharedstr.text): New file. - -2000-08-12 Mikael Djurfeldt - - * translate: New directory. - - * translate/langtools.text: New file. - -2000-05-30 Mikael Djurfeldt - - * tasks.text: Use outline-mode. Added section for tasks in need - of attention. - -2000-05-29 Mikael Djurfeldt - - * tasks.text: New file. - -2000-05-25 Mikael Djurfeldt - - * README: New file. - - * build/snarf-macros.text: New file. - -2000-05-20 Mikael Djurfeldt - - * policy/goals.text, policy/principles.text, policy/plans.text: - New files. - -2000-03-21 Mikael Djurfeldt - - * policy/names.text: New file. - diff --git a/devel/extension/dynamic-root.text b/devel/extension/dynamic-root.text index 87d351854..e69de29bb 100644 --- a/devel/extension/dynamic-root.text +++ b/devel/extension/dynamic-root.text @@ -1,86 +0,0 @@ -The Problem -=========== - -Certain applications embedding Guile (Scwm, Guppi) have found it -necessary to include hacked versions of scm_call_with_dynamic_root. - -They want to run user callbacks, but don't want the callback to be -able to longjmp (via exceptions or continuations) randomly in and out, -since the C code hasn't been written to dynamically wind/unwind local -state. This is likely to be a common problem for users of Guile as an -extension language. - -libguile/root.c:scm_call_with_dynamic_root seems to almost do this, -but it has the apparently undesirable behaviour of unwinding the -dynamic state when the protected procedure is called. In addition -the implementation looks a bit heavy for use in every callback. - -scm_call_with_dynamic_root was implemented to support threading, so -the needs of libguile itself should be considered. Other -considerations are how any new interface interacts with error handling -and reporting; whether a new interface is convenient to use from C; -whether a new interface should also be available to Scheme code. - -Discussion -========== - -There are two ways that longjmp may be invoked from a Scheme callback: -raising an exception or invoking a continuation. Exceptions can be -caught using scm_internal_catch, so it could be argued that the new -interface only needs to block continuations. - -However there are two problems with this: firstly it's unlikely that -anybody would want to block continuations without also catching -exceptions, so it's more convenient to use a single facility set up -both types of blocking. Secondly, the fact that exceptions and -continuations can be treated separately in Guile is just an -implementation detail: in general in Scheme it's possible to use -continuations to implement an exception mechanism, and it's -undesirable to tie a new language feature to an implementation detail -when it can be avoided, even at the C level. - -Hence, the interface should take at least a) the callback to be -protected b) and exception handler and associated handler data to be -passed to scm_internal_catch. - -On which side of the continuation barrier should be exception handler -be installed? Logically it belongs on the same side as the callback: -i.e., if the callback raises an exception then the handler can catch -it without crossing it the continuation barrier. But what happens if -the handler raises another exception? This doesn't seem like an -important concern, since the hander is under control of the code that -is trying to protect itself. It should be sufficient to warn in the -documentation that such exceptions produce undefined behaviour and -allow them to cross the continuation barrier. - -How should the callback procedure be passed to the interface and -invoked? Should it be like scm_internal_catch where it's passed as a -C procedure (scm_t_catch_body) which is applied to user data (void *)? -For a procedure designed to be used from C, this is the most -convenient, since constructing closures in C is difficult. It also -gives symmetry with scm_internal_catch. - -On the other hand, the body procedure is expected to be a Scheme -closure in most cases. This suggests implementing two C procedures, -the first taking four arguments: - -scm_t_catch_body body, void *body_data, -scm_t_catch_handler handler, void *handler_data - -and the second taking three arguments: -SCM body, scm_t_catch_handler handler, void *handler_data - -If there is also to be a Scheme interface, then it would be implemented -with a third variant: -SCM body, SCM handler - -The second and third variants would be implemented by calling the -first, similar to the old scm_call_with_dynamic_root and its wrappers. - -The return value from all variants should be the result of calling -the body, unless an exception occurred in which case it's the result -of calling the handler. So the return type is SCM, as for -scm_internal_catch. - -Yet to be discussed: libguile usage and threads, error handling and -reporting, convenience of use, Scheme-level interface. From de6334e97d36ada8bda2cacccdb688d2d91bac8e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Feb 2002 05:09:19 +0000 Subject: [PATCH 14/41] Add version table. --- devel/policy/api.text | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/devel/policy/api.text b/devel/policy/api.text index f73dfc6c7..b53a8613f 100644 --- a/devel/policy/api.text +++ b/devel/policy/api.text @@ -1,4 +1,4 @@ -* Intro / Index (last modified: $Date: 2001-12-08 12:50:37 $) +* Intro / Index (last modified: $Date: 2002-02-28 05:09:19 $) This working document explains the design of the libguile API, specifically the interface to the C programming language. @@ -41,6 +41,17 @@ Starting w/ guile-1.7.x, in concurrence w/ an effort to make libguile available to usloth windows platforms, the naked library was once again dressed w/ the "SCM_API interface". +Here is a table of versions (! means planned): + + guile libguile readline qthreads srfi-4 -13-14 + --------------------------------------------------- + 1.3.4 6.0.0 0.0.0 0.0.0 - - + 1.4 9.0.0 0.0.0 0.0.0 - - + 1.4.1 10.0.0 TBD 15.0.0 - - ! + 1.6.x 15.0.0 10.0.0 15.0.0 1.0.0 1.0.0 ! + + Note: These are libtool-style versions: CURRENT:REVISION:AGE + * Decisions @@ -86,19 +97,19 @@ strings into that table you would have to store a pointer to the corresponding version of 'free' with every string? We should demand such coding from all guile users? -The proposal itself read: For a clean memory interface of a client program +The proposal itself read: For a clean memory interface of a client program to libguile we use the following functions from libguile: - * scm_c_malloc -- should be used to allocate memory returned by some + * scm_c_malloc -- should be used to allocate memory returned by some of the SCM to C converter functions in libguile if the client program does not supply memory * scm_c_free -- must be used by the client program to free the memory - returned by the SCM to C converter functions in + returned by the SCM to C converter functions in libguile if the client program did not supply a buffer * scm_c_realloc -- to be complete, do not know a real purpose yet -Yet another proposal regarding this problem reads as follows: We could make +Yet another proposal regarding this problem reads as follows: We could make life easier, if we supplied the following: [in gc.h] @@ -115,8 +126,8 @@ SCM_API scm_t_free_func scm_c_free; } Then the SCM to C converters allocating memory to store their results use -scm_c_malloc() instead of simply malloc(). This way all libguile/Unix users -can stick to the previous free() policy, saying that you need to free() +scm_c_malloc() instead of simply malloc(). This way all libguile/Unix users +can stick to the previous free() policy, saying that you need to free() pointers delivered by libguile. On the other hand M$-Windows users can pass their own malloc()-function-pointer to the library and use their own free() then. Basically this can be achieved in the following order: @@ -129,7 +140,7 @@ then. Basically this can be achieved in the following order: free (str); } -This policy is still discussed: +This policy is still discussed: If there is one global variable scm_c_malloc, then setting it within one thread may interfere with another thread that expects scm_c_malloc to be set differently. In other words, you would have to introduce some locking From ec99391afd7973f36b7fb7c459ab2c4d609c0e57 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Feb 2002 06:10:47 +0000 Subject: [PATCH 15/41] Typofix; nfc. --- pre-inst-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pre-inst-guile.in b/pre-inst-guile.in index 428e04b14..5c44a9d77 100644 --- a/pre-inst-guile.in +++ b/pre-inst-guile.in @@ -28,7 +28,7 @@ # passing ARGS to it. In the process, env var GUILE is clobbered, and the # following env vars are modified (but not clobbered): # GUILE_LOAD_PATH -# LTDL_LOAD_PATH +# LTDL_LIBRARY_PATH # # This script can be used as a drop-in replacement for $bindir/guile; # if there is a discrepency in behavior, that's a bug. From 5ddf900c86feee0accfade7f31a1a8a60513192e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Thu, 28 Feb 2002 06:11:37 +0000 Subject: [PATCH 16/41] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index b0c352451..7e0a4ed83 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2002-02-27 Thien-Thi Nguyen + + * pre-inst-guile.in: Typofix; nfc. + 2002-02-27 Stefan Jahn * Makefile.am (SUBDIRS): Added the `am' directory. From d115af0eea8d8c19cb0abc4acb26e647810aafe7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 20:55:49 +0000 Subject: [PATCH 17/41] (image_tag): Changed type to scm_t_bits. (make_image): Use scm_gc_malloc instead of scm_must_malloc. (free_image): Use scm_gc_free instead of free. Return zero. --- doc/example-smob/image-type.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/doc/example-smob/image-type.c b/doc/example-smob/image-type.c index f9b783737..1a03c9ce2 100644 --- a/doc/example-smob/image-type.c +++ b/doc/example-smob/image-type.c @@ -21,7 +21,7 @@ #include #include -static scm_bits_t image_tag; +static scm_t_bits image_tag; struct image { int width, height; @@ -49,10 +49,10 @@ make_image (SCM name, SCM s_width, SCM s_height) width = SCM_INUM (s_width); height = SCM_INUM (s_height); - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image = (struct image *) scm_gc_malloc (sizeof (struct image), "image"); image->width = width; image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); + image->pixels = scm_gc_malloc (width * height, "image pixels"); image->name = name; image->update_func = SCM_BOOL_F; @@ -93,12 +93,11 @@ static size_t free_image (SCM image_smob) { struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - size_t size = image->width * image->height + sizeof (struct image); - free (image->pixels); - free (image); + scm_gc_free (image->pixels, image->width * image->height, "image pixels"); + scm_gc_free (image, sizeof (struct image), "image"); - return size; + return 0; } static int From 4c7fbdfbd56e300020586c637a3cbf0e144f511d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 20:56:41 +0000 Subject: [PATCH 18/41] (malloc-stats): Refer to scm_gc_malloc instead of to scm_must_malloc. --- doc/ref/scheme-debug.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/scheme-debug.texi b/doc/ref/scheme-debug.texi index 602fecf3f..f939c03be 100644 --- a/doc/ref/scheme-debug.texi +++ b/doc/ref/scheme-debug.texi @@ -42,7 +42,7 @@ to the current output port. @deffn {Scheme Procedure} malloc-stats Return an alist ((@var{what} . @var{n}) ...) describing number of malloced objects. -@var{what} is the second argument to @code{scm_must_malloc}, +@var{what} is the second argument to @code{scm_gc_malloc}, @var{n} is the number of objects of that type currently allocated. @end deffn From eabd8acf879771ed4df46076e92ede77fa60c9b2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 20:58:50 +0000 Subject: [PATCH 19/41] Use scm_gc_malloc and scm_gc_free instead of scm_must_malloc and free in example code. Updated text for the new memory management functions. --- doc/ref/data-rep.texi | 98 +++++++++++++------------------------------ 1 file changed, 29 insertions(+), 69 deletions(-) diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi index 3d419392f..5624ddfbe 100644 --- a/doc/ref/data-rep.texi +++ b/doc/ref/data-rep.texi @@ -46,7 +46,7 @@ @c essay @sp 10 @c essay @comment The title is printed in a large font. @c essay @title Data Representation in Guile -@c essay @subtitle $Id: data-rep.texi,v 1.3 2002-01-08 08:29:00 ttn Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.4 2002-02-28 20:58:50 mvo Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1410,15 +1410,15 @@ refers to. The default smob mark function is to not mark any data. @xref{Garbage Collecting Smobs}, for more details. @item free -Guile will apply this function to each instance of the new type it could -not find any live pointers to. The function should release all +Guile will apply this function to each instance of the new type it +could not find any live pointers to. The function should release all resources held by the object and return the number of bytes released. -This is analogous to the Java finalization method-- it is invoked at an -unspecified time (when garbage collection occurs) after the object is -dead. The default free function frees the smob data (if the size of the -struct passed to @code{scm_make_smob_type} is non-zero) using -@code{scm_must_free} and returns the size of that struct. @xref{Garbage -Collecting Smobs}, for more details. +This is analogous to the Java finalization method-- it is invoked at +an unspecified time (when garbage collection occurs) after the object +is dead. The default free function frees the smob data (if the size +of the struct passed to @code{scm_make_smob_type} is non-zero) using +@code{scm_gc_free}. @xref{Garbage Collecting Smobs}, for more +details. @item print @c GJB:FIXME:: @var{exp} and @var{port} need to refer to a prototype of @@ -1557,49 +1557,13 @@ macro for this situation: @deftypefnx Macro fn_returns SCM_RETURN_NEWSMOB3(scm_t_bits tag, void *data1, void *data2, void *data3) This macro expands to a block of code that creates a smob instance of the type with tag @var{tag} and smob data @var{data} (or @var{data1}, -@var{data2}, and @var{data3}), and returns that @code{SCM} value. It -should be the last piece of code in a block. +@var{data2}, and @var{data3}), and causes the surrounding function to +return that @code{SCM} value. It should be the last piece of code in +a block. @end deftypefn -Guile provides the following functions for managing memory, which are -often helpful when implementing smobs: - -@deftypefun {char *} scm_must_malloc (size_t @var{len}, char *@var{what}) -Allocate @var{len} bytes of memory, using @code{malloc}, and return a -pointer to them. - -If there is not enough memory available, invoke the garbage collector, -and try once more. If there is still not enough, signal an error, -reporting that we could not allocate @var{what}. - -This function also helps maintain statistics about the size of the heap. -@end deftypefun - -@deftypefun {char *} scm_must_realloc (char *@var{addr}, size_t @var{olen}, size_t @var{len}, char *@var{what}) -Resize (and possibly relocate) the block of memory at @var{addr}, to -have a size of @var{len} bytes, by calling @code{realloc}. Return a -pointer to the new block. - -If there is not enough memory available, invoke the garbage collector, -and try once more. If there is still not enough, signal an error, -reporting that we could not allocate @var{what}. - -The value @var{olen} should be the old size of the block of memory at -@var{addr}; it is only used for keeping statistics on the size of the -heap. -@end deftypefun - -@deftypefun void scm_must_free (char *@var{addr}) -Free the block of memory at @var{addr}, using @code{free}. If -@var{addr} is zero, signal an error, complaining of an attempt to free -something that is already free. - -This does no record-keeping; instead, the smob's @code{free} function -must take care of that. - -This function isn't usually sufficiently different from the usual -@code{free} function to be worth using. -@end deftypefun +Guile provides some functions for managing memory, which are often +helpful when implementing smobs. @xref{Memory Blocks}. Continuing the above example, if the global variable @code{image_tag} @@ -1634,10 +1598,10 @@ make_image (SCM name, SCM s_width, SCM s_height) width = SCM_INUM (s_width); height = SCM_INUM (s_height); - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image = (struct image *) scm_gc_malloc (sizeof (struct image), "image"); image->width = width; image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); + image->pixels = scm_gc_malloc (width * height, "image pixels"); image->name = name; image->update_func = SCM_BOOL_F; @@ -1645,7 +1609,6 @@ make_image (SCM name, SCM s_width, SCM s_height) @} @end example - @node Type checking @subsection Type checking @@ -1794,10 +1757,9 @@ as its only argument. The @code{free} function must release any resources used by the smob. However, it need not free objects managed by the collector; the -collector will take care of them. The return type of the @code{free} -function should be @code{size_t}, an unsigned integral type; the -@code{free} function should return the number of bytes released, to help -the collector maintain statistics on the size of the heap. +collector will take care of them. For historical reasons, the return +type of the @code{free} function should be @code{size_t}, an unsigned +integral type; the @code{free} function should always return zero. Here is how we might write the @code{free} function for the image smob type: @@ -1806,12 +1768,11 @@ size_t free_image (SCM image_smob) @{ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - size_t size = image->width * image->height + sizeof (*image); - free (image->pixels); - free (image); + scm_gc_free (image->pixels, image->width * image->height, "image pixels"); + scm_gc_free (image, sizeof (struct image), "image"); - return size; + return 0; @} @end example @@ -1850,10 +1811,10 @@ make_image (SCM name, SCM s_width, SCM s_height) width = SCM_INUM (s_width); height = SCM_INUM (s_height); - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image = (struct image *) scm_gc_malloc (sizeof (struct image), "image"); image->width = width; image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); + image->pixels = scm_gc_malloc (width * height, "image pixels"); /* THESE TWO LINES HAVE CHANGED: */ image->name = scm_string_copy (name); @@ -1981,10 +1942,10 @@ make_image (SCM name, SCM s_width, SCM s_height) width = SCM_INUM (s_width); height = SCM_INUM (s_height); - image = (struct image *) scm_must_malloc (sizeof (struct image), "image"); + image = (struct image *) scm_gc_malloc (sizeof (struct image), "image"); image->width = width; image->height = height; - image->pixels = scm_must_malloc (width * height, "image pixels"); + image->pixels = scm_gc_malloc (width * height, "image pixels"); image->name = name; image->update_func = SCM_BOOL_F; @@ -2025,12 +1986,11 @@ static size_t free_image (SCM image_smob) @{ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob); - size_t size = image->width * image->height + sizeof (struct image); - free (image->pixels); - free (image); + scm_gc_free (image->pixels, image->width * image->height, "image pixels"); + scm_gc_free (image, sizeof (struct image), "image"); - return size; + return 0; @} static int From 621f22b16177f8e8cae571bb85eb770af537c544 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 20:58:59 +0000 Subject: [PATCH 20/41] *** empty log message *** --- doc/example-smob/ChangeLog | 6 ++++++ doc/ref/ChangeLog | 9 +++++++++ 2 files changed, 15 insertions(+) diff --git a/doc/example-smob/ChangeLog b/doc/example-smob/ChangeLog index 60d10c03d..5e0ea0cfa 100644 --- a/doc/example-smob/ChangeLog +++ b/doc/example-smob/ChangeLog @@ -1,3 +1,9 @@ +2002-02-28 Marius Vollmer + + * image-type.c (image_tag): Changed type to scm_t_bits. + (make_image): Use scm_gc_malloc instead of scm_must_malloc. + (free_image): Use scm_gc_free instead of free. Return zero. + 2001-05-30 Martin Grabmueller * image-type.c: Adapted to new typing and naming convention. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 61e661d61..d624f1587 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,12 @@ +2002-02-28 Marius Vollmer + + * data-rep.texi: Use scm_gc_malloc and scm_gc_free instead of + scm_must_malloc and free in example code. Updated text for the + new memory management functions. + + * scheme-debug.texi (malloc-stats): Refer to scm_gc_malloc instead + of to scm_must_malloc. + 2002-02-27 Stefan Jahn * gh.texi (scm transition summary): Documented some more From 3392a571b588e55eba7c65577fe8e4d9b5200355 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 23:42:22 +0000 Subject: [PATCH 21/41] (Upgrading from scm_must_malloc et al): New section. --- doc/ref/scheme-memory.texi | 56 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/doc/ref/scheme-memory.texi b/doc/ref/scheme-memory.texi index 45f0f883b..9ffb9a341 100644 --- a/doc/ref/scheme-memory.texi +++ b/doc/ref/scheme-memory.texi @@ -128,6 +128,62 @@ the memory management overhead very low. @end deftypefn +@subsection Upgrading from scm_must_malloc et al + +Version 1.6 of Guile and earlier did not have the functions from the +previous section. In their place, it had the functions +@code{scm_must_malloc}, @code{scm_must_realloc} and +@code{scm_must_free}. This section explains why we want you to stop +using them, and how to do this. + +The functions @code{scm_must_malloc} and @code{scm_must_realloc} +behaved like @code{scm_gc_malloc} and @code{scm_gc_realloc} do now, +respectively. They would inform the GC about the newly allocated +memory via the internal equivalent of +@code{scm_gc_register_collectable_memory}. However, +@code{scm_must_free} did not unregister the memory it was about to +free. The usual way to unregister memory was to return its size from +a smob free function. + +This disconnectedness of the actual freeing of memory and reporting +this to the GC proved to be bad in practice. It was easy to make +mistakes and report the wrong size because allocating and freeing was +not done with symmetric code, and because it is cumbersome to compute +the total size of nested data structures that were freed with multiple +calls to @code{scm_must_free}. Additionally, there was no equivalent +to @code{scm_malloc}, and it was tempting to just use +@code{scm_must_malloc} and never to tell the GC that the memory has +been freed. + +The effect was that the internal statistics kept by the GC drifted out +of sync with reality and could even overflow in long running programs. +When this happened, the result was a dramatic increase in (senseless) +GC activity which would effectively stop the program dead. + +The functions @code{scm_done_malloc} and @code{scm_done_free} were +introduced to help restore balance to the force, but existing bugs did +not magically disappear, of course. + +Therefore we decided to force everybody to review their code by +deprecating the existing functions and introducing new ones in their +place that are hopefully easier to use correctly. + +For every use of @code{scm_must_malloc} you need to decide whether to +use @code{scm_malloc} or @code{scm_gc_malloc} in its place. When the +memory block is not part of a smob or some other Scheme object whose +lifetime is ultimately managed by the garbage collector, use +@code{scm_malloc} and @code{free}. When it is part of a smob, use +@code{scm_gc_malloc} and change the smob free function to use +@code{scm_gc_free} instead of @code{scm_must_free} or @code{free} and +make it return zero. + +The important thing is to always pair @code{scm_malloc} with +@code{free}; and to always pair @code{scm_gc_malloc} with +@code{scm_gc_free}. + +The same reasoning applies to @code{scm_must_realloc} and +@code{scm_realloc} versus @code{scm_gc_realloc}. + @node Weak References @section Weak References From eee065c4fe9204f3e7d7202e81b14d38bc00b7a3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 28 Feb 2002 23:42:29 +0000 Subject: [PATCH 22/41] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index d624f1587..03c3ee36e 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2002-03-01 Marius Vollmer + + * scheme-memory.texi (Upgrading from scm_must_malloc et al): New + section. + 2002-02-28 Marius Vollmer * data-rep.texi: Use scm_gc_malloc and scm_gc_free instead of From 228a24ef30e635e58af0e4fe5fc9b9db738abeff Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 1 Mar 2002 00:19:20 +0000 Subject: [PATCH 23/41] Changes in doc/ref: * api.txt, data-rep.texi: Renamed the struct scm_cell to scm_t_cell. * data-rep.texi: Renamed scm_alloc_cell to scm_cell and scm_alloc_double_cell to scm_double_cell. Changes in libguile: * gc.c (SCM_HEAP_SEG_SIZE, CELL_UP, CELL_DN, NEXT_DATA_CELL, init_heap_seg, alloc_some_heap), gc.h (struct scm_cell, struct scm_t_cell, SCM_CELLPTR, SCM_GC_CARD_SIZE, SCM_GC_IN_CARD_HEADERP), tags.h (SCM_CELLP): Renamed the struct scm_cell and all its uses to scm_t_cell in accordance to Guile's naming scheme for types. * alist.c (scm_acons), convert.i.c (CTYPES2UVECT, CTYPES2UVECT_OPTIONAL), coop-threads.c (scm_call_with_new_thread, scm_spawn_thread), debug.c (scm_make_debugobj), environments.c (scm_make_environment), eval.c (scm_closure), fports.c (scm_fdes_to_port), gc.c (scm_deprecated_newcell, scm_deprecated_newcell2), inline.h (scm_alloc_cell, scm_cell), list.c (SCM_I_CONS), numbers.c (scm_i_mkbig), pairs.c (scm_cons), ports.c (scm_void_port), procs.c (scm_c_make_subr, scm_makcclo), smob.c (scm_make_smob), smob.h (SCM_NEWSMOB), strings.c (scm_take_str, scm_allocate_string), strports.c (scm_mkstrport), unif.c (scm_make_uve), variable.c (make_variable), vectors.c (scm_c_make_vector), vports.c (scm_make_soft_port): Renamed scm_alloc_cell to scm_cell. * environments.c (core_environments_observe), gc.c (scm_deprecated_newcell2), goops.c (wrap_init, scm_wrap_object), inline.h (scm_alloc_double_cell, scm_double_cell), num2float.i.c (FLOAT2NUM), numbers.c (scm_make_real), procs.c (scm_make_procedure_with_setter), smob.h (SCM_NEWSMOB2, SCM_NEWSMOB3), struct.c (scm_make_struct, scm_make_vtable_vtable), symbols.c (scm_mem2symbol, scm_mem2uninterned_symbol), weaks.c (allocate_weak_vector): Renamed scm_alloc_double_cell to scm_double_cell. --- NEWS | 15 ++++++++++----- doc/ref/ChangeLog | 8 ++++++++ doc/ref/api.txt | 8 ++++---- doc/ref/data-rep.texi | 16 ++++++++-------- libguile/ChangeLog | 33 +++++++++++++++++++++++++++++++++ libguile/alist.c | 6 +++--- libguile/convert.i.c | 6 +++--- libguile/coop-threads.c | 4 ++-- libguile/debug.c | 2 +- libguile/environments.c | 12 +++++------- libguile/eval.c | 3 +-- libguile/fports.c | 2 +- libguile/gc.c | 34 +++++++++++++++++----------------- libguile/gc.h | 12 ++++++------ libguile/gh_data.c | 2 +- libguile/goops.c | 12 ++++++------ libguile/inline.h | 12 ++++++------ libguile/list.c | 2 +- libguile/num2float.i.c | 2 +- libguile/numbers.c | 4 ++-- libguile/pairs.c | 2 +- libguile/ports.c | 2 +- libguile/procs.c | 10 +++++----- libguile/smob.c | 2 +- libguile/smob.h | 9 ++++----- libguile/strings.c | 4 ++-- libguile/strports.c | 2 +- libguile/struct.c | 10 +++++----- libguile/symbols.c | 22 ++++++++++------------ libguile/tags.h | 2 +- libguile/unif.c | 10 +++++----- libguile/variable.c | 2 +- libguile/vectors.c | 3 +-- libguile/vports.c | 2 +- libguile/weaks.c | 18 ++++++++---------- 35 files changed, 166 insertions(+), 129 deletions(-) diff --git a/NEWS b/NEWS index dd3e4c1db..76aa249c3 100644 --- a/NEWS +++ b/NEWS @@ -52,6 +52,12 @@ Use `substring-move!' instead. * Changes to the C interface +** The struct scm_cell has been renamed to scm_t_cell + +This is in accordance to Guile's naming scheme for types. Note that +the name scm_cell is now used for a function that allocates and +initializes a new cell (see below). + ** New functions for memory management A new set of functions for memory management has been added since the @@ -94,11 +100,10 @@ SCM_SRFI4_IMPORT, for the corresponding libraries. ** SCM_NEWCELL and SCM_NEWCELL2 have been deprecated. -Use the new functions scm_alloc_cell and scm_alloc_double_cell -instead. The old macros had problems because with them allocation and -initialization was separated and the GC could sometimes observe half -initialized cells. Only careful coding by the user of SCM_NEWCELL and -SCM_NEWCELL2 could make this safe and efficient. +Use the new functions scm_cell and scm_double_cell instead. The old macros +had problems because with them allocation and initialization was separated and +the GC could sometimes observe half initialized cells. Only careful coding by +the user of SCM_NEWCELL and SCM_NEWCELL2 could make this safe and efficient. Changes since Guile 1.4: diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 03c3ee36e..aa7ea31fe 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,11 @@ +2002-03-01 Dirk Herrmann + + * api.txt, data-rep.texi: Renamed the struct scm_cell to + scm_t_cell. + + * data-rep.texi: Renamed scm_alloc_cell to scm_cell and + scm_alloc_double_cell to scm_double_cell. + 2002-03-01 Marius Vollmer * scheme-memory.texi (Upgrading from scm_must_malloc et al): New diff --git a/doc/ref/api.txt b/doc/ref/api.txt index 367cbbf95..cc26b839f 100644 --- a/doc/ref/api.txt +++ b/doc/ref/api.txt @@ -66,8 +66,8 @@ determined from the scm_bits_t value that is delivered by SCM_UNPACK (x). Non immediate objects ===================== -- (scm_cell *) SCM2PTR (SCM x) (FIXME:: this name should be changed) -- SCM PTR2SCM (scm_cell * x) (FIXME:: this name should be changed) +- (scm_t_cell *) SCM2PTR (SCM x) (FIXME:: this name should be changed) +- SCM PTR2SCM (scm_t_cell * x) (FIXME:: this name should be changed) A scheme object of type SCM that does not fullfill the SCM_IMP predicate holds an encoded reference to a heap cell. This reference can be decoded to a C @@ -76,14 +76,14 @@ a heap cell into a SCM value is done using the PTR2SCM macro. Note that it is also possible to transform a non immediate SCM value by using SCM_UNPACK into a scm_bits_t variable. Hower, the result of SCM_UNPACK may -not be used as a pointer to a scm_cell: Only SCM2PTR is guaranteed to +not be used as a pointer to a scm_t_cell: Only SCM2PTR is guaranteed to transform a SCM object into a valid pointer to a heap cell. Also, it is not allowed to apply PTR2SCM to anything that is not a valid pointer to a heap cell. Summary: * Only use SCM2PTR for SCM values for which SCM_IMP is false! -* Don't use '(scm_cell*) SCM_UNPACK (x)'! Use 'SCM2PTR (x)' instead! +* Don't use '(scm_t_cell*) SCM_UNPACK (x)'! Use 'SCM2PTR (x)' instead! * Don't use PTR2SCM for anything but a cell pointer! diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi index 5624ddfbe..d3a9aa678 100644 --- a/doc/ref/data-rep.texi +++ b/doc/ref/data-rep.texi @@ -46,7 +46,7 @@ @c essay @sp 10 @c essay @comment The title is printed in a large font. @c essay @title Data Representation in Guile -@c essay @subtitle $Id: data-rep.texi,v 1.4 2002-02-28 20:58:50 mvo Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.5 2002-03-01 00:19:20 dirk Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1150,13 +1150,13 @@ This reference can be decoded to a C pointer to a heap cell using the @code{SCM} value is done using the @code{PTR2SCM} macro. @c (FIXME:: this name should be changed) -@deftypefn Macro (scm_cell *) SCM2PTR (SCM @var{x}) +@deftypefn Macro (scm_t_cell *) SCM2PTR (SCM @var{x}) Extract and return the heap cell pointer from a non-immediate @code{SCM} object @var{x}. @end deftypefn @c (FIXME:: this name should be changed) -@deftypefn Macro SCM PTR2SCM (scm_cell * @var{x}) +@deftypefn Macro SCM PTR2SCM (scm_t_cell * @var{x}) Return a @code{SCM} value that encodes a reference to the heap cell pointer @var{x}. @end deftypefn @@ -1164,7 +1164,7 @@ pointer @var{x}. Note that it is also possible to transform a non-immediate @code{SCM} value by using @code{SCM_UNPACK} into a @code{scm_t_bits} variable. However, the result of @code{SCM_UNPACK} may not be used as a pointer to -a @code{scm_cell}: only @code{SCM2PTR} is guaranteed to transform a +a @code{scm_t_cell}: only @code{SCM2PTR} is guaranteed to transform a @code{SCM} object into a valid pointer to a heap cell. Also, it is not allowed to apply @code{PTR2SCM} to anything that is not a valid pointer to a heap cell. @@ -1176,7 +1176,7 @@ Summary: Only use @code{SCM2PTR} on @code{SCM} values for which @code{SCM_IMP} is false! @item -Don't use @code{(scm_cell *) SCM_UNPACK (@var{x})}! Use @code{SCM2PTR +Don't use @code{(scm_t_cell *) SCM_UNPACK (@var{x})}! Use @code{SCM2PTR (@var{x})} instead! @item Don't use @code{PTR2SCM} for anything but a cell pointer! @@ -1198,7 +1198,7 @@ the code in @code{}. If you just want to allocate pairs, use @code{scm_cons}. -@deftypefn Function SCM scm_alloc_cell (scm_t_bits word_0, scm_t_bits word_1) +@deftypefn Function SCM scm_cell (scm_t_bits word_0, scm_t_bits word_1) Allocate a new cell, initialize the two slots with @var{word_0} and @var{word_1}, and return it. @@ -1207,8 +1207,8 @@ If you want to pass a @code{SCM} object, you need to use @code{SCM_UNPACK}. @end deftypefn -@deftypefn Function SCM scm_alloc_double_cell (scm_t_bits word_0, scm_t_bits word_1, scm_t_bits word_2, scm_t_bits word_3) -Like @code{scm_alloc_cell}, but allocates a double cell with four +@deftypefn Function SCM scm_double_cell (scm_t_bits word_0, scm_t_bits word_1, scm_t_bits word_2, scm_t_bits word_3) +Like @code{scm_cell}, but allocates a double cell with four slots. @end deftypefn diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ae93bdc1d..f86d494d0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,36 @@ +2002-03-01 Dirk Herrmann + + * gc.c (SCM_HEAP_SEG_SIZE, CELL_UP, CELL_DN, NEXT_DATA_CELL, + init_heap_seg, alloc_some_heap), gc.h (struct scm_cell, struct + scm_t_cell, SCM_CELLPTR, SCM_GC_CARD_SIZE, + SCM_GC_IN_CARD_HEADERP), tags.h (SCM_CELLP): Renamed the struct + scm_cell and all its uses to scm_t_cell in accordance to Guile's + naming scheme for types. + + * alist.c (scm_acons), convert.i.c (CTYPES2UVECT, + CTYPES2UVECT_OPTIONAL), coop-threads.c (scm_call_with_new_thread, + scm_spawn_thread), debug.c (scm_make_debugobj), environments.c + (scm_make_environment), eval.c (scm_closure), fports.c + (scm_fdes_to_port), gc.c (scm_deprecated_newcell, + scm_deprecated_newcell2), inline.h (scm_alloc_cell, scm_cell), + list.c (SCM_I_CONS), numbers.c (scm_i_mkbig), pairs.c (scm_cons), + ports.c (scm_void_port), procs.c (scm_c_make_subr, scm_makcclo), + smob.c (scm_make_smob), smob.h (SCM_NEWSMOB), strings.c + (scm_take_str, scm_allocate_string), strports.c (scm_mkstrport), + unif.c (scm_make_uve), variable.c (make_variable), vectors.c + (scm_c_make_vector), vports.c (scm_make_soft_port): Renamed + scm_alloc_cell to scm_cell. + + * environments.c (core_environments_observe), gc.c + (scm_deprecated_newcell2), goops.c (wrap_init, scm_wrap_object), + inline.h (scm_alloc_double_cell, scm_double_cell), num2float.i.c + (FLOAT2NUM), numbers.c (scm_make_real), procs.c + (scm_make_procedure_with_setter), smob.h (SCM_NEWSMOB2, + SCM_NEWSMOB3), struct.c (scm_make_struct, scm_make_vtable_vtable), + symbols.c (scm_mem2symbol, scm_mem2uninterned_symbol), weaks.c + (allocate_weak_vector): Renamed scm_alloc_double_cell to + scm_double_cell. + 2002-02-27 Stefan Jahn * convert.i.c, convert.c: Better range checking. diff --git a/libguile/alist.c b/libguile/alist.c index a3cdde604..07bd64356 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -59,9 +59,9 @@ SCM_DEFINE (scm_acons, "acons", 3, 0, 0, "function is @emph{not} destructive; @var{alist} is not modified.") #define FUNC_NAME s_scm_acons { - return scm_alloc_cell (SCM_UNPACK (scm_alloc_cell (SCM_UNPACK (key), - SCM_UNPACK (value))), - SCM_UNPACK (alist)); + return scm_cell (SCM_UNPACK (scm_cell (SCM_UNPACK (key), + SCM_UNPACK (value))), + SCM_UNPACK (alist)); } #undef FUNC_NAME diff --git a/libguile/convert.i.c b/libguile/convert.i.c index 80a0c30ff..0d78711c7 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -197,7 +197,7 @@ CTYPES2UVECT (const CTYPE *data, long n) n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); v = scm_gc_malloc (n * sizeof (CTYPE), "uvect"); memcpy (v, data, n * sizeof (CTYPE)); - return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); + return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); } #undef FUNC_NAME @@ -212,8 +212,8 @@ CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n) n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect"); memcpy (v, data, n * sizeof (unsigned CTYPE)); - return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL), - (scm_t_bits) v); + return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL), + (scm_t_bits) v); } #undef FUNC_NAME #endif /* UVECTTYPE_OPTIONAL */ diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index 95498b310..a3f4018e0 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -257,7 +257,7 @@ scm_call_with_new_thread (SCM argl) /* Allocate thread locals. */ root = scm_make_root (scm_root->handle); /* Make thread. */ - thread = scm_alloc_cell (scm_tc16_thread, 0); + thread = scm_cell (scm_tc16_thread, 0); SCM_DEFER_INTS; argl = scm_cons (thread, argl); /* Note that we couldn't pass a pointer to argl as data since the @@ -343,7 +343,7 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data, /* Allocate thread locals. */ root = scm_make_root (scm_root->handle); /* Make thread. */ - thread = scm_alloc_cell (scm_tc16_thread, 0); + thread = scm_cell (scm_tc16_thread, 0); SCM_DEFER_INTS; data->u.thread = thread; diff --git a/libguile/debug.c b/libguile/debug.c index 82b647b3a..11f34cd2c 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -539,7 +539,7 @@ SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, SCM scm_make_debugobj (scm_t_debug_frame *frame) { - return scm_alloc_cell (scm_tc16_debugobj, (scm_t_bits) frame); + return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame); } diff --git a/libguile/environments.c b/libguile/environments.c index 3db13b036..10ce8c8ca 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -119,7 +119,7 @@ scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol) SCM scm_make_environment (void *type) { - return scm_alloc_cell (scm_tc16_environment, (scm_t_bits) type); + return scm_cell (scm_tc16_environment, (scm_t_bits) type); } @@ -662,12 +662,10 @@ struct core_environments_base { static SCM core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p) { - SCM observer; - - observer = scm_alloc_double_cell (scm_tc16_observer, - SCM_UNPACK (env), - SCM_UNPACK (data), - (scm_t_bits) proc); + SCM observer = scm_double_cell (scm_tc16_observer, + SCM_UNPACK (env), + SCM_UNPACK (data), + (scm_t_bits) proc); if (!weak_p) { diff --git a/libguile/eval.c b/libguile/eval.c index 2fff70468..4c3d53e95 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3836,8 +3836,7 @@ scm_closure (SCM code, SCM env) { SCM z; SCM closcar = scm_cons (code, SCM_EOL); - z = scm_alloc_cell (SCM_UNPACK (closcar) + scm_tc3_closure, - (scm_t_bits) env); + z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env); scm_remember_upto_here (closcar); return z; } diff --git a/libguile/fports.c b/libguile/fports.c index 882405cec..2fe0bee0c 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -436,7 +436,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL); } - port = scm_alloc_cell (scm_tc16_fport, 0); + port = scm_cell (scm_tc16_fport, 0); SCM_DEFER_INTS; pt = scm_add_to_port_table (port); SCM_SETPTAB_ENTRY (port, pt); diff --git a/libguile/gc.c b/libguile/gc.c index 6e781f721..3da2861e1 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -277,9 +277,9 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb # define SCM_HEAP_SEG_SIZE 32768L #else # ifdef sequent -# define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell)) +# define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_t_cell)) # else -# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell)) +# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) # endif #endif /* Make heap grow with factor 1.5 */ @@ -287,7 +287,7 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb #define SCM_INIT_MALLOC_LIMIT 100000 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span) +/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_t_cell * span) aligned inner bounds for allocated storage */ #ifdef PROT386 @@ -299,12 +299,12 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span))) # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p)) # else -# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L)) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & ((long)(p)+sizeof(scm_t_cell)*(span)-1L)) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ -#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) +#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1) #define CLUSTER_SIZE_IN_BYTES(freelist) \ @@ -1544,7 +1544,7 @@ gc_sweep_freelist_finish (scm_t_freelist *freelist) #define NEXT_DATA_CELL(ptr, span) \ do { \ - scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ + scm_t_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \ CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \ : nxt__); \ @@ -2201,9 +2201,9 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) NEXT_DATA_CELL (ptr, span); while (ptr < seg_end) { - scm_cell *nxt = ptr; - scm_cell *prv = NULL; - scm_cell *last_card = NULL; + scm_t_cell *nxt = ptr; + scm_t_cell *prv = NULL; + scm_t_cell *last_card = NULL; int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1; NEXT_DATA_CELL(nxt, span); @@ -2216,7 +2216,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) while (n_data_cells--) { - scm_cell *card = SCM_GC_CELL_CARD (ptr); + scm_t_cell *card = SCM_GC_CELL_CARD (ptr); SCM scmptr = PTR2SCM (ptr); nxt = ptr; NEXT_DATA_CELL (nxt, span); @@ -2239,7 +2239,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) /* sanity check */ { - scm_cell *ref = seg_end; + scm_t_cell *ref = seg_end; NEXT_DATA_CELL (ref, span); if (ref != ptr) /* [cmm] looks like the segment size doesn't divide cleanly by @@ -2344,7 +2344,7 @@ alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy) #endif if (len < min_cells) len = min_cells + freelist->cluster_size; - len *= sizeof (scm_cell); + len *= sizeof (scm_t_cell); /* force new sampling */ freelist->collected = LONG_MAX; } @@ -2831,18 +2831,18 @@ SCM scm_deprecated_newcell (void) { scm_c_issue_deprecation_warning - ("SCM_NEWCELL is deprecated. Use `scm_alloc_cell' instead.\n"); + ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n"); - return scm_alloc_cell (scm_tc16_allocated, 0); + return scm_cell (scm_tc16_allocated, 0); } SCM scm_deprecated_newcell2 (void) { scm_c_issue_deprecation_warning - ("SCM_NEWCELL2 is deprecated. Use `scm_alloc_double_cell' instead.\n"); + ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n"); - return scm_alloc_double_cell (scm_tc16_allocated, 0, 0, 0); + return scm_double_cell (scm_tc16_allocated, 0, 0, 0); } #endif /* SCM_ENABLE_DEPRECATED == 1 */ diff --git a/libguile/gc.h b/libguile/gc.h index 7d575bc96..fce0add19 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -52,24 +52,24 @@ -typedef struct scm_cell +typedef struct scm_t_cell { scm_t_bits word_0; scm_t_bits word_1; -} scm_cell; +} scm_t_cell; /* SCM_CELLPTR is a pointer to a cons cell which may be compared or * differenced. */ -typedef scm_cell * SCM_CELLPTR; +typedef scm_t_cell * SCM_CELLPTR; /* Cray machines have pointers that are incremented once for each word, * rather than each byte, the 3 most significant bits encode the byte * within the word. The following macros deal with this by storing the * native Cray pointers like the ones that looks like scm expects. This - * is done for any pointers that might appear in the car of a scm_cell, + * is done for any pointers that might appear in the car of a scm_t_cell, * pointers to scm_vector elts, functions, &c are not munged. */ #ifdef _UNICOS @@ -83,14 +83,14 @@ typedef scm_cell * SCM_CELLPTR; #define SCM_GC_CARD_N_HEADER_CELLS 1 #define SCM_GC_CARD_N_CELLS 256 -#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_cell)) +#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)) #define SCM_GC_CARD_N_DATA_CELLS (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) #define SCM_GC_CARD_BVEC_SIZE_IN_LIMBS \ ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LIMB_BITS - 1) / SCM_C_BVEC_LIMB_BITS) #define SCM_GC_IN_CARD_HEADERP(x) \ - SCM_PTR_LT ((scm_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS) + SCM_PTR_LT ((scm_t_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS) #define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_limb *) ((card)->word_0)) #define SCM_GC_SET_CARD_BVEC(card, bvec) \ diff --git a/libguile/gh_data.c b/libguile/gh_data.c index ceef34db0..31c9ea730 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -149,7 +149,7 @@ gh_doubles2scm (const double *d, long n) static SCM makvect (char *m, size_t len, int type) { - return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m); + return scm_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m); } SCM diff --git a/libguile/goops.c b/libguile/goops.c index 5c9e0f99b..fde237149 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1306,9 +1306,9 @@ wrap_init (SCM class, SCM *m, long n) for (i = 0; i < n; i++) m[i] = SCM_GOOPS_UNBOUND; - return scm_alloc_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class)) - | scm_tc3_struct), - (scm_t_bits) m, 0, 0); + return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class)) + | scm_tc3_struct), + (scm_t_bits) m, 0, 0); } SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, @@ -2580,9 +2580,9 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM scm_wrap_object (SCM class, void *data) { - return scm_alloc_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct, - (scm_t_bits) data, - 0, 0); + return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct, + (scm_t_bits) data, + 0, 0); } SCM scm_components; diff --git a/libguile/inline.h b/libguile/inline.h index 9d3b6fca1..19566bcce 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -55,7 +55,7 @@ #ifdef HAVE_INLINE static inline SCM -scm_alloc_cell (scm_t_bits car, scm_t_bits cdr) +scm_cell (scm_t_bits car, scm_t_bits cdr) { SCM z; @@ -102,8 +102,8 @@ scm_alloc_cell (scm_t_bits car, scm_t_bits cdr) } static inline SCM -scm_alloc_double_cell (scm_t_bits car, scm_t_bits cbr, - scm_t_bits ccr, scm_t_bits cdr) +scm_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr) { SCM z; @@ -153,9 +153,9 @@ scm_alloc_double_cell (scm_t_bits car, scm_t_bits cbr, #else /* !HAVE_INLINE */ -SCM_API SCM scm_alloc_cell (scm_t_bits car, scm_t_bits cdr); -SCM_API SCM scm_alloc_double_cell (scm_t_bits car, scm_t_bits cbr, - scm_t_bits ccr, scm_t_bits cdr); +SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); +SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, + scm_t_bits ccr, scm_t_bits cdr); #endif diff --git a/libguile/list.c b/libguile/list.c index 2197a61f5..7b0161cdf 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -61,7 +61,7 @@ #define SCM_I_CONS(cell,x,y) \ do { \ - cell = scm_alloc_cell ((scm_t_bits)x, (scm_t_bits)y); \ + cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \ } while (0) SCM diff --git a/libguile/num2float.i.c b/libguile/num2float.i.c index a3e669266..b393ba9b7 100644 --- a/libguile/num2float.i.c +++ b/libguile/num2float.i.c @@ -32,7 +32,7 @@ SCM FLOAT2NUM (FTYPE n) { SCM z; - z = scm_alloc_double_cell (scm_tc16_real, 0, 0, 0); + z = scm_double_cell (scm_tc16_real, 0, 0, 0); SCM_REAL_VALUE (z) = n; return z; } diff --git a/libguile/numbers.c b/libguile/numbers.c index bdb6f4ca3..98c045b78 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1390,7 +1390,7 @@ scm_i_mkbig (size_t nlen, int sign) base = scm_gc_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); - v = scm_alloc_cell (SCM_MAKE_BIGNUM_TAG (nlen, sign), (scm_t_bits) base); + v = scm_cell (SCM_MAKE_BIGNUM_TAG (nlen, sign), (scm_t_bits) base); return v; } @@ -2827,7 +2827,7 @@ SCM scm_make_real (double x) { SCM z; - z = scm_alloc_double_cell (scm_tc16_real, 0, 0, 0); + z = scm_double_cell (scm_tc16_real, 0, 0, 0); SCM_REAL_VALUE (z) = x; return z; } diff --git a/libguile/pairs.c b/libguile/pairs.c index 5216de8bb..bc4831480 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -80,7 +80,7 @@ SCM_DEFINE (scm_cons, "cons", 2, 0, 0, "sense of @code{eq?}) from every previously existing object.") #define FUNC_NAME s_scm_cons { - return scm_alloc_cell (SCM_UNPACK (x), SCM_UNPACK (y)); + return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index 33c6cab89..4acf1fdd6 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1531,7 +1531,7 @@ scm_void_port (char *mode_str) SCM answer; scm_t_port * pt; - answer = scm_alloc_cell (scm_tc16_void_port, 0); + answer = scm_cell (scm_tc16_void_port, 0); SCM_DEFER_INTS; mode_bits = scm_mode_bits (mode_str); pt = scm_add_to_port_table (answer); diff --git a/libguile/procs.c b/libguile/procs.c index afc81cd23..dae2e104e 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -85,7 +85,7 @@ scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) } entry = scm_subr_table_size; - z = scm_alloc_cell ((entry << 8) + type, (scm_t_bits) fcn); + z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn); scm_subr_table[entry].handle = z; scm_subr_table[entry].name = scm_str2symbol (name); scm_subr_table[entry].generic = 0; @@ -160,7 +160,7 @@ scm_makcclo (SCM proc, size_t len) for (i = 0; i < len; ++i) base [i] = SCM_UNPACK (SCM_UNSPECIFIED); - s = scm_alloc_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); + s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); SCM_SET_CCLO_SUBR (s, proc); return s; } @@ -320,9 +320,9 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, { SCM_VALIDATE_PROC (1, procedure); SCM_VALIDATE_PROC (2, setter); - return scm_alloc_double_cell (scm_tc7_pws, - SCM_UNPACK (procedure), - SCM_UNPACK (setter), 0); + return scm_double_cell (scm_tc7_pws, + SCM_UNPACK (procedure), + SCM_UNPACK (setter), 0); } #undef FUNC_NAME diff --git a/libguile/smob.c b/libguile/smob.c index 94133a797..e907fb107 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -462,7 +462,7 @@ scm_make_smob (scm_t_bits tc) scm_t_bits data = (size > 0 ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) : 0); - return scm_alloc_cell (tc, data); + return scm_cell (tc, data); } diff --git a/libguile/smob.h b/libguile/smob.h index be87b255e..50de243ce 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -72,7 +72,7 @@ typedef struct scm_smob_descriptor #define SCM_NEWSMOB(z, tc, data) \ do { \ - z = scm_alloc_cell ((tc), (scm_t_bits) (data)); \ + z = scm_cell ((tc), (scm_t_bits) (data)); \ } while (0) #define SCM_RETURN_NEWSMOB(tc, data) \ @@ -83,8 +83,7 @@ do { \ #define SCM_NEWSMOB2(z, tc, data1, data2) \ do { \ - z = scm_alloc_double_cell ((tc), (scm_t_bits)(data1), \ - (scm_t_bits)(data2), 0); \ + z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \ } while (0) #define SCM_RETURN_NEWSMOB2(tc, data1, data2) \ @@ -95,8 +94,8 @@ do { \ #define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ do { \ - z = scm_alloc_double_cell ((tc), (scm_t_bits)(data1), \ - (scm_t_bits)(data2), (scm_t_bits)(data3)); \ + z = scm_double_cell ((tc), (scm_t_bits)(data1), \ + (scm_t_bits)(data2), (scm_t_bits)(data3)); \ } while (0) #define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ diff --git a/libguile/strings.c b/libguile/strings.c index c7517626d..d8580b7eb 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -132,7 +132,7 @@ scm_take_str (char *s, size_t len) SCM_ASSERT_RANGE (2, scm_ulong2num (len), len <= SCM_STRING_MAX_LENGTH); - answer = scm_alloc_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) s); + answer = scm_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) s); scm_gc_register_collectable_memory (s, len+1, "string"); return answer; @@ -194,7 +194,7 @@ scm_allocate_string (size_t len) mem = (char *) scm_gc_malloc (len + 1, "string"); mem[len] = 0; - s = scm_alloc_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) mem); + s = scm_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) mem); return s; } diff --git a/libguile/strports.c b/libguile/strports.c index daf68b5f3..0a75a4068 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -279,7 +279,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) scm_out_of_range (caller, pos); if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); - z = scm_alloc_cell (scm_tc16_strport, 0); + z = scm_cell (scm_tc16_strport, 0); SCM_DEFER_INTS; pt = scm_add_to_port_table (z); SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes); diff --git a/libguile/struct.c b/libguile/struct.c index a384c8647..075388e42 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -460,9 +460,9 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, "struct"); - handle = scm_alloc_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable)) - + scm_tc3_struct), - (scm_t_bits) data, 0, 0); + handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable)) + + scm_tc3_struct), + (scm_t_bits) data, 0, 0); scm_struct_init (handle, layout, data, tail_elts, init); SCM_ALLOW_INTS; return handle; @@ -539,8 +539,8 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, "struct"); - handle = scm_alloc_double_cell ((scm_t_bits) data + scm_tc3_struct, - (scm_t_bits) data, 0, 0); + handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct, + (scm_t_bits) data, 0, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); SCM_ALLOW_INTS; diff --git a/libguile/symbols.c b/libguile/symbols.c index c6979f9a4..57ead5cab 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -125,12 +125,11 @@ scm_mem2symbol (const char *name, size_t len) SCM cell; SCM slot; - symbol = scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_gc_strndup (name, len, - "symbol"), - raw_hash, - SCM_UNPACK (scm_cons (SCM_BOOL_F, - SCM_EOL))); + symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), + (scm_t_bits) scm_gc_strndup (name, len, + "symbol"), + raw_hash, + SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); slot = SCM_VELTS (symbols) [hash]; cell = scm_cons (symbol, SCM_UNDEFINED); @@ -146,12 +145,11 @@ scm_mem2uninterned_symbol (const char *name, size_t len) size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2 + SCM_T_BITS_MAX/2 + 1); - return scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_gc_strndup (name, len, - "symbol"), - raw_hash, - SCM_UNPACK (scm_cons (SCM_BOOL_F, - SCM_EOL))); + return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), + (scm_t_bits) scm_gc_strndup (name, len, + "symbol"), + raw_hash, + SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); } SCM diff --git a/libguile/tags.h b/libguile/tags.h index 1e9090ede..37d4a0f60 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -533,7 +533,7 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #if (SCM_ENABLE_DEPRECATED == 1) -#define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) +#define SCM_CELLP(x) (((sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) #define SCM_NCELLP(x) (!SCM_CELLP (x)) #endif diff --git a/libguile/unif.c b/libguile/unif.c index 96bdfa4f0..b900df50e 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -170,11 +170,11 @@ scm_make_uve (long k, SCM prot) SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - v = scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (k), - (scm_t_bits) scm_gc_malloc (i, "vector")); + v = scm_cell (SCM_MAKE_BITVECTOR_TAG (k), + (scm_t_bits) scm_gc_malloc (i, "vector")); } else - v = scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); + v = scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); return v; } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) @@ -239,8 +239,8 @@ scm_make_uve (long k, SCM prot) SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); - return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (k, type), - (scm_t_bits) scm_gc_malloc (i, "vector")); + return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type), + (scm_t_bits) scm_gc_malloc (i, "vector")); } #undef FUNC_NAME diff --git a/libguile/variable.c b/libguile/variable.c index 66f82b9de..b2710c113 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -68,7 +68,7 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) static SCM make_variable (SCM init) { - return scm_alloc_cell (scm_tc7_variable, SCM_UNPACK (init)); + return scm_cell (scm_tc7_variable, SCM_UNPACK (init)); } SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0, diff --git a/libguile/vectors.c b/libguile/vectors.c index c1dfe840f..bdc943760 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -215,8 +215,7 @@ scm_c_make_vector (unsigned long int k, SCM fill) else base = NULL; - v = scm_alloc_cell (SCM_MAKE_VECTOR_TAG (k, scm_tc7_vector), - (scm_t_bits) base); + v = scm_cell (SCM_MAKE_VECTOR_TAG (k, scm_tc7_vector), (scm_t_bits) base); scm_remember_upto_here_1 (fill); return v; diff --git a/libguile/vports.c b/libguile/vports.c index c25bc204f..2cf94feae 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -189,7 +189,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, SCM z; SCM_VALIDATE_VECTOR_LEN (1,pv,5); SCM_VALIDATE_STRING (2, modes); - z = scm_alloc_cell (scm_tc16_sfport, 0); + z = scm_cell (scm_tc16_sfport, 0); SCM_DEFER_INTS; pt = scm_add_to_port_table (z); scm_port_non_buffer (pt); diff --git a/libguile/weaks.c b/libguile/weaks.c index 08d570069..a5b194eca 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -84,20 +84,18 @@ allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller) base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector"); for (j = 0; j != c_size; ++j) base[j] = SCM_UNPACK (fill); - v = scm_alloc_double_cell (SCM_MAKE_VECTOR_TAG (c_size, - scm_tc7_wvect), - (scm_t_bits) base, - type, - SCM_UNPACK (SCM_EOL)); + v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect), + (scm_t_bits) base, + type, + SCM_UNPACK (SCM_EOL)); scm_remember_upto_here_1 (fill); } else { - v = scm_alloc_double_cell (SCM_MAKE_VECTOR_TAG (0, - scm_tc7_wvect), - (scm_t_bits) NULL, - type, - SCM_UNPACK (SCM_EOL)); + v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect), + (scm_t_bits) NULL, + type, + SCM_UNPACK (SCM_EOL)); } return v; From 039576cf091f68d2956575dc827610fe36116fcb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 1 Mar 2002 07:37:43 +0000 Subject: [PATCH 24/41] Update. --- doc/guile-api.alist | 2255 ++++++++++++++++++++++--------------------- 1 file changed, 1134 insertions(+), 1121 deletions(-) diff --git a/doc/guile-api.alist b/doc/guile-api.alist index c1a6c46e1..4f79b6139 100644 --- a/doc/guile-api.alist +++ b/doc/guile-api.alist @@ -1,69 +1,71 @@ -;; Generated Fri Feb 15 13:35:09 PST 2002 by guile-scripts/scan-api -- do not edit! -;; guile: /home/ttn/build/.gnu/guile-core/pre-inst-guile . -;; sofile: libguile/.libs/libguile.so.10.0.0 - +;; Generated Thu Feb 28 23:33:42 PST 2002 by guile-scripts/scan-api -- do not edit! ( +(meta (GUILE_LOAD_PATH . "") + (LTDL_LOAD_PATH . "") + (guile . "pre-inst-guile") + (sofile . "libguile/.libs/libguile.so.15.0.0") + (pwd . "/home/ttn/tmp/.tmp")) (scheme -($abs "#") +($acos "#") +($acosh "#") +($asin "#") +($asinh "#") +($atan "#") +($atan2 "#") +($atanh "#") +($cos "#") +($cosh "#") +($exp "#") +($expt "#") +($log "#") +($sin "#") +($sinh "#") +($sqrt "#") +($tan "#") +($tanh "#") (%cond-expand-features "") (%cond-expand-table "") -(%deliver-signals "#") +(%get-pre-modules-obarray "#") (%guile-build-info "") -(%init-goops-builtins "#") +(%init-rdelim-builtins "#") +(%init-rw-builtins "#") +(%library-dir "#") +(%load-announce "#") (%load-extensions "") -(%load-hook "#") (%load-path "") (%load-verbosely "") -(%make-void-port "#") (%module-public-interface "") (%module-public-interface "") (%nil "") -(%package-data-dir "#") +(%print-module "#") +(%print-values "#") +(%search-load-path "#") +(%site-dir "#") +(* "#") (*features* "") (*null-device* "") (*random-state* "") (*unspecified* "") -(+ "#bool "#") +(- "#") +(->bool "#bool (x)>") +(/ "#") +(1+ "#") +(1- "#") +(< "#") +(<= "#") ( "") ( "") ( "") -(= "# "#= "# "#>") +(>= "#=>") (@apply "") (@bind "") (@call-with-current-continuation "") @@ -318,83 +320,83 @@ (_IOLBF "") (_IONBF "") (abort-hook "") -(abs "#") +(accept "#") +(access? "#") +(acons "#") +(acos "#") +(acosh "#") +(add-hook! "#") (after-backtrace-hook "") (after-error-hook "") (after-eval-hook "") (after-gc-hook "") (after-print-hook "") (after-read-hook "") -(alarm "#") (and "") -(and-map "# "#") +(and=> "# (value procedure)>") +(angle "#") (app "") -(append "#list "#") +(append! "#") +(apply "#") +(apply-to-args "#") +(apply:nconc2last "#") +(array->list "#list>") +(array-contents "#") +(array-copy! "#") +(array-copy-in-order! "#") +(array-dimensions "#") +(array-equal? "#") +(array-fill! "#") +(array-for-each "#") +(array-in-bounds? "#") +(array-index-map! "#") +(array-map! "#") +(array-map-in-order! "#") +(array-prototype "#") +(array-rank "#") +(array-ref "#") +(array-set! "#") +(array-shape "#") +(array? "#") +(ash "#") +(asin "#") +(asinh "#") +(assert-defmacro?! "#") +(assert-load-verbosity "#") +(assert-repl-print-unspecified "#") +(assert-repl-silence "#") +(assert-repl-verbosity "#") +(assoc "#") +(assoc-ref "#") +(assoc-remove! "#") +(assoc-set! "#") +(assq "#") +(assq-ref "#") +(assq-remove! "#") +(assq-set! "#") +(assv "#") +(assv-ref "#") +(assv-remove! "#") +(assv-set! "#") +(async "#") +(async-mark "#") +(atan "#") +(atanh "#") +(autoload-done! "#") +(autoload-done-or-in-progress? "#") +(autoload-in-progress! "#") (autoloads-done "") (autoloads-in-progress "") -(backtrace "#") +(bad-throw "#") +(basename "#") +(basic-load "#") +(batch-mode? "#") +(beautify-user-module! "#") (before-backtrace-hook "") (before-error-hook "") (before-eval-hook "") @@ -403,123 +405,123 @@ (before-signal-stack "") (begin "") (begin-deprecated "") -(bind "#") +(bit-count "#") +(bit-count* "#") +(bit-extract "#") +(bit-invert! "#") +(bit-position "#") +(bit-set*! "#") +(boolean? "#") +(caaaar "#") +(caaadr "#") +(caaar "#") +(caadar "#") +(caaddr "#") +(caadr "#") +(caar "#") +(cadaar "#") +(cadadr "#") +(cadar "#") +(caddar "#") +(cadddr "#") +(caddr "#") +(cadr "#") +(call-with-current-continuation "#") +(call-with-dynamic-root "#") +(call-with-input-file "#") +(call-with-input-string "#") +(call-with-new-thread "#") +(call-with-output-file "#") +(call-with-output-string "#") +(call-with-values "#") +(car "#") (case "") -(catch "#integer "#=? "#? "#") +(cdaaar "#") +(cdaadr "#") +(cdaar "#") +(cdadar "#") +(cdaddr "#") +(cdadr "#") +(cdar "#") +(cddaar "#") +(cddadr "#") +(cddar "#") +(cdddar "#") +(cddddr "#") +(cdddr "#") +(cddr "#") +(cdr "#") +(ceiling "#") +(char->integer "#integer>") +(char-alphabetic? "#") +(char-ci<=? "#") +(char-ci") +(char-ci=? "#") +(char-ci>=? "#=?>") +(char-ci>? "#?>") (char-code-limit "") -(char-downcase "#=? "#? "#") +(char-is-both? "#") +(char-lower-case? "#") +(char-numeric? "#") +(char-ready? "#") +(char-upcase "#") +(char-upper-case? "#") +(char-whitespace? "#") +(char<=? "#") +(char") +(char=? "#") +(char>=? "#=?>") +(char>? "#?>") +(char? "#") +(chdir "#") +(chmod "#") +(chown "#") +(chroot "#") +(class-of "#") +(close "#") +(close-fdes "#") +(close-input-port "#") +(close-io-port "#") +(close-output-port "#") +(close-port "#") +(closedir "#") +(closure? "#") (collect "") -(command-line "#") +(compile-define-module-args "#") +(compile-interface-spec "#") +(complex? "#") (cond "") (cond-expand "") -(cond-expand-provide "#") +(connect "#") +(cons "#") +(cons* "#") +(cons-source "#") +(copy-file "#") +(copy-random-state "#") +(copy-tree "#") +(cos "#") +(cosh "#") +(crypt "#") +(ctermid "#") +(current-error-port "#") +(current-input-port "#") +(current-load-port "#") +(current-module "#") +(current-output-port "#") +(current-time "#") +(cuserid "#") +(debug-disable "#") +(debug-enable "#") +(debug-object? "#") +(debug-options "#") +(debug-options-interface "#") (debug-set! "") -(default-lazy-handler "#") (define "") (define-macro "") (define-module "") @@ -527,967 +529,967 @@ (define-private "") (define-public "") (define-syntax-macro "") -(defined? "#") (defmacro "") (defmacro-public "") -(defmacro-transformer "#") +(defmacro:syntax-transformer "#") +(defmacro:transformer "#") +(defmacro? "#") (delay "") -(delete "#uniform-array "#") +(delete! "#") +(delete-file "#") +(delete1! "#") +(delq "#") +(delq! "#") +(delq1! "#") +(delv "#") +(delv! "#") +(delv1! "#") +(destroy-guardian! "#") +(dimensions->uniform-array "#uniform-array>") +(directory-stream? "#") +(dirname "#") +(display "#") +(display-application "#") +(display-backtrace "#") +(display-error "#") +(display-usage-report "#") (do "") -(doubly-weak-hash-table? "#fdes "#inport "#outport "#port "#") +(drain-input "#") +(dup "#") +(dup->fdes "#fdes>") +(dup->inport "#inport (port/fd . maybe-fd)>") +(dup->outport "#outport (port/fd . maybe-fd)>") +(dup->port "#port (port/fd mode . maybe-fd)>") +(dup2 "#") +(duplicate-port "#") +(dynamic-args-call "#") +(dynamic-call "#") +(dynamic-func "#") +(dynamic-link "#") +(dynamic-object? "#") +(dynamic-root "#") +(dynamic-unlink "#") +(dynamic-wind "#") +(enclose-array "#") +(endgrent "#") +(endhostent "#") +(endnetent "#") +(endprotoent "#") +(endpwent "#") +(endservent "#") +(entity? "#") +(env-module "#") +(environ "#") +(environment-bound? "#") +(environment-cell "#") +(environment-define "#") +(environment-fold "#") +(environment-module "#") +(environment-observe "#") +(environment-observe-weak "#") +(environment-ref "#") +(environment-set! "#") +(environment-undefine "#") +(environment-unobserve "#") +(environment? "#") +(eof-object? "#") +(eq? "#") +(equal? "#") +(eqv? "#") +(error "#") +(error-catching-loop "#") +(error-catching-repl "#") +(eval "#") (eval-case "") -(eval-disable "#") +(eval-enable "#") +(eval-environment-imported "#") +(eval-environment-local "#") +(eval-environment-set-imported! "#") +(eval-environment-set-local! "#") +(eval-environment? "#") +(eval-options "#") +(eval-options-interface "#") (eval-set! "") -(eval-string "#inexact "#") +(evaluator-traps-interface "#") +(even? "#") +(exact->inexact "#inexact>") +(exact? "#") +(execl "#") +(execle "#") +(execlp "#") +(exit "#") (exit-hook "") -(exp "#") (export "") -(export-environment-private "#") +(export-environment-set-private! "#") +(export-environment-set-signature! "#") +(export-environment-signature "#") +(export-environment? "#") (export-syntax "") -(expt "#") (false-if-exception "") -(fcntl "#inport "#outport "#ports "#") +(fdes->inport "#inport (fdes)>") +(fdes->outport "#outport (fdes)>") +(fdes->ports "#ports>") +(fdopen "#") +(feature? "#") +(file-exists? "#") +(file-is-directory? "#") +(file-port? "#") +(file-position "#") +(file-set-position "#") +(fileno "#") +(flock "#") +(floor "#") +(fluid-ref "#") +(fluid-set! "#") +(fluid? "#") +(flush-all-ports "#") +(for-each "#") +(for-next-option "#") +(force "#") +(force-output "#") +(format "#") +(frame-arguments "#") +(frame-evaluating-args? "#") +(frame-next "#") +(frame-number "#") +(frame-overflow? "#") +(frame-previous "#") +(frame-procedure "#") +(frame-procedure? "#") +(frame-real? "#") +(frame-source "#") +(frame? "#") +(fsync "#") +(ftell "#") +(gc "#") +(gc-run-time "#") +(gc-stats "#") +(gcd "#") +(gensym "#") +(get-internal-real-time "#") +(get-internal-run-time "#") +(get-option "#") +(get-output-string "#") +(get-print-state "#") +(getcwd "#") +(getegid "#") +(getenv "#") +(geteuid "#") +(getgid "#") +(getgr "#") +(getgrent "#") +(getgrgid "#") +(getgrnam "#") +(getgroups "#") +(gethost "#") +(gethostbyaddr "#") +(gethostbyname "#") +(gethostent "#") +(gethostname "#") +(getitimer "#") +(getlogin "#") +(getnet "#") +(getnetbyaddr "#") +(getnetbyname "#") +(getnetent "#") +(getpass "#") +(getpeername "#") +(getpgrp "#") +(getpid "#") +(getppid "#") +(getpriority "#") +(getproto "#") +(getprotobyname "#") +(getprotobynumber "#") +(getprotoent "#") +(getpw "#") +(getpwent "#") +(getpwnam "#") +(getpwuid "#") +(getserv "#") +(getservbyname "#") +(getservbyport "#") +(getservent "#") +(getsockname "#") +(getsockopt "#") +(gettimeofday "#") +(getuid "#") +(gmtime "#") +(group:gid "#") +(group:mem "#") +(group:name "#") +(group:passwd "#") +(guardian-destroyed? "#") +(guardian-greedy? "#") +(handle-system-error "#") (has-shown-backtrace-hint? "") (has-shown-debugger-hint? "") -(has-suffix? "#list "#") +(hash "#") +(hash-create-handle! "#") +(hash-fold "#") +(hash-get-handle "#") +(hash-ref "#") +(hash-remove! "#") +(hash-set! "#") +(hashq "#") +(hashq-create-handle! "#") +(hashq-get-handle "#") +(hashq-ref "#") +(hashq-remove! "#") +(hashq-set! "#") +(hashv "#") +(hashv-create-handle! "#") +(hashv-get-handle "#") +(hashv-ref "#") +(hashv-remove! "#") +(hashv-set! "#") +(hashx-create-handle! "#") +(hashx-get-handle "#") +(hashx-ref "#") +(hashx-set! "#") +(hook->list "#list>") +(hook-empty? "#") +(hook? "#") +(hostent:addr-list "#") +(hostent:addrtype "#") +(hostent:aliases "#") +(hostent:length "#") +(hostent:name "#") +(htonl "#") +(htons "#") +(identity "#") (if "") -(imag-part "#exact "#char "#") +(import-environment-imports "#") +(import-environment-set-imports! "#") +(import-environment? "#") +(in-vicinity "#") +(include-deprecated-features "#") +(inet-aton "#") +(inet-lnaof "#") +(inet-makeaddr "#") +(inet-netof "#") +(inet-ntoa "#") +(inet-ntop "#") +(inet-pton "#") +(inexact->exact "#exact>") +(inexact? "#") +(inherit-print-state "#") +(input-port? "#") +(integer->char "#char>") +(integer-expt "#") +(integer-length "#") +(integer? "#") +(interaction-environment "#") (internal-time-units-per-second "") -(iota "#symbol "#keyword "#") +(ipow-by-squaring "#") +(isatty? "#") +(issue-deprecation-warning "#") +(join-thread "#") +(keyword->symbol "#symbol (kw)>") +(keyword-dash-symbol "#") +(keyword-like-symbol->keyword "#keyword (sym)>") +(keyword? "#") +(kill "#") +(kw-arg-ref "#") (lambda "") -(last-pair "#") +(last-stack-frame "#") +(lazy-catch "#") +(lazy-handler-dispatch "#") +(lcm "#") +(leaf-environment? "#") +(length "#") (let "") (let* "") (letrec "") -(link "#array "#string "#symbol "#uniform-array "#uniform-vector "#vector "#weak-vector "#") +(list "#") +(list->array "#array (ndim lst)>") +(list->string "#string>") +(list->symbol "#symbol args>") +(list->uniform-array "#uniform-array>") +(list->uniform-vector "#uniform-vector (prot lst)>") +(list->vector "#vector>") +(list->weak-vector "#weak-vector>") +(list-cdr-ref "#") +(list-cdr-set! "#") +(list-copy "#") +(list-head "#") +(list-index "#") +(list-ref "#") +(list-set! "#") +(list-tail "#") +(list? "#") +(listen "#") +(load "#") (load-compiled "") -(load-emacs-interface "#") +(load-extension "#") +(load-from-path "#") +(load-module "#") +(load-user-init "#") +(local-define "#") +(local-eval "#") +(local-ref "#") +(local-remove "#") +(local-set! "#") +(localtime "#") +(lock-mutex "#") +(log "#") +(log10 "#") +(logand "#") +(logbit? "#") +(logcount "#") +(logior "#") +(lognot "#") +(logtest "#") +(logxor "#") +(lstat "#") +(macro-name "#") (macro-table "") -(macro-transformer "#") +(macro-type "#") +(macro? "#") +(macroexpand "#") +(macroexpand-1 "#") +(magnitude "#") +(major-version "#") +(make-arbiter "#") +(make-array "#") +(make-autoload-interface "#") +(make-class-object "#") +(make-condition-variable "#") +(make-doubly-weak-hash-table "#") +(make-eval-environment "#") +(make-export-environment "#") +(make-fluid "#") +(make-guardian "#") +(make-hash-table "#") +(make-hook "#") +(make-import-environment "#") +(make-keyword-from-dash-symbol "#") +(make-leaf-environment "#") +(make-list "#") +(make-module "#") +(make-modules-in "#") +(make-mutex "#") +(make-object-property "#") +(make-polar "#") +(make-procedure-with-setter "#") +(make-record-type "#") +(make-rectangular "#") +(make-regexp "#") +(make-root-module "#") +(make-scm-module "#") +(make-shared-array "#") +(make-soft-port "#") +(make-stack "#") +(make-string "#") +(make-struct "#") +(make-struct-layout "#") +(make-subclass-object "#") +(make-symbol "#") +(make-undefined-variable "#") +(make-uniform-array "#") +(make-uniform-vector "#uniform-array>") +(make-variable "#") +(make-vector "#") +(make-vtable-vtable "#") +(make-weak-key-hash-table "#") +(make-weak-value-hash-table "#") +(make-weak-vector "#") +(map "#") +(map-in-order "#") +(mask-signals "#") +(max "#") +(member "#") +(memoized-environment "#") +(memoized? "#") +(memq "#") +(memv "#") +(merge "#") +(merge! "#") +(micro-version "#") +(min "#") +(minor-version "#") +(mkdir "#") +(mknod "#") +(mkstemp! "#") +(mktime "#") +(module-add! "#") +(module-binder "#") +(module-bound? "#") +(module-clear! "#") +(module-constructor "#") +(module-define! "#") +(module-defined? "#") +(module-ensure-local-variable! "#") +(module-eval-closure "#") +(module-export! "#") +(module-for-each "#") +(module-kind "#") +(module-local-variable "#") +(module-locally-bound? "#") +(module-make-local-var! "#") +(module-map "#") +(module-modified "#") +(module-name "#") +(module-obarray "#") +(module-obarray-get-handle "#") +(module-obarray-ref "#") +(module-obarray-remove! "#") +(module-obarray-set! "#") +(module-observe "#") +(module-observe-weak "#") +(module-observer-id "#") +(module-observers "#") +(module-public-interface "#") +(module-re-export! "#") +(module-ref "#") +(module-remove! "#") +(module-search "#") +(module-set! "#") +(module-symbol-binding "#") +(module-symbol-interned? "#") +(module-symbol-local-binding "#") +(module-symbol-locally-interned? "#") +(module-transformer "#") (module-type "") -(module-unobserve "#") +(module-use! "#") +(module-uses "#") +(module-variable "#") +(module-weak-observers "#") +(module? "#") +(modulo "#") (most-negative-fixnum "") (most-positive-fixnum "") -(move->fdes "#fdes "#fdes (fd/port fd)>") +(named-module-use! "#") +(negative? "#") +(nested-define! "#") +(nested-ref "#") +(nested-remove! "#") +(nested-set! "#") +(netent:addrtype "#") +(netent:aliases "#") +(netent:name "#") +(netent:net "#") +(newline "#") +(nice "#") (nil-cond "") -(noop "#string "#string "#") +(not "#") +(ntohl "#") +(ntohs "#") +(null? "#") +(number->string "#string>") +(number? "#") +(object->string "#string>") +(object-address "#") +(object-properties "#") +(object-property "#") +(odd? "#") +(open "#") +(open-fdes "#") +(open-file "#") +(open-input-file "#") +(open-input-string "#") +(open-io-file "#") +(open-output-file "#") +(open-output-string "#") +(opendir "#") +(operator? "#") (or "") -(or-map "#fdes "#fdes "#") +(output-port? "#") +(pair? "#") +(parse-path "#") +(passwd:dir "#") +(passwd:gecos "#") +(passwd:gid "#") +(passwd:name "#") +(passwd:passwd "#") +(passwd:shell "#") +(passwd:uid "#") +(pause "#") +(peek "#") +(peek-char "#") +(pipe "#") +(pk "#") +(port->fdes "#fdes (port)>") +(port-closed? "#") +(port-column "#") +(port-filename "#") +(port-for-each "#") +(port-line "#") +(port-mode "#") +(port-revealed "#") +(port-with-print-state "#") +(port? "#") +(positive? "#") +(primitive-eval "#") +(primitive-exit "#") +(primitive-fork "#") +(primitive-load "#") +(primitive-load-path "#") +(primitive-macro? "#") +(primitive-make-property "#") +(primitive-move->fdes "#fdes>") +(primitive-property-del! "#") +(primitive-property-ref "#") +(primitive-property-set! "#") +(print-disable "#") +(print-enable "#") +(print-options "#") +(print-options-interface "#") (print-set! "") -(procedure "#macro "#memoizing-macro "#syntax "#") +(procedure->macro "#macro>") +(procedure->memoizing-macro "#memoizing-macro>") +(procedure->syntax "#syntax>") +(procedure-documentation "#") +(procedure-environment "#") +(procedure-name "#") +(procedure-properties "#") +(procedure-property "#") +(procedure-source "#") +(procedure-with-setter? "#") +(procedure? "#") +(process-define-module "#") +(process-use-modules "#") +(program-arguments "#") +(promise? "#") +(protoent:aliases "#") +(protoent:name "#") +(protoent:proto "#") +(provide "#") +(provided? "#") +(purify-module! "#") +(putenv "#") (quasiquote "") -(quit "#") (quote "") -(quotient "#") +(raise "#") +(random "#") +(random:exp "#") +(random:hollow-sphere! "#") +(random:normal "#") +(random:normal-vector! "#") +(random:solid-sphere! "#") +(random:uniform "#") +(rational? "#") (re-export "") (re-export-syntax "") -(read "#") +(read-char "#") +(read-disable "#") +(read-enable "#") (read-eval? "") -(read-hash-extend "#") (read-hash-procedures "") -(read-options "#") +(read-options-interface "#") (read-set! "") -(read:array "#") +(read:uniform-vector "#") +(readdir "#") +(readlink "#") +(real-part "#") +(real? "#") +(record-accessor "#") +(record-constructor "#") +(record-modifier "#") +(record-predicate "#") +(record-type-descriptor "#") +(record-type-fields "#") +(record-type-name "#") (record-type-vtable "") -(record-type? "#") +(record? "#") +(recv! "#") +(recvfrom! "#") +(redirect-port "#") +(regexp-exec "#") (regexp/basic "") (regexp/extended "") (regexp/icase "") (regexp/newline "") (regexp/notbol "") (regexp/noteol "") -(regexp? "#") +(release-arbiter "#") +(release-port-handle "#") +(remainder "#") +(remove-hook! "#") +(rename-file "#") +(repl "#") +(repl-reader "#") +(reset-hook! "#") +(resolve-interface "#") +(resolve-module "#") +(restore-signals "#") +(restricted-vector-sort! "#") +(reverse "#") +(reverse! "#") +(rewinddir "#") +(rmdir "#") +(round "#") +(run-asyncs "#") +(run-hook "#") +(save-module-excursion "#") +(save-stack "#") +(scheme-file-suffix "#") +(scm-error "#") (scm-repl-print-unspecified "") (scm-repl-prompt "") (scm-repl-silent "") (scm-repl-verbose "") -(scm-style-repl "#random-state "#") +(search-path "#") +(seed->random-state "#random-state>") +(seek "#") +(select "#") +(send "#") +(sendto "#") +(servent:aliases "#") +(servent:name "#") +(servent:port "#") +(servent:proto "#") (set! "") -(set-autoloaded! "#") +(set-batch-mode?! "#") +(set-car! "#") +(set-cdr! "#") +(set-current-error-port "#") +(set-current-input-port "#") +(set-current-module "#") +(set-current-output-port "#") +(set-defmacro-transformer! "#") +(set-module-binder! "#") +(set-module-eval-closure! "#") +(set-module-kind! "#") +(set-module-name! "#") +(set-module-obarray! "#") +(set-module-observer-id! "#") +(set-module-observers! "#") +(set-module-public-interface! "#") +(set-module-transformer! "#") +(set-module-uses! "#") +(set-object-procedure! "#") +(set-object-properties! "#") +(set-object-property! "#") +(set-port-column! "#") +(set-port-filename! "#") +(set-port-line! "#") +(set-port-revealed! "#") +(set-procedure-properties! "#") +(set-procedure-property! "#") +(set-repl-prompt! "#") +(set-source-properties! "#") +(set-source-property! "#") +(set-struct-vtable-name! "#") +(set-symbol-property! "#") +(set-system-module! "#") +(set-tm:gmtoff "#") +(set-tm:hour "#") +(set-tm:isdst "#") +(set-tm:mday "#") +(set-tm:min "#") +(set-tm:mon "#") +(set-tm:sec "#") +(set-tm:wday "#") +(set-tm:yday "#") +(set-tm:year "#") +(set-tm:zone "#") +(setegid "#") +(setenv "#") +(seteuid "#") +(setgid "#") +(setgr "#") +(setgrent "#") +(sethost "#") +(sethostent "#") +(sethostname "#") +(setitimer "#") +(setlocale "#") +(setnet "#") +(setnetent "#") +(setpgid "#") +(setpriority "#") +(setproto "#") +(setprotoent "#") +(setpw "#") +(setpwent "#") +(setserv "#") +(setservent "#") +(setsid "#") +(setsockopt "#") +(setter "#") +(setuid "#") +(setvbuf "#") +(shared-array-increments "#") +(shared-array-offset "#") +(shared-array-root "#") +(shutdown "#") +(sigaction "#") +(signal-condition-variable "#") (signal-handlers "") -(simple-format "#") +(sin "#") +(single-active-thread? "#") +(sinh "#") +(sleep "#") +(sloppy-assoc "#") +(sloppy-assq "#") +(sloppy-assv "#") +(sockaddr:addr "#") +(sockaddr:fam "#") +(sockaddr:path "#") +(sockaddr:port "#") +(socket "#") +(socketpair "#") +(sort "#") +(sort! "#") +(sort-list "#") +(sort-list! "#") +(sorted? "#") +(source-properties "#") +(source-property "#") (source-whash "") -(sqrt "#") +(stable-sort "#") +(stable-sort! "#") +(stack-id "#") +(stack-length "#") +(stack-ref "#") (stack-saved? "") -(stack? "#") +(standard-eval-closure "#") +(standard-interface-eval-closure "#") (start-stack "") -(stat "#list "#number "#symbol "#symbol "#=? "#? "#=? "#? "#keyword "#string "#") +(stat:atime "#") +(stat:blksize "#") +(stat:blocks "#") +(stat:ctime "#") +(stat:dev "#") +(stat:gid "#") +(stat:ino "#") +(stat:mode "#") +(stat:mtime "#") +(stat:nlink "#") +(stat:perms "#") +(stat:rdev "#") +(stat:size "#") +(stat:type "#") +(stat:uid "#") +(status:exit-val "#") +(status:stop-sig "#") +(status:term-sig "#") +(strerror "#") +(strftime "#") +(string "#") +(string->list "#list>") +(string->number "#number>") +(string->symbol "#symbol>") +(string-append "#") +(string-capitalize "#") +(string-capitalize! "#") +(string-ci->symbol "#symbol>") +(string-ci<=? "#") +(string-ci") +(string-ci=? "#") +(string-ci>=? "#=?>") +(string-ci>? "#?>") +(string-copy "#") +(string-downcase "#") +(string-downcase! "#") +(string-fill! "#") +(string-index "#") +(string-length "#") +(string-null? "#") +(string-ref "#") +(string-rindex "#") +(string-set! "#") +(string-split "#") +(string-upcase "#") +(string-upcase! "#") +(string<=? "#") +(string") +(string=? "#") +(string>=? "#=?>") +(string>? "#?>") +(string? "#") +(strptime "#") +(struct-layout "#") +(struct-ref "#") +(struct-set! "#") +(struct-vtable "#") +(struct-vtable-name "#") +(struct-vtable-tag "#") +(struct-vtable? "#") +(struct? "#") +(substring "#") +(substring-fill! "#") +(substring-move! "#") +(symbol "#") +(symbol->keyword "#keyword (symbol)>") +(symbol->string "#string>") +(symbol-append "#") +(symbol-fref "#") +(symbol-fset! "#") +(symbol-hash "#") +(symbol-interned? "#") +(symbol-pref "#") +(symbol-prefix-proc "#") +(symbol-property "#") +(symbol-property-remove! "#") +(symbol-pset! "#") +(symbol? "#") +(symlink "#") +(sync "#") +(system "#") +(system-async "#") +(system-async-mark "#") +(system-error-errno "#") +(tan "#") +(tanh "#") +(tcgetpgrp "#") +(tcsetpgrp "#") (the-environment "") (the-eof-object "") (the-last-stack "") (the-root-environment "") (the-root-module "") (the-scm-module "") -(throw "#") +(thunk? "#") +(times "#") +(tm:gmtoff "#") +(tm:hour "#") +(tm:isdst "#") +(tm:mday "#") +(tm:min "#") +(tm:mon "#") +(tm:sec "#") +(tm:wday "#") +(tm:yday "#") +(tm:year "#") +(tm:zone "#") +(tmpnam "#") +(tms:clock "#") +(tms:cstime "#") +(tms:cutime "#") +(tms:stime "#") +(tms:utime "#") +(top-repl "#") +(transform-usage-lambda "#") +(transpose-array "#") +(trap-disable "#") +(trap-enable "#") (trap-set! "") -(traps "#") +(truncate "#") +(truncate-file "#") +(try-arbiter "#") +(try-load-module "#") +(try-module-autoload "#") +(ttyname "#") +(turn-on-debugging "#") +(tzset "#") +(umask "#") +(uname "#") (undefine "") -(uniform-array-read! "#") +(uniform-array-set1! "#") +(uniform-array-write "#") +(uniform-vector-fill! "#") +(uniform-vector-length "#") +(uniform-vector-read! "#") +(uniform-vector-ref "#") +(uniform-vector-set! "#") +(uniform-vector-write "#") +(uniform-vector? "#") +(unlock-mutex "#") +(unmask-signals "#") +(unmemoize "#") +(unread-char "#") +(unread-string "#") +(unspecified? "#") (use-emacs-interface "") (use-modules "") -(use-srfis "#") (use-syntax "") (using-readline? "#") -(usleep "#list "#") +(utime "#") +(utsname:machine "#") +(utsname:nodename "#") +(utsname:release "#") +(utsname:sysname "#") +(utsname:version "#") +(valid-object-procedure? "#") +(values "#") +(variable-bound? "#") +(variable-ref "#") +(variable-set! "#") +(variable? "#") +(vector "#") +(vector->list "#list>") +(vector-fill! "#") +(vector-length "#") +(vector-move-left! "#") +(vector-move-right! "#") +(vector-ref "#") +(vector-set! "#") +(vector? "#") +(version "#") (vtable-index-layout "") (vtable-index-printer "") (vtable-index-vtable "") (vtable-offset-user "") -(wait-condition-variable "#") +(waitpid "#") +(warn "#") +(weak-key-hash-table? "#") +(weak-value-hash-table? "#") +(weak-vector "#") +(weak-vector? "#") (while "") -(with-error-to-file "#") +(with-error-to-port "#") +(with-error-to-string "#") (with-fluids "") -(with-fluids* "#") +(with-input-from-file "#") +(with-input-from-port "#") +(with-input-from-string "#") +(with-output-to-file "#") +(with-output-to-port "#") +(with-output-to-string "#") +(with-traps "#") +(write "#") +(write-char "#") (xformer-table "") -(yield "#") +(zero? "#") ) ;; end of scheme -(C +(C (collisionp B) (coop_abort T) (coop_condition_variable_destroy T) @@ -1648,7 +1650,6 @@ (gnfds B) (greadfds B) (gwritefds B) -(issued_msgs B) (rexceptfds B) (rreadfds B) (rwritefds B) @@ -1699,6 +1700,7 @@ (scm_array_prototype T) (scm_array_rank T) (scm_array_set_x T) +(scm_array_to_list T) (scm_ash T) (scm_asinh T) (scm_assoc T) @@ -1774,6 +1776,7 @@ (scm_c_ints2ivect T) (scm_c_ints2scm T) (scm_c_issue_deprecation_warning T) +(scm_c_issue_deprecation_warning_fmt T) (scm_c_load_extension T) (scm_c_longs2ivect T) (scm_c_longs2scm T) @@ -2128,22 +2131,29 @@ (scm_gc_cells_swept D) (scm_gc_cells_swept_acc D) (scm_gc_for_newcell T) +(scm_gc_free T) (scm_gc_heap_lock D) +(scm_gc_malloc T) (scm_gc_malloc_collected B) (scm_gc_mark T) (scm_gc_mark_dependencies T) (scm_gc_mark_time_taken D) (scm_gc_ports_collected B) (scm_gc_protect_object T) +(scm_gc_realloc T) +(scm_gc_register_collectable_memory T) (scm_gc_register_root T) (scm_gc_register_roots T) (scm_gc_running_p D) (scm_gc_stats T) +(scm_gc_strdup T) +(scm_gc_strndup T) (scm_gc_sweep T) (scm_gc_sweep_time_taken D) (scm_gc_time_taken D) (scm_gc_times D) (scm_gc_unprotect_object T) +(scm_gc_unregister_collectable_memory T) (scm_gc_unregister_root T) (scm_gc_unregister_roots T) (scm_gc_yield B) @@ -2554,6 +2564,7 @@ (scm_makmacro T) (scm_makmmacro T) (scm_makprom T) +(scm_malloc T) (scm_malloc_obj T) (scm_mallocated D) (scm_map T) @@ -2768,6 +2779,7 @@ (scm_real_equalp T) (scm_real_p T) (scm_real_part T) +(scm_realloc T) (scm_recv T) (scm_recvfrom T) (scm_redirect_port T) @@ -2927,6 +2939,7 @@ (scm_status_term_sig T) (scm_str2string T) (scm_str2symbol T) +(scm_strdup T) (scm_strerror T) (scm_strftime T) (scm_string T) @@ -2962,6 +2975,7 @@ (scm_string_to_symbol T) (scm_string_upcase T) (scm_string_upcase_x T) +(scm_strndup T) (scm_strport_to_string T) (scm_strptime T) (scm_struct_create_handle T) @@ -3073,7 +3087,6 @@ (scm_system_environment B) (scm_system_error_key B) (scm_system_module_env_p T) -(scm_t_arrayo_list T) (scm_tables_prehistory T) (scm_take0str T) (scm_take_from_input_buffers T) @@ -3198,4 +3211,4 @@ (scm_zero_p T) (terminating B) ) ;; end of C -) +) ;; eof From 2f908075a53ece4e2372a79294ad2dd9524fe81e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 1 Mar 2002 08:35:15 +0000 Subject: [PATCH 25/41] Remove "pwd" meta info. --- doc/guile-api.alist | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/guile-api.alist b/doc/guile-api.alist index 4f79b6139..10983d0bd 100644 --- a/doc/guile-api.alist +++ b/doc/guile-api.alist @@ -3,8 +3,7 @@ (meta (GUILE_LOAD_PATH . "") (LTDL_LOAD_PATH . "") (guile . "pre-inst-guile") - (sofile . "libguile/.libs/libguile.so.15.0.0") - (pwd . "/home/ttn/tmp/.tmp")) + (sofile . "libguile/.libs/libguile.so.15.0.0")) (scheme ($abs "#") ($acos "#") From 547ba6882a15a68e6818e9f7a5b84fc6d7202786 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 1 Mar 2002 08:36:32 +0000 Subject: [PATCH 26/41] *** empty log message *** --- doc/ChangeLog | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 0703983f5..8dfc503c0 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2002-03-01 Thien-Thi Nguyen + + * guile-api.alist: Update. + 2001-08-27 Neil Jerram * mltext.texi (Guile Character Properties): Fix `hexidecimal' @@ -39,7 +43,7 @@ * scheme-evaluation.texi: Added `load-from-path'. Corrected `load': it doesn't use the load paths. - + 2001-07-04 Martin Grabmueller * scheme-data.texi (Hook Reference): Removed documentation for @@ -57,7 +61,7 @@ @result{} and @print{}. * scheme-data.texi (Hash Table Examples): New subsubsection. - + 2001-06-30 Martin Grabmueller * scheme-data.texi (Hash Tables): Added docs for @@ -157,7 +161,7 @@ 2001-06-04 Gary Houston - * scheme-io.texi (Block Reading and Writing): added + * scheme-io.texi (Block Reading and Writing): added write-string/partial, updated read-string!/partial. 2001-05-30 Martin Grabmueller @@ -248,7 +252,7 @@ * srfi-modules.texi (SRFI-0): New section. (SRFI-16): New section. - + Change `--' to `-' throughout. 2001-05-13 Thien-Thi Nguyen From 6a0f6ff30ce01947755276fc6e505129f921541e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 2 Mar 2002 09:53:51 +0000 Subject: [PATCH 27/41] * eval.c (scm_badargsp, SCM_CEVAL): Replaced SCM_N?IMP by a more explicit predicate in some places. (CHECK_EQVISH): Removed. (SCM_CEVAL): Removed some uses of t.arg1 and proc as temporary variables. Removed side-effecting operations from conditions and macro calls. Introduced temporary variables for clarification. Sorted if-else-if check for the type of the last form in a list by frequency. Avoided some unnecessary tail-recursion calls. --- libguile/ChangeLog | 13 ++++++ libguile/eval.c | 111 +++++++++++++++++++++++++-------------------- 2 files changed, 76 insertions(+), 48 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f86d494d0..8d7b23f09 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2002-03-02 Dirk Herrmann + + * eval.c (scm_badargsp, SCM_CEVAL): Replaced SCM_N?IMP by a more + explicit predicate in some places. + + (CHECK_EQVISH): Removed. + + (SCM_CEVAL): Removed some uses of t.arg1 and proc as temporary + variables. Removed side-effecting operations from conditions and + macro calls. Introduced temporary variables for clarification. + Sorted if-else-if check for the type of the last form in a list by + frequency. Avoided some unnecessary tail-recursion calls. + 2002-03-01 Dirk Herrmann * gc.c (SCM_HEAP_SEG_SIZE, CELL_UP, CELL_DN, NEXT_DATA_CELL, diff --git a/libguile/eval.c b/libguile/eval.c index 4c3d53e95..44df33d18 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1571,11 +1571,11 @@ scm_unmemocopy (SCM x, SCM env) int scm_badargsp (SCM formals, SCM args) { - while (SCM_NIMP (formals)) + while (!SCM_NULLP (formals)) { if (!SCM_CONSP (formals)) return 0; - if (SCM_IMP(args)) + if (SCM_NULLP (args)) return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); @@ -1845,9 +1845,6 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) env = scm_top_level_env (p); \ } while (0) -#ifndef DEVAL -#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B))))) -#endif /* DEVAL */ /* This is the evaluator. Like any real monster, it has three heads: * @@ -1926,9 +1923,11 @@ SCM_CEVAL (SCM x, SCM env) scm_report_stack_overflow (); } #endif + #ifdef DEVAL goto start; #endif + loopnoap: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); loop: @@ -1951,6 +1950,7 @@ loop: SCM_SET_OVERFLOW (debug); debug.info -= 2; } + start: debug.info->e.exp = x; debug.info->e.env = env; @@ -1999,11 +1999,12 @@ dispatch: x = scm_cons (x, SCM_UNDEFINED); RETURN (*scm_lookupcar (x, env, 1)); - case SCM_BIT8(SCM_IM_AND): + case SCM_BIT8 (SCM_IM_AND): x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { - if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1)) + SCM condition = EVALCAR (x, env); + if (SCM_FALSEP (condition) || SCM_NILP (condition)) RETURN (SCM_BOOL_F); else x = SCM_CDR (x); @@ -2011,7 +2012,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8(SCM_IM_BEGIN): + case SCM_BIT8 (SCM_IM_BEGIN): if (SCM_NULLP (SCM_CDR (x))) RETURN (SCM_UNSPECIFIED); @@ -2046,59 +2047,73 @@ dispatch: nontoplevel_begin: while (!SCM_NULLP (SCM_CDR (x))) { - if (SCM_IMP (SCM_CAR (x))) + SCM form = SCM_CAR (x); + if (SCM_IMP (form)) { - if (SCM_ISYMP (SCM_CAR (x))) + if (SCM_ISYMP (form)) { x = scm_m_expand_body (x, env); goto nontoplevel_begin; } else - SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x)); + SCM_VALIDATE_NON_EMPTY_COMBINATION (form); } else - SCM_CEVAL (SCM_CAR (x), env); + SCM_CEVAL (form, env); x = SCM_CDR (x); } - carloop: /* scm_eval car of last form in list */ - if (SCM_IMP (SCM_CAR (x))) - { - x = SCM_CAR (x); - RETURN (SCM_EVALIM (x, env)); - } + carloop: + { + /* scm_eval last form in list */ + SCM last_form = SCM_CAR (x); - if (SCM_SYMBOLP (SCM_CAR (x))) - RETURN (*scm_lookupcar (x, env, 1)); - - x = SCM_CAR (x); - goto loop; /* tail recurse */ + if (SCM_CONSP (last_form)) + { + /* This is by far the most frequent case. */ + x = last_form; + goto loop; /* tail recurse */ + } + else if (SCM_IMP (last_form)) + RETURN (SCM_EVALIM (last_form, env)); + else if (SCM_VARIABLEP (last_form)) + RETURN (SCM_VARIABLE_REF (last_form)); + else if (SCM_SYMBOLP (last_form)) + RETURN (*scm_lookupcar (x, env, 1)); + else + RETURN (last_form); + } case SCM_BIT8(SCM_IM_CASE): x = SCM_CDR (x); - t.arg1 = EVALCAR (x, env); - while (SCM_NIMP (x = SCM_CDR (x))) - { - proc = SCM_CAR (x); - if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))) - { - x = SCM_CDR (proc); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - proc = SCM_CAR (proc); - while (SCM_NIMP (proc)) - { - if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) - { - x = SCM_CDAR (x); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; - } - proc = SCM_CDR (proc); - } - } + { + SCM key = EVALCAR (x, env); + x = SCM_CDR (x); + while (!SCM_NULLP (x)) + { + SCM clause = SCM_CAR (x); + SCM labels = SCM_CAR (clause); + if (SCM_EQ_P (labels, scm_sym_else)) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + while (!SCM_NULLP (labels)) + { + SCM label = SCM_CAR (labels); + if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key))) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + labels = SCM_CDR (labels); + } + x = SCM_CDR (x); + } + } RETURN (SCM_UNSPECIFIED); @@ -2119,14 +2134,14 @@ dispatch: x = SCM_CDR (proc); if (SCM_NULLP (x)) RETURN (t.arg1); - if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) + else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } proc = SCM_CDR (x); proc = EVALCAR (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); + SCM_ASRTGO (!SCM_IMP (proc), badfun); PREP_APPLY (proc, scm_list_1 (t.arg1)); ENTER_APPLY; if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) @@ -2142,7 +2157,7 @@ dispatch: x = SCM_CDR (x); proc = SCM_CADR (x); /* inits */ t.arg1 = SCM_EOL; /* values */ - while (SCM_NIMP (proc)) + while (!SCM_NULLP (proc)) { t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); proc = SCM_CDR (proc); From e5cb71a0a9ff8d1fc1592543868f4fd7cd4f7792 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 2 Mar 2002 11:50:01 +0000 Subject: [PATCH 28/41] * eval.c (SCM_CEVAL): Cleaned up the handling of 'cons' and 'do': Removed some uses of t.arg1 and proc as temporary variables. Removed side-effecting operations from conditions and macro calls. Introduced temporary variables with hopefully descriptive names for clarification. Replaced SCM_N?IMP by a more explicit predicate in some places. --- libguile/ChangeLog | 9 ++++ libguile/eval.c | 128 ++++++++++++++++++++++++++++++--------------- 2 files changed, 95 insertions(+), 42 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8d7b23f09..c7344414a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2002-03-02 Dirk Herrmann + + * eval.c (SCM_CEVAL): Cleaned up the handling of 'cons' and 'do': + Removed some uses of t.arg1 and proc as temporary variables. + Removed side-effecting operations from conditions and macro calls. + Introduced temporary variables with hopefully descriptive names + for clarification. Replaced SCM_N?IMP by a more explicit + predicate in some places. + 2002-03-02 Dirk Herrmann * eval.c (scm_badargsp, SCM_CEVAL): Replaced SCM_N?IMP by a more diff --git a/libguile/eval.c b/libguile/eval.c index 44df33d18..430ba4398 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2121,64 +2121,108 @@ dispatch: x = SCM_CDR (x); while (!SCM_NULLP (x)) { - proc = SCM_CAR (x); - if (SCM_EQ_P (SCM_CAR (proc), scm_sym_else)) + SCM clause = SCM_CAR (x); + if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else)) { - x = SCM_CDR (proc); + x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } - t.arg1 = EVALCAR (proc, env); - if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1)) + else { - x = SCM_CDR (proc); - if (SCM_NULLP (x)) - RETURN (t.arg1); - else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) + t.arg1 = EVALCAR (clause, env); + if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1)) { - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; + x = SCM_CDR (clause); + if (SCM_NULLP (x)) + RETURN (t.arg1); + else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + else + { + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (!SCM_IMP (proc), badfun); + PREP_APPLY (proc, scm_list_1 (t.arg1)); + ENTER_APPLY; + if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) + goto umwrongnumargs; + else + goto evap1; + } } - proc = SCM_CDR (x); - proc = EVALCAR (proc, env); - SCM_ASRTGO (!SCM_IMP (proc), badfun); - PREP_APPLY (proc, scm_list_1 (t.arg1)); - ENTER_APPLY; - if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) - goto umwrongnumargs; - goto evap1; + x = SCM_CDR (x); } - x = SCM_CDR (x); } RETURN (SCM_UNSPECIFIED); - case SCM_BIT8(SCM_IM_DO): + case SCM_BIT8 (SCM_IM_DO): x = SCM_CDR (x); - proc = SCM_CADR (x); /* inits */ - t.arg1 = SCM_EOL; /* values */ - while (!SCM_NULLP (proc)) - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - proc = SCM_CDR (proc); - } - env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); + { + /* Compute the initialization values and the initial environment. */ + SCM init_forms = SCM_CADR (x); + SCM init_values = SCM_EOL; + while (!SCM_NULLP (init_forms)) + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + env = EXTEND_ENV (SCM_CAR (x), init_values, env); + } x = SCM_CDDR (x); - while (proc = SCM_CAR (x), - SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || SCM_NILP (t.arg1)) - { - for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc)) + { + SCM test_form = SCM_CAR (x); + SCM body_forms = SCM_CADR (x); + SCM step_forms = SCM_CDDR (x); + + SCM test_result = EVALCAR (test_form, env); + + while (SCM_FALSEP (test_result) || SCM_NILP (test_result)) + { { - t.arg1 = SCM_CAR (proc); /* body */ - SIDEVAL (t.arg1, env); + /* Evaluate body forms. */ + SCM temp_forms; + for (temp_forms = body_forms; + !SCM_NULLP (temp_forms); + temp_forms = SCM_CDR (temp_forms)) + { + SCM form = SCM_CAR (temp_forms); + /* Dirk:FIXME: We only need to eval forms, that may have a + * side effect here. This is only true for forms that start + * with a pair. All others are just constants. However, + * since in the common case there is no constant expression + * in a body of a do form, we just check for immediates here + * and have SCM_CEVAL take care of other cases. In the long + * run it would make sense to get rid of this test and have + * the macro transformer of 'do' eliminate all forms that + * have no sideeffect. */ + if (!SCM_IMP (form)) + SCM_CEVAL (form, env); + } } - for (t.arg1 = SCM_EOL, proc = SCM_CDDR (x); - SCM_NIMP (proc); - proc = SCM_CDR (proc)) - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */ - env = EXTEND_ENV (SCM_CAAR (env), t.arg1, SCM_CDR (env)); - } - x = SCM_CDR (proc); + + { + /* Evaluate the step expressions. */ + SCM temp_forms; + SCM step_values = SCM_EOL; + for (temp_forms = step_forms; + !SCM_NULLP (temp_forms); + temp_forms = SCM_CDR (temp_forms)) + { + SCM value = EVALCAR (temp_forms, env); + step_values = scm_cons (value, step_values); + } + env = EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env)); + } + + test_result = EVALCAR (test_form, env); + } + } + x = SCM_CDAR (x); if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); From 38ace99eb34dc50f97d730877233231943a3a49c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 2 Mar 2002 12:47:45 +0000 Subject: [PATCH 29/41] * eval.c (SCM_CEVAL): Cleaned up the handling of 'if', 'let', 'letrec' and 'set*': Removed some uses of t.arg1, t.lloc and proc as temporary variables. Removed side-effecting operations from conditions and macro calls. Introduced temporary variables with hopefully descriptive names for clarification. Replaced SCM_N?IMP by a more explicit predicate in some places. Removed code that was conditionally compiled if SICP was defined - which it never is. --- libguile/ChangeLog | 11 +++++ libguile/eval.c | 107 ++++++++++++++++++++++++--------------------- 2 files changed, 68 insertions(+), 50 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c7344414a..496ad9afa 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2002-03-02 Dirk Herrmann + + * eval.c (SCM_CEVAL): Cleaned up the handling of 'if', 'let', + 'letrec' and 'set*': Removed some uses of t.arg1, t.lloc and proc + as temporary variables. Removed side-effecting operations from + conditions and macro calls. Introduced temporary variables with + hopefully descriptive names for clarification. Replaced SCM_N?IMP + by a more explicit predicate in some places. Removed code that + was conditionally compiled if SICP was defined - which it never + is. + 2002-03-02 Dirk Herrmann * eval.c (SCM_CEVAL): Cleaned up the handling of 'cons' and 'do': diff --git a/libguile/eval.c b/libguile/eval.c index 430ba4398..f2c8b07e8 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2003,8 +2003,8 @@ dispatch: x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { - SCM condition = EVALCAR (x, env); - if (SCM_FALSEP (condition) || SCM_NILP (condition)) + SCM test_result = EVALCAR (x, env); + if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) RETURN (SCM_BOOL_F); else x = SCM_CDR (x); @@ -2085,7 +2085,7 @@ dispatch: } - case SCM_BIT8(SCM_IM_CASE): + case SCM_BIT8 (SCM_IM_CASE): x = SCM_CDR (x); { SCM key = EVALCAR (x, env); @@ -2229,46 +2229,59 @@ dispatch: goto nontoplevel_begin; - case SCM_BIT8(SCM_IM_IF): + case SCM_BIT8 (SCM_IM_IF): x = SCM_CDR (x); - if (!SCM_FALSEP (t.arg1 = EVALCAR (x, env)) && !SCM_NILP (t.arg1)) - x = SCM_CDR (x); - else if (SCM_IMP (x = SCM_CDDR (x))) - RETURN (SCM_UNSPECIFIED); + { + SCM test_result = EVALCAR (x, env); + if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result)) + x = SCM_CDR (x); + else + { + x = SCM_CDDR (x); + if (SCM_NULLP (x)) + RETURN (SCM_UNSPECIFIED); + } + } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8(SCM_IM_LET): + case SCM_BIT8 (SCM_IM_LET): x = SCM_CDR (x); - proc = SCM_CADR (x); - t.arg1 = SCM_EOL; - do - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - } - while (SCM_NIMP (proc = SCM_CDR (proc))); - env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); + { + SCM init_forms = SCM_CADR (x); + SCM init_values = SCM_EOL; + do + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + while (!SCM_NULLP (init_forms)); + env = EXTEND_ENV (SCM_CAR (x), init_values, env); + } x = SCM_CDR (x); goto nontoplevel_cdrxnoap; - case SCM_BIT8(SCM_IM_LETREC): + case SCM_BIT8 (SCM_IM_LETREC): x = SCM_CDR (x); env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); x = SCM_CDR (x); - proc = SCM_CAR (x); - t.arg1 = SCM_EOL; - do - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - } - while (SCM_NIMP (proc = SCM_CDR (proc))); - SCM_SETCDR (SCM_CAR (env), t.arg1); + { + SCM init_forms = SCM_CAR (x); + SCM init_values = SCM_EOL; + do + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + while (!SCM_NULLP (init_forms)); + SCM_SETCDR (SCM_CAR (env), init_values); + } goto nontoplevel_cdrxnoap; - case SCM_BIT8(SCM_IM_LETSTAR): + case SCM_BIT8 (SCM_IM_LETSTAR): x = SCM_CDR (x); { SCM bindings = SCM_CAR (x); @@ -2289,7 +2302,7 @@ dispatch: goto nontoplevel_cdrxnoap; - case SCM_BIT8(SCM_IM_OR): + case SCM_BIT8 (SCM_IM_OR): x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { @@ -2303,43 +2316,37 @@ dispatch: goto carloop; - case SCM_BIT8(SCM_IM_LAMBDA): + case SCM_BIT8 (SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case SCM_BIT8(SCM_IM_QUOTE): + case SCM_BIT8 (SCM_IM_QUOTE): RETURN (SCM_CADR (x)); - case SCM_BIT8(SCM_IM_SET_X): + case SCM_BIT8 (SCM_IM_SET_X): x = SCM_CDR (x); - proc = SCM_CAR (x); - switch (SCM_ITAG3 (proc)) - { - case scm_tc3_cons: - if (SCM_VARIABLEP (proc)) - t.lloc = SCM_VARIABLE_LOC (proc); - else - t.lloc = scm_lookupcar (x, env, 1); - break; + { + SCM *location; + SCM variable = SCM_CAR (x); + if (SCM_VARIABLEP (variable)) + location = SCM_VARIABLE_LOC (variable); #ifdef MEMOIZE_LOCALS - case scm_tc3_imm24: - t.lloc = scm_ilookup (proc, env); - break; + else if (SCM_ILOCP (variable)) + location = scm_ilookup (variable, env); #endif - } - x = SCM_CDR (x); - *t.lloc = EVALCAR (x, env); -#ifdef SICP - RETURN (*t.lloc); -#else + else /* (SCM_SYMBOLP (variable)) is known to be true */ + location = scm_lookupcar (x, env, 1); + x = SCM_CDR (x); + *location = EVALCAR (x, env); + } RETURN (SCM_UNSPECIFIED); -#endif case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */ scm_misc_error (NULL, "Bad define placement", SCM_EOL); + /* new syntactic forms go here. */ case SCM_BIT8(SCM_MAKISYM (0)): proc = SCM_CAR (x); From 97820583b49502fdb72794185bb7d466efe5ab12 Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Sat, 2 Mar 2002 14:18:38 +0000 Subject: [PATCH 30/41] 2002-03-02 Stefan Jahn * convert.i.c: Fixed int <-> long conversions which would have failed if their sizes were different. --- libguile/ChangeLog | 5 ++++ libguile/convert.c | 60 +++++++++++++++++++++++++++++--------------- libguile/convert.i.c | 58 +++++++++++++++++++++++++++++++----------- 3 files changed, 89 insertions(+), 34 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 496ad9afa..06f0bf053 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-03-02 Stefan Jahn + + * convert.i.c: Fixed int <-> long conversions which would have + failed if their sizes were different. + 2002-03-02 Dirk Herrmann * eval.c (SCM_CEVAL): Cleaned up the handling of 'if', 'let', diff --git a/libguile/convert.c b/libguile/convert.c index d6606d555..16ab366a5 100644 --- a/libguile/convert.c +++ b/libguile/convert.c @@ -56,28 +56,36 @@ #include #endif -#define CTYPE char -#define SIZEOF_CTYPE 1 -#define SCM2CTYPES_FN "scm_c_scm2chars" -#define SCM2CTYPES scm_c_scm2chars -#define CTYPES2SCM_FN "scm_c_chars2scm" -#define CTYPES2SCM scm_c_chars2scm -#define CTYPES2UVECT_FN "scm_c_chars2byvect" -#define CTYPES2UVECT scm_c_chars2byvect -#define UVECTTYPE scm_tc7_byvect -#define ARRAYTYPE scm_tc7_byvect +#define CTYPE char +#define SIZEOF_CTYPE 1 +#define SCM2CTYPES_FN "scm_c_scm2chars" +#define SCM2CTYPES scm_c_scm2chars +#define CTYPES2SCM_FN "scm_c_chars2scm" +#define CTYPES2SCM scm_c_chars2scm +#define CTYPES2UVECT_FN "scm_c_chars2byvect" +#define CTYPES2UVECT scm_c_chars2byvect +#define UVECTTYPE scm_tc7_byvect +#define SIZEOF_UVECTTYPE 1 +#define UVECTCTYPE char +#define ARRAYTYPE scm_tc7_byvect +#define SIZEOF_ARRAYTYPE 1 +#define ARRAYCTYPE char #include "convert.i.c" -#define CTYPE short -#define SIZEOF_CTYPE SIZEOF_SHORT -#define SCM2CTYPES_FN "scm_c_scm2shorts" -#define SCM2CTYPES scm_c_scm2shorts -#define CTYPES2SCM_FN "scm_c_shorts2scm" -#define CTYPES2SCM scm_c_shorts2scm -#define CTYPES2UVECT_FN "scm_c_shorts2svect" -#define CTYPES2UVECT scm_c_shorts2svect -#define UVECTTYPE scm_tc7_svect -#define ARRAYTYPE scm_tc7_svect +#define CTYPE short +#define SIZEOF_CTYPE SIZEOF_SHORT +#define SCM2CTYPES_FN "scm_c_scm2shorts" +#define SCM2CTYPES scm_c_scm2shorts +#define CTYPES2SCM_FN "scm_c_shorts2scm" +#define CTYPES2SCM scm_c_shorts2scm +#define CTYPES2UVECT_FN "scm_c_shorts2svect" +#define CTYPES2UVECT scm_c_shorts2svect +#define UVECTTYPE scm_tc7_svect +#define SIZEOF_UVECTTYPE SIZEOF_SHORT +#define UVECTCTYPE short +#define ARRAYTYPE scm_tc7_svect +#define SIZEOF_ARRAYTYPE SIZEOF_SHORT +#define ARRAYCTYPE short #include "convert.i.c" #define CTYPE int @@ -89,10 +97,14 @@ #define CTYPES2UVECT_FN "scm_c_ints2ivect" #define CTYPES2UVECT scm_c_ints2ivect #define UVECTTYPE scm_tc7_ivect +#define SIZEOF_UVECTTYPE SIZEOF_LONG +#define UVECTCTYPE long #define CTYPES2UVECT_FN_OPTIONAL "scm_c_uints2uvect" #define CTYPES2UVECT_OPTIONAL scm_c_uints2uvect #define UVECTTYPE_OPTIONAL scm_tc7_uvect #define ARRAYTYPE scm_tc7_ivect +#define SIZEOF_ARRAYTYPE SIZEOF_LONG +#define ARRAYCTYPE long #define ARRAYTYPE_OPTIONAL scm_tc7_uvect #include "convert.i.c" @@ -105,10 +117,14 @@ #define CTYPES2UVECT_FN "scm_c_longs2ivect" #define CTYPES2UVECT scm_c_longs2ivect #define UVECTTYPE scm_tc7_ivect +#define SIZEOF_UVECTTYPE SIZEOF_LONG +#define UVECTCTYPE long #define CTYPES2UVECT_FN_OPTIONAL "scm_c_ulongs2uvect" #define CTYPES2UVECT_OPTIONAL scm_c_ulongs2uvect #define UVECTTYPE_OPTIONAL scm_tc7_uvect #define ARRAYTYPE scm_tc7_ivect +#define SIZEOF_ARRAYTYPE SIZEOF_LONG +#define ARRAYCTYPE long #define ARRAYTYPE_OPTIONAL scm_tc7_uvect #include "convert.i.c" @@ -121,7 +137,9 @@ #define CTYPES2UVECT_FN "scm_c_floats2fvect" #define CTYPES2UVECT scm_c_floats2fvect #define UVECTTYPE scm_tc7_fvect +#define SIZEOF_UVECTTYPE 0 #define ARRAYTYPE scm_tc7_fvect +#define SIZEOF_ARRAYTYPE 0 #define ARRAYTYPE_OPTIONAL scm_tc7_dvect #define FLOATTYPE float #define FLOATTYPE_OPTIONAL double @@ -136,7 +154,9 @@ #define CTYPES2UVECT_FN "scm_c_doubles2dvect" #define CTYPES2UVECT scm_c_doubles2dvect #define UVECTTYPE scm_tc7_dvect +#define SIZEOF_UVECTTYPE 0 #define ARRAYTYPE scm_tc7_dvect +#define SIZEOF_ARRAYTYPE 0 #define ARRAYTYPE_OPTIONAL scm_tc7_fvect #define FLOATTYPE double #define FLOATTYPE_OPTIONAL float diff --git a/libguile/convert.i.c b/libguile/convert.i.c index 0d78711c7..e2c338a7a 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -54,10 +54,8 @@ SCM2CTYPES (SCM obj, CTYPE *data) /* allocate new memory if necessary */ if (data == NULL) - { - if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) - return NULL; - } + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; /* traverse the list once more and convert each member */ list = obj; @@ -116,10 +114,8 @@ SCM2CTYPES (SCM obj, CTYPE *data) /* allocate new memory if necessary */ if (data == NULL) - { - if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) - return NULL; - } + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; /* traverse the vector once more and convert each member */ for (i = 0; i < n; i++) @@ -146,10 +142,8 @@ SCM2CTYPES (SCM obj, CTYPE *data) /* allocate new memory if necessary */ if (data == NULL) - { - if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) - return NULL; - } + if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) + return NULL; #ifdef FLOATTYPE_OPTIONAL /* float <-> double conversions */ @@ -160,8 +154,14 @@ SCM2CTYPES (SCM obj, CTYPE *data) } else #endif +#if SIZEOF_CTYPE != SIZEOF_ARRAYTYPE + /* copy array element by element */ + for (i = 0; i < n; i++) + data[i] = (CTYPE) ((ARRAYCTYPE *) SCM_UVECTOR_BASE (obj))[i]; +#else /* copy whole array */ memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); +#endif break; #endif /* HAVE_ARRAYS */ @@ -191,12 +191,23 @@ SCM2CTYPES (SCM obj, CTYPE *data) SCM CTYPES2UVECT (const CTYPE *data, long n) { +#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE + UVECTCTYPE *v; + long i; +#else char *v; +#endif SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); +#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE + v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect"); + for (i = 0; i < n; i++) + v[i] = (UVECTCTYPE) data[i]; +#else v = scm_gc_malloc (n * sizeof (CTYPE), "uvect"); memcpy (v, data, n * sizeof (CTYPE)); +#endif return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); } #undef FUNC_NAME @@ -206,12 +217,23 @@ CTYPES2UVECT (const CTYPE *data, long n) SCM CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n) { +#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE + unsigned UVECTCTYPE *v; + long i; +#else char *v; +#endif SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); - v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect"); - memcpy (v, data, n * sizeof (unsigned CTYPE)); +#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE + v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect"); + for (i = 0; i < n; i++) + v[i] = (unsigned UVECTCTYPE) data[i]; +#else + v = scm_gc_malloc (n * sizeof (CTYPE), "uvect"); + memcpy (v, data, n * sizeof (CTYPE)); +#endif return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL), (scm_t_bits) v); } @@ -258,6 +280,8 @@ CTYPES2SCM (const CTYPE *data, long n) #undef UVECTTYPE_OPTIONAL #endif #undef SIZEOF_CTYPE +#undef SIZEOF_UVECTTYPE +#undef SIZEOF_ARRAYTYPE #undef ARRAYTYPE #ifdef ARRAYTYPE_OPTIONAL #undef ARRAYTYPE_OPTIONAL @@ -268,6 +292,12 @@ CTYPES2SCM (const CTYPE *data, long n) #ifdef FLOATTYPE_OPTIONAL #undef FLOATTYPE_OPTIONAL #endif +#ifdef UVECTCTYPE +#undef UVECTCTYPE +#endif +#ifdef ARRAYCTYPE +#undef ARRAYCTYPE +#endif /* Local Variables: From 3e76fda1f65b9d9b5eb3aecf4ed2a0e5b7a0e97b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 16:35:50 +0000 Subject: [PATCH 31/41] (top_srcdir): Fix ref bug: Force absolute. --- pre-inst-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pre-inst-guile.in b/pre-inst-guile.in index 5c44a9d77..149fbd338 100644 --- a/pre-inst-guile.in +++ b/pre-inst-guile.in @@ -39,7 +39,7 @@ subdirs_with_ltlibs="srfi guile-readline" # maintain me # env (set by configure) -top_srcdir="@top_srcdir@" +top_srcdir=`(cd "@top_srcdir@" ; pwd)` top_builddir="@top_builddir_absolute@" [ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \ From eb8aea9b2ea32a90c972a750a2b0864614ad203d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 16:36:50 +0000 Subject: [PATCH 32/41] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7e0a4ed83..1fd8fa689 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2002-03-04 Thien-Thi Nguyen + + * pre-inst-guile.in (top_srcdir): Fix ref bug: Force absolute. + 2002-02-27 Thien-Thi Nguyen * pre-inst-guile.in: Typofix; nfc. From 114d6a9423b9df4709600def06ecae1d74770917 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 19:28:00 +0000 Subject: [PATCH 33/41] Remove self. --- THANKS | 1 - 1 file changed, 1 deletion(-) diff --git a/THANKS b/THANKS index 4ef8ceb73..508aa098a 100644 --- a/THANKS +++ b/THANKS @@ -6,7 +6,6 @@ Contributors since the last release: Rob Browning Stefan Jahn - Thien-Thi Nguyen For fixes or providing information which led to a fix: From b51bad08b3d287ae7b1c67a4b243eaf6ac745fc0 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 4 Mar 2002 20:34:30 +0000 Subject: [PATCH 34/41] * Added an entry listing removed definitions. --- NEWS | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/NEWS b/NEWS index 76aa249c3..f6d4003f8 100644 --- a/NEWS +++ b/NEWS @@ -105,6 +105,68 @@ had problems because with them allocation and initialization was separated and the GC could sometimes observe half initialized cells. Only careful coding by the user of SCM_NEWCELL and SCM_NEWCELL2 could make this safe and efficient. +** Removed definitions: scm_lisp_nil, scm_lisp_t, s_nil_ify, scm_m_nil_ify, +s_t_ify, scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify, scm_m_0_ify, s_1_ify, +scm_m_1_ify, scm_debug_newcell, scm_debug_newcell2, scm_tc16_allocated, +SCM_SET_SYMBOL_HASH, SCM_IM_NIL_IFY, SCM_IM_T_IFY, SCM_IM_0_COND, +SCM_IM_0_IFY, SCM_IM_1_IFY, SCM_GC_SET_ALLOCATED, scm_debug_newcell, +scm_debug_newcell2, scm_substring_move_left_x, scm_substring_move_right_x, +long_long, ulong_long, scm_sizet, SCM_WNA, SCM_OUTOFRANGE, SCM_NALLOC, +SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, +SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, +SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, moddata, registered_mods, +scm_register_module_xxx, scm_registered_modules, +scm_clear_registered_modules, scm_wta, *top-level-lookup-closure*, +scm_top_level_lookup_closure_var, scm_system_transformer, scm_eval_3, +scm_eval2, SCM_SETAND_CAR, SCM_SETOR_CAR, SCM_SETAND_CDR, SCM_SETOR_CDR, +SCM_FREEP, SCM_NFREEP, SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, +SCM_GCTYP16, SCM_GCCDR, scm_remember, scm_protect_object, +scm_unprotect_object, root_module_lookup_closure, scm_sym_app, +scm_sym_modules, module_prefix, make_modules_in_var, +beautify_user_module_x_var, try_module_autoload_var, scm_module_full_name, +scm_the_root_module, scm_make_module, scm_ensure_user_module, +scm_load_scheme_module, scm_port, scm_ptob_descriptor, scm_port_rw_active, +scm_close_all_ports_except, scm_rstate, scm_rng, scm_i_rstate, +SCM_SLOPPY_STRINGP, SCM_RWSTRINGP, SCM_STRING_UCHARS, SCM_STRING_CHARS, +scm_read_only_string_p, scm_makstr, scm_makfromstr, +scm_make_shared_substring, scm_tc7_substring, SCM_SLOPPY_CONSP, +SCM_SLOPPY_NCONSP, scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols, +sym_huh, scm_variable_set_name_hint, scm_builtin_variable, SCM_VARVCELL, +SCM_UDVARIABLEP, SCM_DEFVARIABLEP, scm_internal_with_fluids, +scm_make_gsubr, scm_make_gsubr_with_generic, scm_create_hook, list*, +SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, +SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify, scm_sloppy_memq, +scm_sloppy_memv, scm_sloppy_member, scm_end_of_file_key, +scm_read_and_eval_x, scm_mkbig, scm_big2inum, scm_adjbig, scm_normbig, +scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl, SCM_FIXNUM_BIT, +scm_subr_entry, SCM_SUBR_DOC, scm_make_subr_opt, scm_make_subr, +scm_make_subr_with_generic, setjmp_type, setjmp_type, +scm_call_catching_errors, scm_make_smob_type_mfpe, scm_set_smob_mfpe, +scm_strprint_obj, scm_read_0str, scm_eval_0str, SCM_CHARS, SCM_UCHARS, +SCM_SETCHARS, SCM_SLOPPY_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, +SCM_LENGTH_MAX, SCM_LENGTH, SCM_SETLENGTH, SCM_ROSTRINGP, SCM_ROLENGTH, +SCM_ROCHARS, SCM_ROUCHARS, SCM_SUBSTRP, SCM_COERCE_SUBSTR, scm_strhash, +scm_sym2vcell, scm_sym2ovcell_soft, scm_sym2ovcell, +scm_intern_obarray_soft, scm_intern_obarray, scm_intern, scm_intern0, +scm_sysintern, scm_sysintern0, scm_sysintern0_no_module_lookup, +scm_symbol_value0, scm_string_to_obarray_symbol, scm_intern_symbol, +scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p, +scm_symbol_bound_p, scm_symbol_set_x, scm_gentemp, +scm_init_symbols_deprecated, s_vector_set_length_x, scm_vector_set_length_x, +scm_contregs, scm_debug_info, scm_debug_frame, SCM_DSIDEVAL, SCM_OPDIRP, +scm_fport, scm_option, SCM_CONST_LONG, SCM_VCELL, SCM_GLOBAL_VCELL, +SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT, scm_srcprops, scm_srcprops_chunk, +scm_info_frame, scm_stack, scm_array, scm_array_dim, SCM_ARRAY_CONTIGUOUS, +SCM_HUGE_LENGTH, SCM_FUNC_NAME, SCM_WTA, RETURN_SCM_WTA, +SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY, +SCM_VALIDATE_STRINGORSUBSTR, SCM_VALIDATE_ROSTRING, +SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, +SCM_VALIDATE_RWSTRING, SCM_VALIDATE_OPDIR, DIGITS, scm_small_istr2int, +scm_istr2int, scm_istr2flo, scm_istring2number, scm_istr2int, +scm_istr2flo, scm_istring2number, scm_vtable_index_vcell, scm_si_vcell, +SCM_ECONSP, SCM_NECONSP, SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, +SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable + Changes since Guile 1.4: * Changes to the distribution From 2f13db9a0ca7d3ca3bd6254399d0ec01380c4fd2 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 22:37:37 +0000 Subject: [PATCH 35/41] (top_srcdir_absolute): New AC_SUBST var. --- configure.in | 2 ++ 1 file changed, 2 insertions(+) diff --git a/configure.in b/configure.in index 8b42424cd..6c6d44197 100644 --- a/configure.in +++ b/configure.in @@ -686,6 +686,8 @@ AC_SUBST(EXTRA_DOT_X_FILES) dnl See also top_builddir in info node: (libtool)AC_PROG_LIBTOOL top_builddir_absolute=`pwd` AC_SUBST(top_builddir_absolute) +top_srcdir_absolute=`(cd $srcdir ; pwd)` +AC_SUBST(top_srcdir_absolute) AC_CONFIG_FILES([ Makefile From ce8b584c2d92cd2fd15c9727461cf2f7a719db12 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 22:39:06 +0000 Subject: [PATCH 36/41] (top_srcdir): Use `top_srcdir_absolute' AC_SUBST var. --- pre-inst-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pre-inst-guile.in b/pre-inst-guile.in index 149fbd338..206eab174 100644 --- a/pre-inst-guile.in +++ b/pre-inst-guile.in @@ -39,7 +39,7 @@ subdirs_with_ltlibs="srfi guile-readline" # maintain me # env (set by configure) -top_srcdir=`(cd "@top_srcdir@" ; pwd)` +top_srcdir="@top_srcdir_absolute@" top_builddir="@top_builddir_absolute@" [ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \ From 2d78a1c54cd759e855094af4608c78c9fb39d48b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 22:40:21 +0000 Subject: [PATCH 37/41] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 1fd8fa689..f574c3cd2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2002-03-04 Thien-Thi Nguyen + * configure.in (top_srcdir_absolute): New AC_SUBST var. + + * pre-inst-guile.in (top_srcdir): Use `top_srcdir_absolute' + AC_SUBST var. + * pre-inst-guile.in (top_srcdir): Fix ref bug: Force absolute. 2002-02-27 Thien-Thi Nguyen From 829fdfbc6d3578c7493c968d02e15b91f4c859e7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 22:53:34 +0000 Subject: [PATCH 38/41] (top_srcdir): Use `top_srcdir_absolute' AC_SUBST var. --- check-guile.in | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/check-guile.in b/check-guile.in index 9142fcff8..f66bf13be 100644 --- a/check-guile.in +++ b/check-guile.in @@ -11,9 +11,8 @@ set -e -# this script runs in the top-level build-dir. top_builddir=@top_builddir_absolute@ -top_srcdir=@top_srcdir@ +top_srcdir=@top_srcdir_absolute@ TEST_SUITE_DIR=${top_srcdir}/test-suite From 7ca15449ed173ed7c9753f4d030aaa035f5a2e74 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Mar 2002 22:54:19 +0000 Subject: [PATCH 39/41] *** empty log message *** --- ChangeLog | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index f574c3cd2..03334c934 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,8 +2,8 @@ * configure.in (top_srcdir_absolute): New AC_SUBST var. - * pre-inst-guile.in (top_srcdir): Use `top_srcdir_absolute' - AC_SUBST var. + * pre-inst-guile.in, check-guile.in (top_srcdir): + Use `top_srcdir_absolute' AC_SUBST var. * pre-inst-guile.in (top_srcdir): Fix ref bug: Force absolute. From 3f04400dd27771811e32669786cdc24746f8f00e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 5 Mar 2002 21:10:15 +0000 Subject: [PATCH 40/41] * eval.c (SCM_CEVAL): Cleaned up the handling of 'apply'. Removed side-effecting operations from conditions and macro calls. Replaced SCM_N?IMP by a more explicit predicate in some places. Minimized the scope of some variables. --- libguile/ChangeLog | 7 ++++++ libguile/eval.c | 63 ++++++++++++++++++++++++++-------------------- 2 files changed, 43 insertions(+), 27 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 06f0bf053..66d68ae0d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-03-02 Dirk Herrmann + + * eval.c (SCM_CEVAL): Cleaned up the handling of 'apply'. Removed + side-effecting operations from conditions and macro calls. + Replaced SCM_N?IMP by a more explicit predicate in some places. + Minimized the scope of some variables. + 2002-03-02 Stefan Jahn * convert.i.c: Fixed int <-> long conversions which would have diff --git a/libguile/eval.c b/libguile/eval.c index f2c8b07e8..6167b5b23 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2348,18 +2348,19 @@ dispatch: /* new syntactic forms go here. */ - case SCM_BIT8(SCM_MAKISYM (0)): + case SCM_BIT8 (SCM_MAKISYM (0)): proc = SCM_CAR (x); SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch (SCM_ISYMNUM (proc)) { + + case (SCM_ISYMNUM (SCM_IM_APPLY)): proc = SCM_CDR (x); proc = EVALCAR (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); + SCM_ASRTGO (!SCM_IMP (proc), badfun); if (SCM_CLOSUREP (proc)) { - SCM argl, tl; PREP_APPLY (proc, SCM_EOL); t.arg1 = SCM_CDDR (x); t.arg1 = EVALCAR (t.arg1, env); @@ -2367,36 +2368,44 @@ dispatch: /* Go here to tail-call a closure. PROC is the closure and T.ARG1 is the list of arguments. Do not forget to call PREP_APPLY. */ + { + SCM formals = SCM_CLOSURE_FORMALS (proc); #ifdef DEVAL - debug.info->a.args = t.arg1; + debug.info->a.args = t.arg1; #endif #ifndef SCM_RECKLESS - if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1)) - goto wrongnumargs; + if (scm_badargsp (formals, t.arg1)) + goto wrongnumargs; #endif - ENTER_APPLY; - /* Copy argument list */ - if (SCM_IMP (t.arg1)) - argl = t.arg1; - else - { - argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED); - while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1)) - && SCM_CONSP (t.arg1)) - { - SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1), - SCM_UNSPECIFIED)); - tl = SCM_CDR (tl); - } - SCM_SETCDR (tl, t.arg1); - } + ENTER_APPLY; + /* Copy argument list */ + if (SCM_NULL_OR_NIL_P (t.arg1)) + env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + else + { + SCM args = scm_list_1 (SCM_CAR (t.arg1)); + SCM tail = args; + t.arg1 = SCM_CDR (t.arg1); + while (!SCM_NULL_OR_NIL_P (t.arg1)) + { + SCM new_tail = scm_list_1 (SCM_CAR (t.arg1)); + SCM_SETCDR (tail, new_tail); + tail = new_tail; + t.arg1 = SCM_CDR (t.arg1); + } + env = EXTEND_ENV (formals, args, SCM_ENV (proc)); + } - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc)); - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } } - proc = scm_f_apply; - goto evapply; + else + { + proc = scm_f_apply; + goto evapply; + } + case (SCM_ISYMNUM (SCM_IM_CONT)): { From df6251728851efe2a62e5a887249423b01694c7b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 6 Mar 2002 02:43:56 +0000 Subject: [PATCH 41/41] Initial revision --- ice-9/ftw.scm | 384 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 384 insertions(+) create mode 100644 ice-9/ftw.scm diff --git a/ice-9/ftw.scm b/ice-9/ftw.scm new file mode 100644 index 000000000..1d2ec5e93 --- /dev/null +++ b/ice-9/ftw.scm @@ -0,0 +1,384 @@ +;;;; ftw.scm --- filesystem tree walk + +;;;; Copyright (C) 2002 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 +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;; Author: Thien-Thi Nguyen + +;;; Commentary: + +;; Two procedures are provided: `ftw' and `nftw'. + +;; NOTE: The following description was adapted from the GNU libc info page, w/ +;; significant modifications for a more "Schemey" interface. Most noticible +;; are the inlining of `struct FTW *' parameters `base' and `level' and the +;; omission of `descriptors' parameters. + +;; * Types +;; +;; The X/Open specification defines two procedures to process whole +;; hierarchies of directories and the contained files. Both procedures +;; of this `ftw' family take as one of the arguments a callback procedure +;; which must be of these types. +;; +;; - Data Type: __ftw_proc_t +;; (lambda (filename statinfo flag) ...) => status +;; +;; Type for callback procedures given to the `ftw' procedure. The +;; first parameter is a filename, the second parameter is the +;; vector value as returned by calling `stat' on FILENAME. +;; +;; The last parameter is a symbol giving more information about +;; FILENAM. It can have one of the following values: +;; +;; `regular' +;; The current item is a normal file or files which do not fit +;; into one of the following categories. This means +;; especially special files, sockets etc. +;; +;; `directory' +;; The current item is a directory. +;; +;; `invalid-stat' +;; The `stat' call to fill the object pointed to by the second +;; parameter failed and so the information is invalid. +;; +;; `directory-not-readable' +;; The item is a directory which cannot be read. +;; +;; `symlink' +;; The item is a symbolic link. Since symbolic links are +;; normally followed seeing this value in a `ftw' callback +;; procedure means the referenced file does not exist. The +;; situation for `nftw' is different. +;; +;; - Data Type: __nftw_proc_t +;; (lambda (filename statinfo flag base level) ...) => status +;; +;; The first three arguments have the same as for the +;; `__ftw_proc_t' type. A difference is that for the third +;; argument some additional values are defined to allow finer +;; differentiation: +;; +;; `directory-processed' +;; The current item is a directory and all subdirectories have +;; already been visited and reported. This flag is returned +;; instead of `directory' if the `depth' flag is given to +;; `nftw' (see below). +;; +;; `stale-symlink' +;; The current item is a stale symbolic link. The file it +;; points to does not exist. +;; +;; The last two parameters are described below. They contain +;; information to help interpret FILENAME and give some information +;; about current state of the traversal of the directory hierarchy. +;; +;; `base' +;; The value specifies which part of the filename argument +;; given in the first parameter to the callback procedure is +;; the name of the file. The rest of the string is the path +;; to locate the file. This information is especially +;; important if the `chdir' flag for `nftw' was set since then +;; the current directory is the one the current item is found +;; in. +;; +;; `level' +;; While processing the directory the procedures tracks how +;; many directories have been examined to find the current +;; item. This nesting level is 0 for the item given starting +;; item (file or directory) and is incremented by one for each +;; entered directory. +;; +;; * Procedure: (ftw filename proc . options) +;; Do a filesystem tree walk starting at FILENAME using PROC. +;; +;; The `ftw' procedure calls the callback procedure given in the +;; parameter PROC for every item which is found in the directory +;; specified by FILENAME and all directories below. The procedure +;; follows symbolic links if necessary but does not process an item +;; twice. If FILENAME names no directory this item is the only +;; object reported by calling the callback procedure. +;; +;; The filename given to the callback procedure is constructed by +;; taking the FILENAME parameter and appending the names of all +;; passed directories and then the local file name. So the +;; callback procedure can use this parameter to access the file. +;; Before the callback procedure is called `ftw' calls `stat' for +;; this file and passes the information up to the callback +;; procedure. If this `stat' call was not successful the failure is +;; indicated by setting the flag argument of the callback procedure +;; to `invalid-stat'. Otherwise the flag is set according to the +;; description given in the description of `__ftw_proc_t' above. +;; +;; The callback procedure is expected to return non-#f to indicate +;; that no error occurred and the processing should be continued. +;; If an error occurred in the callback procedure or the call to +;; `ftw' shall return immediately the callback procedure can return +;; #f. This is the only correct way to stop the procedure. The +;; program must not use `throw' or similar techniques to continue +;; the program in another place. [Can we relax this? --ttn] +;; +;; The return value of the `ftw' procedure is #t if all callback +;; procedure calls returned #t and all actions performed by the +;; `ftw' succeeded. If some procedure call failed (other than +;; calling `stat' on an item) the procedure returns #f. If a +;; callback procedure returns a value other than #t this value is +;; returned as the return value of `ftw'. +;; +;; * Procedure: (nftw filename proc . control-flags) +;; Do a new-style filesystem tree walk starting at FILENAME using PROC. +;; Various optional CONTROL-FLAGS alter the default behavior. +;; +;; The `nftw' procedures works like the `ftw' procedures. It calls +;; the callback procedure PROC for all items it finds in the +;; directory FILENAME and below. +;; +;; The differences are that for one the callback procedure is of a +;; different type. It takes also `base' and `level' parameters as +;; described above. +;; +;; The second difference is that `nftw' takes additional optional +;; arguments which are zero or more of the following symbols: +;; +;; physical' +;; While traversing the directory symbolic links are not +;; followed. I.e., if this flag is given symbolic links are +;; reported using the `symlink' value for the type parameter +;; to the callback procedure. Please note that if this flag is +;; used the appearance of `symlink' in a callback procedure +;; does not mean the referenced file does not exist. To +;; indicate this the extra value `stale-symlink' exists. +;; +;; mount' +;; The callback procedure is only called for items which are on +;; the same mounted filesystem as the directory given as the +;; FILENAME parameter to `nftw'. +;; +;; chdir' +;; If this flag is given the current working directory is +;; changed to the directory containing the reported object +;; before the callback procedure is called. +;; +;; depth' +;; If this option is given the procedure visits first all files +;; and subdirectories before the callback procedure is called +;; for the directory itself (depth-first processing). This +;; also means the type flag given to the callback procedure is +;; `directory-processed' and not `directory'. +;; +;; The return value is computed in the same way as for `ftw'. +;; `nftw' returns #t if no failure occurred in `nftw' and all +;; callback procedure call return values are also #t. For internal +;; errors such as memory problems the error `ftw-error' is thrown. +;; If the return value of a callback invocation is not #t this +;; very same value is returned. + +;;; Code: + +(define-module (ice-9 ftw) + :export (ftw nftw)) + +(define (directory-files dir) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + acc + (loop (readdir dir-stream) + (if (or (string=? "." new) ;;; ignore + (string=? ".." new)) ;;; ignore + acc + (cons new acc))))))) + +(define (pathify . nodes) + (let loop ((nodes nodes) + (result "")) + (if (null? nodes) + (or (and (string=? "" result) "") + (substring result 1 (string-length result))) + (loop (cdr nodes) (string-append result "/" (car nodes)))))) + +(define (abs? filename) + (char=? #\/ (string-ref filename 0))) + +(define (visited?-proc size) + (let ((visited (make-hash-table size))) + (lambda (s) + (and s (let ((ino (stat:ino s))) + (or (hash-ref visited ino) + (begin + (hash-set! visited ino #t) + #f))))))) + +(define (stat-dir-readable?-proc uid gid) + (let ((uid (getuid)) + (gid (getgid))) + (lambda (s) + (let* ((perms (stat:perms s)) + (perms-bit-set? (lambda (mask) + (not (= 0 (logand mask perms)))))) + (or (and (= uid (stat:uid s)) + (perms-bit-set? #o400)) + (and (= gid (stat:gid s)) + (perms-bit-set? #o040)) + (perms-bit-set? #o004)))))) + +(define (stat&flag-proc dir-readable? . control-flags) + (let* ((directory-flag (if (memq 'depth control-flags) + 'directory-processed + 'directory)) + (stale-symlink-flag (if (memq 'nftw-style control-flags) + 'stale-symlink + 'symlink)) + (physical? (memq 'physical control-flags)) + (easy-flag (lambda (s) + (let ((type (stat:type s))) + (if (eq? 'directory type) + (if (dir-readable? s) + directory-flag + 'directory-not-readable) + 'regular))))) + (lambda (name) + (let ((s (false-if-exception (lstat name)))) + (cond ((not s) + (values s 'invalid-stat)) + ((eq? 'symlink (stat:type s)) + (let ((s-follow (false-if-exception (stat name)))) + (cond ((not s-follow) + (values s stale-symlink-flag)) + ((and s-follow physical?) + (values s 'symlink)) + ((and s-follow (not physical?)) + (values s-follow (easy-flag s-follow)))))) + (else (values s (easy-flag s)))))))) + +(define (clean name) + (let ((last-char-index (1- (string-length name)))) + (if (char=? #\/ (string-ref name last-char-index)) + (substring name 0 last-char-index) + name))) + +(define (ftw filename proc . options) + (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr) + (else 211)))) + (stat&flag (stat&flag-proc + (stat-dir-readable?-proc (getuid) (getgid))))) + (letrec ((go (lambda (fullname) + (call-with-values (lambda () (stat&flag fullname)) + (lambda (s flag) + (or (visited? s) + (let ((ret (proc fullname s flag))) ; callback + (or (eq? #t ret) + (throw 'ftw-early-exit ret)) + (and (eq? 'directory flag) + (for-each + (lambda (child) + (go (pathify fullname child))) + (directory-files fullname))) + #t))))))) + (catch 'ftw-early-exit + (lambda () (go (clean filename))) + (lambda (key val) val))))) + +(define (nftw filename proc . control-flags) + (let* ((od (getcwd)) ; orig dir + (odev (let ((s (false-if-exception (lstat filename)))) + (if s (stat:dev s) -1))) + (same-dev? (if (memq 'mount control-flags) + (lambda (s) (= (stat:dev s) odev)) + (lambda (s) #t))) + (base-sub (lambda (name base) (substring name 0 base))) + (maybe-cd (if (memq 'chdir control-flags) + (if (abs? filename) + (lambda (fullname base) + (or (= 0 base) + (chdir (base-sub fullname base)))) + (lambda (fullname base) + (chdir + (pathify od (base-sub fullname base))))) + (lambda (fullname base) #t))) + (maybe-cd-back (if (memq 'chdir control-flags) + (lambda () (chdir od)) + (lambda () #t))) + (depth-first? (memq 'depth control-flags)) + (visited? (visited?-proc + (cond ((memq 'hash-size control-flags) => cadr) + (else 211)))) + (has-kids? (if depth-first? + (lambda (flag) (eq? flag 'directory-processed)) + (lambda (flag) (eq? flag 'directory)))) + (stat&flag (apply stat&flag-proc + (stat-dir-readable?-proc (getuid) (getgid)) + (cons 'nftw-style control-flags)))) + (letrec ((go (lambda (fullname base level) + (call-with-values (lambda () (stat&flag fullname)) + (lambda (s flag) + (letrec ((self (lambda () + (maybe-cd fullname base) + ;; the callback + (let ((ret (proc fullname s flag + base level))) + (maybe-cd-back) + (or (eq? #t ret) + (throw 'nftw-early-exit ret))))) + (kids (lambda () + (and (has-kids? flag) + (for-each + (lambda (child) + (go (pathify fullname child) + (1+ (string-length + fullname)) + (1+ level))) + (directory-files fullname)))))) + (or (visited? s) + (not (same-dev? s)) + (if depth-first? + (begin (kids) (self)) + (begin (self) (kids))))))) + #t))) + (let ((ret (catch 'nftw-early-exit + (lambda () (go (clean filename) 0 0)) + (lambda (key val) val)))) + (chdir od) + ret)))) + +;;; ftw.scm ends here