diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-03-08 23:04:06 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-03-08 23:04:06 +0100 |
commit | f307fbcec2cbaaa95b8c861395133b519c7519cf (patch) | |
tree | 8f08599fb60cfdcd98de0f03a465e70e962112bd | |
parent | 1eefa363bd7f0db07a907c773c890b78ff6415a9 (diff) | |
parent | 6c59f901499937fe3779ef1f543646754f843679 (diff) | |
download | guile-f307fbcec2cbaaa95b8c861395133b519c7519cf.tar.gz |
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts:
libguile/gc-card.c
libguile/gc-mark.c
-rw-r--r-- | benchmark-suite/Makefile.am | 1 | ||||
-rw-r--r-- | benchmark-suite/benchmarks/subr.bm | 66 | ||||
-rw-r--r-- | configure.in | 5 | ||||
-rw-r--r-- | lang/Makefile.am | 48 | ||||
-rw-r--r-- | lang/elisp/Makefile.am | 39 | ||||
-rw-r--r-- | lang/elisp/internals/Makefile.am | 42 | ||||
-rw-r--r-- | lang/elisp/primitives/Makefile.am | 51 | ||||
-rw-r--r-- | libguile/__scm.h | 4 | ||||
-rw-r--r-- | libguile/debug.c | 8 | ||||
-rw-r--r-- | libguile/eval.c | 8 | ||||
-rw-r--r-- | libguile/eval.i.c | 56 | ||||
-rw-r--r-- | libguile/evalext.c | 3 | ||||
-rw-r--r-- | libguile/goops.c | 2 | ||||
-rw-r--r-- | libguile/gsubr.c | 198 | ||||
-rw-r--r-- | libguile/gsubr.h | 19 | ||||
-rw-r--r-- | libguile/print.c | 27 | ||||
-rw-r--r-- | libguile/procprop.c | 25 | ||||
-rw-r--r-- | libguile/procs.c | 47 | ||||
-rw-r--r-- | libguile/procs.h | 17 | ||||
-rw-r--r-- | libguile/stacks.c | 5 | ||||
-rw-r--r-- | libguile/tags.h | 5 | ||||
-rw-r--r-- | test-suite/Makefile.am | 3 | ||||
-rw-r--r-- | test-suite/tests/eval.test | 65 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 20 | ||||
-rw-r--r-- | test-suite/tests/procprop.test | 61 |
25 files changed, 455 insertions, 370 deletions
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index 5357cf050..e65e8bcb2 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -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) \ diff --git a/benchmark-suite/benchmarks/subr.bm b/benchmark-suite/benchmarks/subr.bm new file mode 100644 index 000000000..9c87a9921 --- /dev/null +++ b/benchmark-suite/benchmarks/subr.bm @@ -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)))) diff --git a/configure.in b/configure.in index 3c54bbdcd..03fd1c62b 100644 --- a/configure.in +++ b/configure.in @@ -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 diff --git a/lang/Makefile.am b/lang/Makefile.am index 5c02db63c..6dc2e2902 100644 --- a/lang/Makefile.am +++ b/lang/Makefile.am @@ -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 diff --git a/lang/elisp/Makefile.am b/lang/elisp/Makefile.am deleted file mode 100644 index 6f1e82fc5..000000000 --- a/lang/elisp/Makefile.am +++ /dev/null @@ -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 diff --git a/lang/elisp/internals/Makefile.am b/lang/elisp/internals/Makefile.am deleted file mode 100644 index 2022a90c3..000000000 --- a/lang/elisp/internals/Makefile.am +++ /dev/null @@ -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) diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am deleted file mode 100644 index b2f62a50a..000000000 --- a/lang/elisp/primitives/Makefile.am +++ /dev/null @@ -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) diff --git a/libguile/__scm.h b/libguile/__scm.h index d486b69bf..3672b1c09 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -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 diff --git a/libguile/debug.c b/libguile/debug.c index 91ba3fed8..a8ccdf8d3 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -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); diff --git a/libguile/eval.c b/libguile/eval.c index 49f1b583b..18cd3b11f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -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; diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 83878ff41..ae666d415 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -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 diff --git a/libguile/evalext.c b/libguile/evalext.c index 9bec8f410..5ca78066d 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -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: diff --git a/libguile/goops.c b/libguile/goops.c index 520b1c25d..bbeb58433 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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; diff --git a/libguile/gsubr.c b/libguile/gsubr.c index fdb70ed92..2b9a29dd1 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -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); } +/* 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_gsubr_apply (SCM args) -#define FUNC_NAME "scm_gsubr_apply" +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 diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 418564901..65680a02c 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -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 */ diff --git a/libguile/print.c b/libguile/print.c index 7906200ee..1852cf19a 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -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); { diff --git a/libguile/procprop.c b/libguile/procprop.c index 88f2c2218..db16834c5 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -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; diff --git a/libguile/procs.c b/libguile/procs.c index f99b524d0..56bb0bb14 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -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 diff --git a/libguile/procs.h b/libguile/procs.h index 354d27179..3ccf1ee33 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -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 */ /* diff --git a/libguile/stacks.c b/libguile/stacks.c index 4b97a1827..86597fa0b 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -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); diff --git a/libguile/tags.h b/libguile/tags.h index 4e0700b52..2f30369d9 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -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 diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 12884b74e..0940c13c2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -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 \ diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index b6ddb7b06..5299b0406 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 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 ;;; diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 713132a43..fa53fd216 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -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" diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test new file mode 100644 index 000000000..5ab585058 --- /dev/null +++ b/test-suite/tests/procprop.test @@ -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: |