mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

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

Browse source 
Conflicts:
	libguile/gc-card.c
	libguile/gc-mark.c
This commit is contained in:
Ludovic Courtès 2009-03-08 23:04:06 +01:00
commit f307fbcec2
25 changed files with 457 additions and 372 deletions
Download patch file Download diff file Expand all files Collapse all files

1
benchmark-suite/Makefile.am
View file

@ -3,6 +3,7 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/if.bm \
benchmarks/logand.bm \
benchmarks/read.bm \
benchmarks/subr.bm \
benchmarks/uniform-vector-read.bm
EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \

66
benchmark-suite/benchmarks/subr.bm Normal file
View file

@ -0,0 +1,66 @@
;;; subr.bm --- Measure the subr invocation cost. -*- Scheme -*-
;;;
;;; Copyright (C) 2009 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., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301 USA
(define-module (benchmarks subrs)
:use-module (benchmark-suite lib))
(define hook1 (make-hook 1))
(define hook3 (make-hook 3))
(with-benchmark-prefix "subr invocation"
(benchmark "simple subr" 700000
;; 1 required argument, 0 optional arguments, no rest.
(1+ 0))
(benchmark "generic subr" 700000
;; 2 required arguments, 4 optional arguments, no rest.
;; In Guile 1.8 and earlier, such subrs are implemented as "compiled
;; closures" (cclos). There, when a cclo/gsubr is called, the evaluator
;; goes through `SCM_APPLY ()' and conses the arguments, which is more
;; costly than the invocation of a "simple subr".
(string= "foo" "bar"))
(benchmark "generic subr with rest arg" 700000
;; 1 required argument, 0 optional arguments, 1 rest.
(run-hook hook1 1))
(benchmark "generic subr with rest arg and 3+ parameters" 700000
;; 1 required argument, 0 optional arguments, 1 rest.
;; The evaluator considers calls with 3 and more parameters as a general
;; form and always stores the arguments into a list.
(run-hook hook3 1 2 3)))
(with-benchmark-prefix "subr application"
(benchmark "simple subr" 700000
(apply 1+ '(0)))
(benchmark "generic subr" 700000
(apply string= "foo" '("bar")))
(benchmark "generic subr with rest arg" 700000
(apply run-hook hook1 '(1)))
(benchmark "generic subr with rest arg and 3+ parameters" 700000
(run-hook hook3 1 2 '(3))))

5
configure.in
View file

@ -4,7 +4,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
This file is part of GUILE
@ -1561,9 +1561,6 @@ AC_CONFIG_FILES([
ice-9/debugger/Makefile
ice-9/debugging/Makefile
lang/Makefile
lang/elisp/Makefile
lang/elisp/internals/Makefile
lang/elisp/primitives/Makefile
libguile/Makefile
oop/Makefile
oop/goops/Makefile

48
lang/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2000, 2006 Free Software Foundation, Inc.
## Copyright (C) 2000, 2006, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -21,4 +21,48 @@
AUTOMAKE_OPTIONS = gnu
SUBDIRS = elisp
# These should be installed and distributed.
elisp_sources = \
elisp/base.scm \
elisp/example.el \
elisp/interface.scm \
elisp/transform.scm \
elisp/variables.scm \
\
elisp/primitives/buffers.scm \
elisp/primitives/char-table.scm \
elisp/primitives/features.scm \
elisp/primitives/fns.scm \
elisp/primitives/format.scm \
elisp/primitives/guile.scm \
elisp/primitives/keymaps.scm \
elisp/primitives/lists.scm \
elisp/primitives/load.scm \
elisp/primitives/match.scm \
elisp/primitives/numbers.scm \
elisp/primitives/pure.scm \
elisp/primitives/read.scm \
elisp/primitives/signal.scm \
elisp/primitives/strings.scm \
elisp/primitives/symprop.scm \
elisp/primitives/syntax.scm \
elisp/primitives/system.scm \
elisp/primitives/time.scm \
\
elisp/internals/evaluation.scm \
elisp/internals/format.scm \
elisp/internals/fset.scm \
elisp/internals/lambda.scm \
elisp/internals/load.scm \
elisp/internals/null.scm \
elisp/internals/set.scm \
elisp/internals/signal.scm \
elisp/internals/time.scm \
elisp/internals/trace.scm
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang
nobase_subpkgdata_DATA = $(elisp_sources)
TAGS_FILES = $(nobase_subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources) elisp/ChangeLog-2008

39
lang/elisp/Makefile.am
View file

@ -1,39 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
SUBDIRS = internals primitives
# These should be installed and distributed.
elisp_sources = \
base.scm \
example.el \
interface.scm \
transform.scm \
variables.scm
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp
subpkgdata_DATA = $(elisp_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources) ChangeLog-2008

42
lang/elisp/internals/Makefile.am
View file

@ -1,42 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
elisp_sources = \
evaluation.scm \
format.scm \
fset.scm \
lambda.scm \
load.scm \
null.scm \
set.scm \
signal.scm \
time.scm \
trace.scm
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp/internals
subpkgdata_DATA = $(elisp_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources)

51
lang/elisp/primitives/Makefile.am
View file

@ -1,51 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
elisp_sources = \
buffers.scm \
char-table.scm \
features.scm \
fns.scm \
format.scm \
guile.scm \
keymaps.scm \
lists.scm \
load.scm \
match.scm \
numbers.scm \
pure.scm \
read.scm \
signal.scm \
strings.scm \
symprop.scm \
syntax.scm \
system.scm \
time.scm
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp/primitives
subpkgdata_DATA = $(elisp_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources)

4
libguile/__scm.h
View file

@ -3,7 +3,7 @@
#ifndef SCM___SCM_H
#define SCM___SCM_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -140,8 +140,6 @@
*/
#define CCLO
/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
have horrible plans for their unification. */
#undef SICP

8
libguile/debug.c
View file

@ -1,5 +1,5 @@
/* Debugging extensions for Guile
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -352,9 +352,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
break;
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
#endif
procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */
@ -385,9 +382,6 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
case scm_tcs_closures:
return SCM_ENV (proc);
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
#endif
return SCM_EOL;
default:
SCM_WRONG_TYPE_ARG (1, proc);

8
libguile/eval.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -3243,7 +3243,7 @@ scm_trampoline_0 (SCM proc)
break;
case scm_tc7_asubr:
case scm_tc7_rpsubr:
case scm_tc7_cclo:
case scm_tc7_gsubr:
case scm_tc7_pws:
trampoline = scm_call_0;
break;
@ -3369,7 +3369,7 @@ scm_trampoline_1 (SCM proc)
break;
case scm_tc7_asubr:
case scm_tc7_rpsubr:
case scm_tc7_cclo:
case scm_tc7_gsubr:
case scm_tc7_pws:
trampoline = scm_call_1;
break;
@ -3463,7 +3463,7 @@ scm_trampoline_2 (SCM proc)
else
return NULL;
break;
case scm_tc7_cclo:
case scm_tc7_gsubr:
case scm_tc7_pws:
trampoline = scm_call_2;
break;

56
libguile/eval.i.c
View file

@ -1,7 +1,7 @@
/*
* eval.i.c - actual evaluator code for GUILE
*
* Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc.
* Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -1124,14 +1124,12 @@ dispatch:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
RETURN (SCM_SMOB_APPLY_0 (proc));
case scm_tc7_cclo:
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
case scm_tc7_gsubr:
#ifdef DEVAL
debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (arg1);
debug.info->a.args = SCM_EOL;
#endif
goto evap1;
RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
@ -1245,15 +1243,12 @@ dispatch:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
case scm_tc7_cclo:
arg2 = arg1;
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
case scm_tc7_gsubr:
#ifdef DEVAL
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc;
#endif
goto evap2;
RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
@ -1350,20 +1345,11 @@ dispatch:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
cclon:
case scm_tc7_cclo:
case scm_tc7_gsubr:
#ifdef DEVAL
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
scm_cons (proc, debug.info->a.args),
SCM_EOL));
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
#else
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
scm_cons2 (proc, arg1,
scm_cons (arg2,
scm_ceval_args (x,
env,
proc))),
SCM_EOL));
RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
#endif
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@ -1492,8 +1478,8 @@ dispatch:
goto badfun;
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
SCM_CDDR (debug.info->a.args)));
case scm_tc7_cclo:
goto cclon;
case scm_tc7_gsubr:
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
debug.info->a.proc = proc;
@ -1555,8 +1541,16 @@ dispatch:
goto badfun;
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
scm_ceval_args (x, env, proc)));
case scm_tc7_cclo:
goto cclon;
case scm_tc7_gsubr:
if (scm_is_null (SCM_CDR (x)))
/* 3 arguments */
RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
SCM_UNDEFINED));
else
RETURN (scm_i_gsubr_apply_list (proc,
scm_cons2 (arg1, arg2,
scm_ceval_args (x, env,
proc))));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
@ -1867,19 +1861,15 @@ tail:
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
else
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_cclo:
case scm_tc7_gsubr:
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = scm_cons (arg1, args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
#endif
goto tail;
RETURN (scm_i_gsubr_apply_list (proc, args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL

3
libguile/evalext.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -106,7 +106,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_cclo:
case scm_tc7_pws:
case scm_tcs_subrs:
case scm_tcs_struct:

2
libguile/goops.c
View file

@ -233,7 +233,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_primitive_generic;
else
return scm_class_procedure;
case scm_tc7_cclo:
case scm_tc7_gsubr:
return scm_class_procedure;
case scm_tc7_pws:
return scm_class_procedure_with_setter;

202
libguile/gsubr.c
View file

@ -21,6 +21,8 @@
#endif
#include <stdio.h>
#include <stdarg.h>
#include "libguile/_scm.h"
#include "libguile/procprop.h"
#include "libguile/root.h"
@ -40,11 +42,10 @@
SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
SCM scm_f_gsubr_apply;
static SCM
create_gsubr (int define, const char *name,
int req, int opt, int rst, SCM (*fcn)())
unsigned int req, unsigned int opt, unsigned int rst,
SCM (*fcn) ())
{
SCM subr;
@ -52,53 +53,47 @@ create_gsubr (int define, const char *name,
{
case SCM_GSUBR_MAKTYPE(0, 0, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(1, 0, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(0, 1, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(1, 1, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(2, 0, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(3, 0, 0):
subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(0, 0, 1):
subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
goto create_subr;
break;
case SCM_GSUBR_MAKTYPE(2, 0, 1):
subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
create_subr:
if (define)
scm_define (SCM_SNAME (subr), subr);
return subr;
break;
default:
{
SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
SCM sym = SCM_SNAME (subr);
if (SCM_GSUBR_MAX < req + opt + rst)
{
fprintf (stderr,
"ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
req + opt + rst, name);
exit (1);
}
SCM_SET_GSUBR_PROC (cclo, subr);
SCM_SET_GSUBR_TYPE (cclo,
scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
if (SCM_REC_PROCNAMES_P)
scm_set_procedure_property_x (cclo, scm_sym_name, sym);
if (define)
scm_define (sym, cclo);
return cclo;
unsigned type;
type = SCM_GSUBR_MAKTYPE (req, opt, rst);
if (SCM_GSUBR_REQ (type) != req
|| SCM_GSUBR_OPT (type) != opt
|| SCM_GSUBR_REST (type) != rst)
scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
fcn);
}
}
if (define)
scm_define (SCM_SNAME (subr), subr);
return subr;
}
SCM
@ -184,26 +179,121 @@ scm_c_define_gsubr_with_generic (const char *name,
return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
}
SCM
scm_gsubr_apply (SCM args)
#define FUNC_NAME "scm_gsubr_apply"
/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
match the number of arguments of the underlying C function. */
static SCM
gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
{
SCM (*fcn) ();
unsigned int type, argc_max;
type = SCM_GSUBR_TYPE (proc);
argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
+ SCM_GSUBR_REST (type);
if (SCM_UNLIKELY (argc != argc_max))
/* We expect the exact argument count. */
scm_wrong_num_args (SCM_SNAME (proc));
fcn = SCM_SUBRF (proc);
switch (argc)
{
case 0:
return (*fcn) ();
case 1:
return (*fcn) (argv[0]);
case 2:
return (*fcn) (argv[0], argv[1]);
case 3:
return (*fcn) (argv[0], argv[1], argv[2]);
case 4:
return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
case 5:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
case 6:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
case 7:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6]);
case 8:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7]);
case 9:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8]);
case 10:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8], argv[9]);
default:
scm_misc_error ((char *) SCM_SNAME (proc),
"gsubr invocation with more than 10 arguments not implemented",
SCM_EOL);
}
return SCM_BOOL_F; /* Never reached. */
}
/* Apply PROC, a gsubr, to the given arguments. Missing optional arguments
are added, and rest arguments are turned into a list. */
SCM
scm_i_gsubr_apply (SCM proc, SCM arg, ...)
{
unsigned int type, argc, argc_max;
SCM *argv;
va_list arg_list;
type = SCM_GSUBR_TYPE (proc);
argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
va_start (arg_list, arg);
for (argc = 0;
!SCM_UNBNDP (arg) && argc < argc_max;
argc++, arg = va_arg (arg_list, SCM))
argv[argc] = arg;
if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
scm_wrong_num_args (SCM_SNAME (proc));
/* Fill in optional arguments that were not passed. */
while (argc < argc_max)
argv[argc++] = SCM_UNDEFINED;
if (SCM_GSUBR_REST (type))
{
/* Accumulate rest arguments in a list. */
SCM *rest_loc;
argv[argc_max] = SCM_EOL;
for (rest_loc = &argv[argc_max];
!SCM_UNBNDP (arg);
rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
*rest_loc = scm_cons (arg, SCM_EOL);
argc = argc_max + 1;
}
va_end (arg_list);
return gsubr_apply_raw (proc, argc, argv);
}
/* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional
arguments are added, and rest arguments are kept into a list. */
SCM
scm_i_gsubr_apply_list (SCM self, SCM args)
#define FUNC_NAME "scm_i_gsubr_apply"
{
SCM self = SCM_CAR (args);
SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self));
SCM v[SCM_GSUBR_MAX];
int typ = scm_to_int (SCM_GSUBR_TYPE (self));
unsigned int typ = SCM_GSUBR_TYPE (self);
long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
#if 0
if (n > SCM_GSUBR_MAX)
scm_misc_error (FUNC_NAME,
"Function ~S has illegal arity ~S.",
scm_list_2 (self, scm_from_int (n)));
#endif
args = SCM_CDR (args);
for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
if (scm_is_null (args))
scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
scm_wrong_num_args (SCM_SNAME (self));
v[i] = SCM_CAR(args);
args = SCM_CDR(args);
}
@ -218,19 +308,9 @@ scm_gsubr_apply (SCM args)
if (SCM_GSUBR_REST(typ))
v[i] = args;
else if (!scm_is_null (args))
scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
switch (n) {
case 2: return (*fcn)(v[0], v[1]);
case 3: return (*fcn)(v[0], v[1], v[2]);
case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
}
return SCM_BOOL_F; /* Never reached. */
scm_wrong_num_args (SCM_SNAME (self));
return gsubr_apply_raw (self, n, v);
}
#undef FUNC_NAME
@ -259,8 +339,6 @@ gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
void
scm_init_gsubr()
{
scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr,
scm_gsubr_apply);
#ifdef GSUBR_TEST
scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif

19
libguile/gsubr.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -26,19 +26,17 @@
/* Return an integer describing the arity of GSUBR, a subr of type
`scm_tc7_gsubr'. The result can be interpreted with `SCM_GSUBR_REQ ()'
and similar. */
#define SCM_GSUBR_TYPE(gsubr) (SCM_CELL_TYPE (gsubr) >> 8)
#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define SCM_GSUBR_MAX 33
#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
#define SCM_GSUBR_REST(x) ((long)(x)>>8)
#define SCM_GSUBR_MAX 10
#define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1))
#define SCM_SET_GSUBR_TYPE(cclo, type) (SCM_CCLO_SET ((cclo), 1, (type)))
#define SCM_GSUBR_PROC(cclo) (SCM_CCLO_REF ((cclo), 2))
#define SCM_SET_GSUBR_PROC(cclo, proc) (SCM_CCLO_SET ((cclo), 2, (proc)))
SCM_API SCM scm_f_gsubr_apply;
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
@ -50,7 +48,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
SCM_API SCM scm_gsubr_apply (SCM args);
SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */

27
libguile/print.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -671,30 +671,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port);
scm_putc ('>', port);
break;
#ifdef CCLO
case scm_tc7_cclo:
{
SCM proc = SCM_CCLO_SUBR (exp);
if (scm_is_eq (proc, scm_f_gsubr_apply))
{
/* Print gsubrs as primitives */
SCM name = scm_procedure_name (exp);
scm_puts ("#<primitive-procedure", port);
if (scm_is_true (name))
{
scm_putc (' ', port);
scm_puts (scm_i_symbol_chars (name), port);
}
}
else
{
scm_puts ("#<compiled-closure ", port);
scm_iprin1 (proc, port, pstate);
}
scm_putc ('>', port);
}
break;
#endif
case scm_tc7_pws:
scm_puts ("#<procedure-with-setter", port);
{

25
libguile/procprop.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -88,21 +88,14 @@ scm_i_procedure_arity (SCM proc)
{
return SCM_BOOL_F;
}
case scm_tc7_cclo:
if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply))
{
int type = scm_to_int (SCM_GSUBR_TYPE (proc));
a += SCM_GSUBR_REQ (type);
o = SCM_GSUBR_OPT (type);
r = SCM_GSUBR_REST (type);
break;
}
else
{
proc = SCM_CCLO_SUBR (proc);
a -= 1;
goto loop;
}
case scm_tc7_gsubr:
{
unsigned int type = SCM_GSUBR_TYPE (proc);
a = SCM_GSUBR_REQ (type);
o = SCM_GSUBR_OPT (type);
r = SCM_GSUBR_REST (type);
break;
}
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
goto loop;

