1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00

Merge branch 'master' into boehm-demers-weiser-gc

Conflicts:
	libguile/gc-mark.c
	libguile/procs.c
	libguile/procs.h
	libguile/threads.c
	libguile/threads.h
This commit is contained in:
Ludovic Courtès 2009-02-14 17:32:46 +01:00
commit f7a1ab8b94
17 changed files with 143 additions and 387 deletions

1
.gitignore vendored
View file

@ -74,3 +74,4 @@ libguile/stack-limit-calibration.scm
cscope.out cscope.out
cscope.files cscope.files
*.log *.log
INSTALL

291
INSTALL
View file

@ -1,291 +0,0 @@
Installation Instructions
*************************
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
2006, 2007, 2008 Free Software Foundation, Inc.
This file is free documentation; the Free Software Foundation gives
unlimited permission to copy, distribute and modify it.
Basic Installation
==================
Briefly, the shell commands `./configure; make; make install' should
configure, build, and install this package. The following
more-detailed instructions are generic; see the `README' file for
instructions specific to this package.
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation. It uses
those values to create a `Makefile' in each directory of the package.
It may also create one or more `.h' files containing system-dependent
definitions. Finally, it creates a shell script `config.status' that
you can run in the future to recreate the current configuration, and a
file `config.log' containing compiler output (useful mainly for
debugging `configure').
It can also use an optional file (typically called `config.cache'
and enabled with `--cache-file=config.cache' or simply `-C') that saves
the results of its tests to speed up reconfiguring. Caching is
disabled by default to prevent problems with accidental use of stale
cache files.
If you need to do unusual things to compile the package, please try
to figure out how `configure' could check whether to do them, and mail
diffs or instructions to the address given in the `README' so they can
be considered for the next release. If you are using the cache, and at
some point `config.cache' contains results you don't want to keep, you
may remove or edit it.
The file `configure.ac' (or `configure.in') is used to create
`configure' by a program called `autoconf'. You need `configure.ac' if
you want to change it or regenerate `configure' using a newer version
of `autoconf'.
The simplest way to compile this package is:
1. `cd' to the directory containing the package's source code and type
`./configure' to configure the package for your system.
Running `configure' might take a while. While running, it prints
some messages telling which features it is checking for.
2. Type `make' to compile the package.
3. Optionally, type `make check' to run any self-tests that come with
the package.
4. Type `make install' to install the programs and any data files and
documentation.
5. You can remove the program binaries and object files from the
source code directory by typing `make clean'. To also remove the
files that `configure' created (so you can compile the package for
a different kind of computer), type `make distclean'. There is
also a `make maintainer-clean' target, but that is intended mainly
for the package's developers. If you use it, you may have to get
all sorts of other programs in order to regenerate files that came
with the distribution.
6. Often, you can also type `make uninstall' to remove the installed
files again.
Compilers and Options
=====================
Some systems require unusual options for compilation or linking that
the `configure' script does not know about. Run `./configure --help'
for details on some of the pertinent environment variables.
You can give `configure' initial values for configuration parameters
by setting variables in the command line or in the environment. Here
is an example:
./configure CC=c99 CFLAGS=-g LIBS=-lposix
*Note Defining Variables::, for more details.
Compiling For Multiple Architectures
====================================
You can compile the package for more than one kind of computer at the
same time, by placing the object files for each architecture in their
own directory. To do this, you can use GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'.
With a non-GNU `make', it is safer to compile the package for one
architecture at a time in the source code directory. After you have
installed the package for one architecture, use `make distclean' before
reconfiguring for another architecture.
On MacOS X 10.5 and later systems, you can create libraries and
executables that work on multiple system types--known as "fat" or
"universal" binaries--by specifying multiple `-arch' options to the
compiler but only a single `-arch' option to the preprocessor. Like
this:
./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
CPP="gcc -E" CXXCPP="g++ -E"
This is not guaranteed to produce working output in all cases, you
may have to build one architecture at a time and combine the results
using the `lipo' tool if you have problems.
Installation Names
==================
By default, `make install' installs the package's commands under
`/usr/local/bin', include files under `/usr/local/include', etc. You
can specify an installation prefix other than `/usr/local' by giving
`configure' the option `--prefix=PREFIX'.
You can specify separate installation prefixes for
architecture-specific files and architecture-independent files. If you
pass the option `--exec-prefix=PREFIX' to `configure', the package uses
PREFIX as the prefix for installing programs and libraries.
Documentation and other data files still use the regular prefix.
In addition, if you use an unusual directory layout you can give
options like `--bindir=DIR' to specify different values for particular
kinds of files. Run `configure --help' for a list of the directories
you can set and what kinds of files go in them.
If the package supports it, you can cause programs to be installed
with an extra prefix or suffix on their names by giving `configure' the
option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
Optional Features
=================
Some packages pay attention to `--enable-FEATURE' options to
`configure', where FEATURE indicates an optional part of the package.
They may also pay attention to `--with-PACKAGE' options, where PACKAGE
is something like `gnu-as' or `x' (for the X Window System). The
`README' should mention any `--enable-' and `--with-' options that the
package recognizes.
For packages that use the X Window System, `configure' can usually
find the X include and library files automatically, but if it doesn't,
you can use the `configure' options `--x-includes=DIR' and
`--x-libraries=DIR' to specify their locations.
Particular systems
==================
On HP-UX, the default C compiler is not ANSI C compatible. If GNU
CC is not installed, it is recommended to use the following options in
order to use an ANSI C compiler:
./configure CC="cc -Ae"
and if that doesn't work, install pre-built binaries of GCC for HP-UX.
On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot
parse its `<wchar.h>' header file. The option `-nodtk' can be used as
a workaround. If GNU CC is not installed, it is therefore recommended
to try
./configure CC="cc"
and if that doesn't work, try
./configure CC="cc -nodtk"
Specifying the System Type
==========================
There may be some features `configure' cannot figure out
automatically, but needs to determine by the type of machine the package
will run on. Usually, assuming the package is built to be run on the
_same_ architectures, `configure' can figure that out, but if it prints
a message saying it cannot guess the machine type, give it the
`--build=TYPE' option. TYPE can either be a short name for the system
type, such as `sun4', or a canonical name which has the form:
CPU-COMPANY-SYSTEM
where SYSTEM can have one of these forms:
OS KERNEL-OS
See the file `config.sub' for the possible values of each field. If
`config.sub' isn't included in this package, then this package doesn't
need to know the machine type.
If you are _building_ compiler tools for cross-compiling, you should
use the option `--target=TYPE' to select the type of system they will
produce code for.
If you want to _use_ a cross compiler, that generates code for a
platform different from the build platform, you should specify the
"host" platform (i.e., that on which the generated programs will
eventually be run) with `--host=TYPE'.
Sharing Defaults
================
If you want to set default values for `configure' scripts to share,
you can create a site shell script called `config.site' that gives
default values for variables like `CC', `cache_file', and `prefix'.
`configure' looks for `PREFIX/share/config.site' if it exists, then
`PREFIX/etc/config.site' if it exists. Or, you can set the
`CONFIG_SITE' environment variable to the location of the site script.
A warning: not all `configure' scripts look for a site script.
Defining Variables
==================
Variables not defined in a site shell script can be set in the
environment passed to `configure'. However, some packages may run
configure again during the build, and the customized values of these
variables may be lost. In order to avoid this problem, you should set
them in the `configure' command line, using `VAR=value'. For example:
./configure CC=/usr/local2/bin/gcc
causes the specified `gcc' to be used as the C compiler (unless it is
overridden in the site shell script).
Unfortunately, this technique does not work for `CONFIG_SHELL' due to
an Autoconf bug. Until the bug is fixed you can use this workaround:
CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash
`configure' Invocation
======================
`configure' recognizes the following options to control how it
operates.
`--help'
`-h'
Print a summary of all of the options to `configure', and exit.
`--help=short'
`--help=recursive'
Print a summary of the options unique to this package's
`configure', and exit. The `short' variant lists options used
only in the top level, while the `recursive' variant lists options
also present in any nested packages.
`--version'
`-V'
Print the version of Autoconf used to generate the `configure'
script, and exit.
`--cache-file=FILE'
Enable the cache: use and save the results of the tests in FILE,
traditionally `config.cache'. FILE defaults to `/dev/null' to
disable caching.
`--config-cache'
`-C'
Alias for `--cache-file=config.cache'.
`--quiet'
`--silent'
`-q'
Do not print messages saying which checks are being made. To
suppress all normal output, redirect it to `/dev/null' (any error
messages will still be shown).
`--srcdir=DIR'
Look for the package's source code in directory DIR. Usually
`configure' can determine that directory automatically.
`--prefix=DIR'
Use DIR as the installation prefix. *Note Installation Names::
for more details, including other options available for fine-tuning
the installation locations.
`--no-create'
`-n'
Run the configure checks, but stop before creating any output
files.
`configure' also accepts some other, not widely useful, options. Run
`configure --help' for more details.

15
NEWS
View file

@ -1,5 +1,5 @@
Guile NEWS --- history of user-visible changes. Guile NEWS --- history of user-visible changes.
Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
See the end for copying conditions. See the end for copying conditions.
Please send Guile bug reports to bug-guile@gnu.org. Please send Guile bug reports to bug-guile@gnu.org.
@ -40,12 +40,25 @@ application code.
** Functions for handling `scm_option' now no longer require an argument ** Functions for handling `scm_option' now no longer require an argument
indicating length of the `scm_t_option' array. indicating length of the `scm_t_option' array.
** Primitive procedures (aka. "subrs") are now stored in double cells
This removes the subr table and simplifies the code.
Changes in 1.8.7 (since 1.8.6) Changes in 1.8.7 (since 1.8.6)
* Bugs fixed * Bugs fixed
** Fix %fast-slot-ref/set!, to avoid possible segmentation fault ** Fix %fast-slot-ref/set!, to avoid possible segmentation fault
** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion
** Fix build problem when scm_t_timespec is different from struct timespec
** Fix build when compiled with -Wundef -Werror
** Allow @ macro to work with (ice-9 syncase)
Previously, use of the @ macro in a module whose code is being
transformed by (ice-9 syncase) would cause an "Invalid syntax" error.
Now it works as you would expect (giving the value of the specified
module binding).
Changes in 1.8.6 (since 1.8.5) Changes in 1.8.6 (since 1.8.5)

4
THANKS
View file

@ -23,6 +23,7 @@ For fixes or providing information which led to a fix:
David Allouche David Allouche
Martin Baulig Martin Baulig
Fabrice Bauzac Fabrice Bauzac
Carlo Bramini
Rob Browning Rob Browning
Adrian Bunk Adrian Bunk
Michael Carmack Michael Carmack
@ -35,13 +36,16 @@ For fixes or providing information which led to a fix:
Nils Durner Nils Durner
John W Eaton John W Eaton
Clinton Ebadi Clinton Ebadi
David Fang
Charles Gagnon Charles Gagnon
Peter Gavin Peter Gavin
Eric Gillespie, Jr Eric Gillespie, Jr
Didier Godefroy Didier Godefroy
Panicz Maciej Godek
John Goerzen John Goerzen
Mike Gran Mike Gran
Szavai Gyula Szavai Gyula
Roland Haeder
Sven Hartrumpf Sven Hartrumpf
Eric Hanchrow Eric Hanchrow
Sam Hocevar Sam Hocevar

View file

@ -98,9 +98,12 @@ lib-version.texi: $(top_srcdir)/GUILE-VERSION
MAINTAINERCLEANFILES = autoconf-macros.texi MAINTAINERCLEANFILES = autoconf-macros.texi
# To allow "make distcheck" to succeed, lib-version.texi must either # To allow "make distcheck" to succeed, lib-version.texi must either
# be cleaned or be included in the distribution. There's no point # be cleaned or be included in the distribution. Or both - and in
# forcing a distribution build to regenerate lib-version.texi, because # fact both are good. There's no point forcing a distribution build
# it can't possibly be different on the build machine than where the # to regenerate lib-version.texi, because it can't possibly be
# distribution was generated, so we might as well include it in the # different on the build machine than where the distribution was
# distribution. # generated, so we might as well include it in the distribution.
EXTRA_DIST += lib-version.texi EXTRA_DIST += lib-version.texi
# But when we want to get back to a clean tree, lib-version.texi
# should be cleaned.
CLEANFILES = lib-version.texi

View file

@ -29,7 +29,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-8:: receive. * SRFI-8:: receive.
* SRFI-9:: define-record-type. * SRFI-9:: define-record-type.
* SRFI-10:: Hash-Comma Reader Extension. * SRFI-10:: Hash-Comma Reader Extension.
* SRFI-11:: let-values and let-values*. * SRFI-11:: let-values and let*-values.
* SRFI-13:: String library. * SRFI-13:: String library.
* SRFI-14:: Character-set library. * SRFI-14:: Character-set library.
* SRFI-16:: case-lambda * SRFI-16:: case-lambda
@ -1514,9 +1514,9 @@ the anonymous and compact syntax of @nicode{#,()} is much better.
@cindex SRFI-11 @cindex SRFI-11
@findex let-values @findex let-values
@findex let-values* @findex let*-values
This module implements the binding forms for multiple values This module implements the binding forms for multiple values
@code{let-values} and @code{let-values*}. These forms are similar to @code{let-values} and @code{let*-values}. These forms are similar to
@code{let} and @code{let*} (@pxref{Local Bindings}), but they support @code{let} and @code{let*} (@pxref{Local Bindings}), but they support
binding of the values returned by multiple-valued expressions. binding of the values returned by multiple-valued expressions.
@ -1533,7 +1533,7 @@ available.
@code{let-values} performs all bindings simultaneously, which means that @code{let-values} performs all bindings simultaneously, which means that
no expression in the binding clauses may refer to variables bound in the no expression in the binding clauses may refer to variables bound in the
same clause list. @code{let-values*}, on the other hand, performs the same clause list. @code{let*-values}, on the other hand, performs the
bindings sequentially, just like @code{let*} does for single-valued bindings sequentially, just like @code{let*} does for single-valued
expressions. expressions.

View file

@ -20,12 +20,58 @@
:use-module (ice-9 documentation) :use-module (ice-9 documentation)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (ice-9 rdelim) :use-module (ice-9 rdelim)
:export (help apropos apropos-internal apropos-fold :export (help
apropos-fold-accessible apropos-fold-exported apropos-fold-all add-value-help-handler! remove-value-help-handler!
source arity system-module)) add-name-help-handler! remove-name-help-handler!
apropos apropos-internal apropos-fold apropos-fold-accessible
apropos-fold-exported apropos-fold-all source arity
system-module module-commentary))
(define *value-help-handlers*
`(,(lambda (name value)
(object-documentation value))))
(define (add-value-help-handler! proc)
"Adds a handler for performing `help' on a value.
`proc' will be called as (PROC NAME VALUE). `proc' should return #t to
indicate that it has performed help, a string to override the default
object documentation, or #f to try the other handlers, potentially
falling back on the normal behavior for `help'."
(set! *value-help-handlers* (cons proc *value-help-handlers*)))
(define (remove-value-help-handler! proc)
"Removes a handler for performing `help' on a value."
(set! *value-help-handlers* (delete! proc *value-help-handlers*)))
(define (try-value-help name value)
(or-map (lambda (proc) (proc name value)) *value-help-handlers*))
(define *name-help-handlers* '())
(define (add-name-help-handler! proc)
"Adds a handler for performing `help' on a name.
`proc' will be called with the unevaluated name as its argument. That is
to say, when the user calls `(help FOO)', the name is FOO, exactly as
the user types it.
`proc' should return #t to indicate that it has performed help, a string
to override the default object documentation, or #f to try the other
handlers, potentially falling back on the normal behavior for `help'."
(set! *name-help-handlers* (cons proc *name-help-handlers*)))
(define (remove-name-help-handler! proc)
"Removes a handler for performing `help' on a name."
(set! *name-help-handlers* (delete! proc *name-help-handlers*)))
(define (try-name-help name)
(or-map (lambda (proc) (proc name)) *name-help-handlers*))
;;; Documentation ;;; Documentation
;;; ;;;
(define help (define help
@ -45,6 +91,10 @@ You don't seem to have regular expressions installed.\n"))
type x)))) type x))))
(cond (cond
;; User-specified
((try-name-help name)
=> (lambda (x) (if (not (eq? x #t)) (display x))))
;; SYMBOL ;; SYMBOL
((symbol? name) ((symbol? name)
(help-doc name (help-doc name
@ -60,10 +110,11 @@ You don't seem to have regular expressions installed.\n"))
((and (list? name) ((and (list? name)
(= (length name) 2) (= (length name) 2)
(eq? (car name) 'unquote)) (eq? (car name) 'unquote))
(cond ((object-documentation (let ((doc (try-value-help (cadr name)
(local-eval (cadr name) env)) (local-eval (cadr name) env))))
=> write-line) (cond ((not doc) (not-found 'documentation (cadr name)))
(else (not-found 'documentation (cadr name))))) ((eq? doc #t)) ;; pass
(else (write-line doc)))))
;; (quote SYMBOL) ;; (quote SYMBOL)
((and (list? name) ((and (list? name)
@ -109,7 +160,7 @@ You don't seem to have regular expressions installed.\n"))
(let ((entries (apropos-fold (lambda (module name object data) (let ((entries (apropos-fold (lambda (module name object data)
(cons (list module (cons (list module
name name
(object-documentation object) (try-value-help name object)
(cond ((closure? object) (cond ((closure? object)
"a procedure") "a procedure")
((procedure? object) ((procedure? object)

View file

@ -146,9 +146,11 @@
(let ((e ((macro-transformer m) (let ((e ((macro-transformer m)
e e
(append r (list eval-closure))))) (append r (list eval-closure)))))
(if (null? r) (if (variable? e)
(sc-expand e) e
(sc-chi e r w)))))))))) (if (null? r)
(sc-expand e)
(sc-chi e r w)))))))))))
(define generated-symbols (make-weak-key-hash-table 1019)) (define generated-symbols (make-weak-key-hash-table 1019))

View file

@ -38,6 +38,25 @@
# include <config.h> # include <config.h>
#endif #endif
/* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't
need it anymore, and because on MinGW:
- the definition of struct timespec is provided (if at all) by
pthread.h
- pthread.h will _not_ define struct timespec if
HAVE_STRUCT_TIMESPEC is 1, because then it thinks that it doesn't
need to.
The libguile C code doesn't need HAVE_STRUCT_TIMESPEC anymore,
because the value of HAVE_STRUCT_TIMESPEC has already been
incorporated in how scm_t_timespec is defined (in scmconfig.h), and
the rest of the libguile C code now just uses scm_t_timespec.
*/
#ifdef HAVE_STRUCT_TIMESPEC
#undef HAVE_STRUCT_TIMESPEC
#endif
#include <errno.h> #include <errno.h>
#include "libguile/__scm.h" #include "libguile/__scm.h"

View file

@ -1905,7 +1905,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
gf, gf,
SCM_SNAME (extension)); SCM_SNAME (extension));
*SCM_SUBR_GENERIC (extension) = gext; SCM_SET_SUBR_GENERIC (extension, gext);
} }
else else
{ {

View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public * modify it under the terms of the GNU Lesser General Public
@ -75,13 +75,13 @@ create_gsubr (int define, const char *name,
subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
create_subr: create_subr:
if (define) if (define)
scm_define (SCM_SUBR_ENTRY(subr).name, subr); scm_define (SCM_SNAME (subr), subr);
return subr; return subr;
default: default:
{ {
SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
SCM sym = SCM_SUBR_ENTRY(subr).name; SCM sym = SCM_SNAME (subr);
if (SCM_GSUBR_MAX < req + opt + rst) if (SCM_GSUBR_MAX < req + opt + rst)
{ {
fprintf (stderr, fprintf (stderr,
@ -151,7 +151,7 @@ create_gsubr_with_generic (int define,
subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
create_subr: create_subr:
if (define) if (define)
scm_define (SCM_SUBR_ENTRY(subr).name, subr); scm_define (SCM_SNAME (subr), subr);
return subr; return subr;
default: default:
; ;

View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public * modify it under the terms of the GNU Lesser General Public
@ -446,7 +446,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_struct_prehistory (); /* requires storage */ scm_struct_prehistory (); /* requires storage */
scm_symbols_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */
scm_init_subr_table ();
#if 0 #if 0
scm_environments_prehistory (); /* requires storage */ scm_environments_prehistory (); /* requires storage */
#endif #endif

View file

@ -54,7 +54,7 @@
C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
inline" in that case. */ inline" in that case. */
# if (defined __GNUC__) && (!(__APPLE_CC__ > 5400 && __STDC_VERSION__ >= 199901L)) # if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
# define SCM_C_USE_EXTERN_INLINE 1 # define SCM_C_USE_EXTERN_INLINE 1
# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2) # if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
# define SCM_C_EXTERN_INLINE \ # define SCM_C_EXTERN_INLINE \

View file

@ -37,45 +37,20 @@
/* {Procedures} /* {Procedures}
*/ */
scm_t_subr_entry *scm_subr_table;
/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ SCM
/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
startup, 786 with guile-readline. 'martin */
static unsigned long scm_subr_table_size = 0;
static unsigned long scm_subr_table_room = 800;
/* Hint for `scm_gc_malloc ()' and friends. */
static const char subr_table_gc_hint[] = "subr table";
SCM
scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
{ {
register SCM z; register SCM z;
unsigned long entry; SCM *meta_info;
if (scm_subr_table_size == scm_subr_table_room) meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
{ meta_info[0] = scm_from_locale_symbol (name);
long new_size = scm_subr_table_room * 3 / 2; meta_info[1] = SCM_EOL; /* properties */
void *new_table
= scm_gc_realloc (scm_subr_table, z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn,
sizeof (* scm_subr_table) * scm_subr_table_room, 0 /* generic */, (scm_t_bits) meta_info);
sizeof (* scm_subr_table) * new_size,
subr_table_gc_hint);
scm_subr_table = new_table;
scm_subr_table_room = new_size;
}
entry = scm_subr_table_size;
z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn);
scm_subr_table[entry].handle = z;
scm_subr_table[entry].name = scm_from_locale_symbol (name);
scm_subr_table[entry].generic = 0;
scm_subr_table[entry].properties = SCM_EOL;
scm_subr_table_size++;
return z; return z;
} }
@ -83,7 +58,7 @@ SCM
scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
{ {
SCM subr = scm_c_make_subr (name, type, fcn); SCM subr = scm_c_make_subr (name, type, fcn);
scm_define (SCM_SUBR_ENTRY(subr).name, subr); scm_define (SCM_SNAME (subr), subr);
return subr; return subr;
} }
@ -92,7 +67,7 @@ scm_c_make_subr_with_generic (const char *name,
long type, SCM (*fcn) (), SCM *gf) long type, SCM (*fcn) (), SCM *gf)
{ {
SCM subr = scm_c_make_subr (name, type, fcn); SCM subr = scm_c_make_subr (name, type, fcn);
SCM_SUBR_ENTRY(subr).generic = gf; SCM_SET_SUBR_GENERIC_LOC (subr, gf);
return subr; return subr;
} }
@ -101,7 +76,7 @@ scm_c_define_subr_with_generic (const char *name,
long type, SCM (*fcn) (), SCM *gf) long type, SCM (*fcn) (), SCM *gf)
{ {
SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
scm_define (SCM_SUBR_ENTRY(subr).name, subr); scm_define (SCM_SNAME (subr), subr);
return subr; return subr;
} }
@ -327,16 +302,7 @@ scm_setter (SCM proc)
return SCM_BOOL_F; /* not reached */ return SCM_BOOL_F; /* not reached */
} }
void
scm_init_subr_table ()
{
scm_subr_table
= ((scm_t_subr_entry *)
scm_gc_malloc (sizeof (* scm_subr_table) * scm_subr_table_room,
subr_table_gc_hint));
}
void void
scm_init_procs () scm_init_procs ()
{ {

View file

@ -30,23 +30,14 @@
/* Subrs /* Subrs
*/ */
typedef struct #define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
{ #define SCM_SNAME(x) (SCM_SUBR_META_INFO (x) [0])
SCM handle; /* link back to procedure object */
SCM name;
SCM *generic; /* 0 if no generic support
* *generic == 0 until first method
*/
SCM properties; /* procedure properties */
} scm_t_subr_entry;
#define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8)
#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])
#define SCM_SNAME(x) (SCM_SUBR_ENTRY (x).name)
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) #define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) #define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8)
#define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo) #define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo)
@ -124,10 +115,6 @@ typedef struct
#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj) #define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
SCM_API scm_t_subr_entry *scm_subr_table;
SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)()); SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type, SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf); SCM (*fcn)(), SCM *gf);
@ -144,7 +131,6 @@ SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter); SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc); SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc); SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_subr_table (void);
SCM_INTERNAL void scm_init_procs (void); SCM_INTERNAL void scm_init_procs (void);
#ifdef GUILE_DEBUG #ifdef GUILE_DEBUG

View file

@ -210,7 +210,7 @@ SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond,
pthread_mutex_t *mutex); pthread_mutex_t *mutex);
SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond, SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
pthread_mutex_t *mutex, pthread_mutex_t *mutex,
const struct timespec *abstime); const scm_t_timespec *abstime);
#endif #endif
/* More convenience functions. /* More convenience functions.

View file

@ -34,3 +34,6 @@
(pass-if "basic syncase macro" (pass-if "basic syncase macro"
(= (plus 1 2 3) (+ 1 2 3))) (= (plus 1 2 3) (+ 1 2 3)))
(pass-if "@ works with syncase"
(eq? run-test (@ (test-suite lib) run-test)))