47
libguile/procs.c
View file

@ -81,39 +81,6 @@ scm_c_define_subr_with_generic (const char *name,
}
#ifdef CCLO
SCM
scm_makcclo (SCM proc, size_t len)
{
scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits),
"compiled closure");
unsigned long i;
SCM s;
for (i = 0; i < len; ++i)
base [i] = SCM_UNPACK (SCM_UNSPECIFIED);
s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base);
SCM_SET_CCLO_SUBR (s, proc);
return s;
}
/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
(SCM proc, SCM len),
"Create a compiled closure for @var{proc}, which reserves\n"
"@var{len} objects for its usage.")
#define FUNC_NAME s_scm_make_cclo
{
return scm_makcclo (proc, scm_to_size_t (len));
}
#undef FUNC_NAME
#endif
#endif
SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a procedure.")
@ -127,9 +94,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
break;
case scm_tcs_closures:
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
#endif
case scm_tc7_pws:
return SCM_BOOL_T;
case scm_tc7_smob:
@ -167,10 +131,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
case scm_tc7_lsubr:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
#ifdef CCLO
case scm_tc7_cclo:
#endif
return SCM_BOOL_T;
case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
@ -221,12 +184,6 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
return SCM_BOOL_F;
default:
return SCM_BOOL_F;
/*
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
#endif
*/
}
}
#undef FUNC_NAME

17
libguile/procs.h
View file

@ -39,18 +39,6 @@
#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_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo)
#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), SCM_MAKE_CCLO_TAG(v)))
#define SCM_CCLO_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x))
#define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
#define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i]))
#define SCM_CCLO_SET(x, i, v) (SCM_CCLO_BASE (x) [i] = SCM_UNPACK (v))
#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0))
#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v)))
/* Closures
*/
@ -121,7 +109,6 @@ SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_makcclo (SCM proc, size_t len);
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_closure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
@ -133,10 +120,6 @@ SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
#ifdef GUILE_DEBUG
SCM_API SCM scm_make_cclo (SCM proc, SCM len);
#endif /*GUILE_DEBUG*/
#endif /* SCM_PROCS_H */
/*

5
libguile/stacks.c
View file

@ -1,5 +1,5 @@
/* Representation of stack frame debug information
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -293,9 +293,6 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
NEXT_FRAME (iframe, n, quit);
}
}
else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
/* Skip gsubr apply frames. */
continue;
else
{
NEXT_FRAME (iframe, n, quit);

5
libguile/tags.h
View file

@ -455,7 +455,7 @@ typedef unsigned long scm_t_bits;
#define scm_tc7_unused_9 79
#define scm_tc7_dsubr 61
#define scm_tc7_cclo 63
#define scm_tc7_gsubr 63
#define scm_tc7_rpsubr 69
#define scm_tc7_subr_0 85
#define scm_tc7_subr_1 87
@ -677,7 +677,8 @@ enum scm_tc8_tags
case scm_tc7_subr_1o:\
case scm_tc7_subr_2o:\
case scm_tc7_lsubr_2:\
case scm_tc7_lsubr
case scm_tc7_lsubr: \
case scm_tc7_gsubr

3
test-suite/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Software Foundation, Inc.
## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -52,6 +52,7 @@ SCM_TESTS = tests/alist.test \
tests/numbers.test \
tests/optargs.test \
tests/options.test \
tests/procprop.test \
tests/poe.test \
tests/popen.test \
tests/ports.test \

65
test-suite/tests/eval.test
View file

@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -17,6 +17,7 @@
(define-module (test-suite test-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
:use-module (ice-9 documentation))
@ -312,6 +313,68 @@
(%make-void-port "w"))
#t))))
;;;
;;; stacks
;;;
(define (stack->frames stack)
;; Return the list of frames comprising STACK.
(unfold (lambda (i)
(>= i (stack-length stack)))
(lambda (i)
(stack-ref stack i))
1+
0))
(with-test-prefix "stacks"
(with-debugging-evaluator
(pass-if "stack involving a subr"
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(fluid-ref 'not-a-fluid))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
fluid-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))
(pass-if "stack involving a gsubr"
;; The gsubr involving the error must appear exactly once on the stack.
;; This is less obvious since gsubr application may require an
;; additional `SCM_APPLY ()' call, which should not be visible to the
;; application.
(catch 'result
(lambda ()
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(hashq-ref 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
hashq-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))))
;;;
;;; letrec init evaluation
;;;

20
test-suite/tests/goops.test
View file

@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
;;;; Copyright (C) 2001,2003,2004, 2006, 2008 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 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
@ -125,6 +125,24 @@
table))))
)
(with-test-prefix "classes for built-in types"
(pass-if "subr"
(eq? (class-of fluid-ref) <procedure>))
(pass-if "gsubr"
(eq? (class-of hashq-ref) <procedure>))
(pass-if "car"
(eq? (class-of car) <procedure>))
(pass-if "string"
(eq? (class-of "foo") <string>))
(pass-if "port"
(is-a? (%make-void-port "w") <port>)))
(with-test-prefix "defining classes"
(with-test-prefix "define-class"

61
test-suite/tests/procprop.test Normal file
View file

@ -0,0 +1,61 @@
;;;; procprop.test --- Procedure properties -*- Scheme -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; Copyright (C) 2009 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(define-module (test-procpop)
:use-module (test-suite lib))
(with-test-prefix "procedure-name"
(pass-if "simple subr"
(eq? 'display (procedure-name display)))
(pass-if "gsubr"
(eq? 'hashq-ref (procedure-name hashq-ref))))
(with-test-prefix "procedure-arity"
(pass-if "simple subr"
(equal? (procedure-property display 'arity)
'(1 1 #f)))
(pass-if "gsubr"
(equal? (procedure-property hashq-ref 'arity)
'(2 1 #f)))
(pass-if "port-closed?"
(equal? (procedure-property port-closed? 'arity)
'(1 0 #f)))
(pass-if "apply"
(equal? (procedure-property apply 'arity)
'(1 0 #t)))
(pass-if "cons*"
(equal? (procedure-property cons* 'arity)
'(1 0 #t)))
(pass-if "list"
(equal? (procedure-property list 'arity)
'(0 0 #t))))
;;; Local Variables:
;;; coding: latin-1
;;; End: