[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-94-g314
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-94-g314b871 |
|
Date: |
Fri, 04 Dec 2009 18:20:53 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=314b87163eac1358923cb84e7f2c87d06aa03756
The branch, master has been updated
via 314b87163eac1358923cb84e7f2c87d06aa03756 (commit)
via f36878ba2d04427e76b85a9e91fce71f56ba7c7f (commit)
from 8a1f4f98e121c4ba90eb992203713cf493d45c71 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 314b87163eac1358923cb84e7f2c87d06aa03756
Author: Andy Wingo <address@hidden>
Date: Fri Dec 4 19:20:11 2009 +0100
eval.c closures are now applicable smobs, not tc3s
* libguile/debug.c (scm_procedure_name): Remove a SCM_CLOSUREP case and
some dead code.
(scm_procedure_module): Remove. This was introduced a few months ago
for the hygienic expander, but now it is no longer needed, as the
expander keeps track of this information itself.
* libguile/debug.h: Remove scm_procedure_module.
* libguile/eval.c: Instead of using tc3 closures, define a "boot
closure" applicable smob type, and represent closures with that. The
advantage is that after eval.scm is compiled, boot closures take up no
address space (besides a smob number) in the runtime, and require no
special cases in procedure dispatch.
* libguile/eval.h: Remove the internal functions scm_i_call_closure_0
and scm_closure_apply, and the public function scm_closure.
* libguile/gc.c (scm_storage_prehistory): No tc3_closure displacement
registration.
(scm_i_tag_name): Remove closure case, and a dead cclo case.
* libguile/vm.c (apply_foreign):
* libguile/print.c (iprin1):
* libguile/procs.c (scm_procedure_p, scm_procedure_documentation);
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of): Remove tc3_closure/tcs_closure cases.
* libguile/hash.c (scm_hasher):
* libguile/hooks.c (scm_add_hook_x): Use new scm_i_procedure_arity.
* libguile/macros.c (macro_print): Print all macros using the same code.
(scm_macro_transformer): Return any procedure, not just programs.
* libguile/procprop.h:
* libguile/procprop.c (scm_i_procedure_arity): Instead of returning a
list that the caller has to parse, have the same prototype as
scm_i_program_arity. An incompatible change, but it's an internal
function anyway.
(scm_procedure_properties, scm_set_procedure_properties)
(scm_procedure_property, scm_set_procedure_property): Remove closure
cases, and use scm_i_program_arity for arity.
* libguile/procs.h (SCM_CLOSUREP, SCM_CLOSCAR, SCM_CODE)
(SCM_CLOSURE_NUM_REQUIRED_ARGS, SCM_CLOSURE_HAS_REST_ARGS)
(SCM_CLOSURE_BODY, SCM_PROCPROPS, SCM_SETPROCPROPS, SCM_ENV)
(SCM_TOP_LEVEL): Remove these macros that pertain to boot closures
only. Only eval.c should know abut boot closures.
* libguile/procs.c (scm_closure_p): Remove this function. There is a
simple stub in deprecated.scm now.
(scm_thunk_p): Use scm_i_program_arity.
* libguile/tags.h (scm_tc3_closure): Remove. Yay, another tc3 to play
with!
(scm_tcs_closures): Remove.
* libguile/validate.h (SCM_VALIDATE_CLOSURE): Remove.
* module/ice-9/deprecated.scm (closure?): Add stub.
* module/ice-9/documentation.scm (object-documentation)
* module/ice-9/session.scm (help-doc, arity)
* module/oop/goops.scm (compute-getters-n-setters)
* module/oop/goops/describe.scm (describe)
* module/system/repl/describe.scm (display-object, display-type):
Remove calls to closure?.
commit f36878ba2d04427e76b85a9e91fce71f56ba7c7f
Author: Andy Wingo <address@hidden>
Date: Fri Dec 4 16:39:34 2009 +0100
remove cxrs
* libguile/pairs.h:
* libguile/pairs.c: Previously scm_cdadr et al were implemented as
#defines that called scm_i_chase_pairs, and the Scheme-exposed
functions themselves were cxr subrs, which got special help in the
interpreter. Since now the special help is unnecessary (because the
compiler inlines and expands calls to car, cdadr, etc), the complexity
is a loss. So just implement cdadr etc using normal functions. There's
an advantage too, in that the compiler can unroll the cxring, reducing
branches.
* libguile/tags.h (scm_tc7_cxr): Remove this tag.
(scm_tcs_subrs): Now there's only one kind of subr, yay!
* libguile/debug.c (scm_procedure_name)
* libguile/evalext.c (scm_self_evaluating_p)
* libguile/gc.c (scm_i_tag_name)
* libguile/goops.c (scm_class_of)
* libguile/hash.c (scm_hasher)
* libguile/print.c (iprin1)
* libguile/procprop.c (scm_i_procedure_arity)
* libguile/procs.c (scm_procedure_p, scm_subr_p)
(scm_make_procedure_with_setter)
* libguile/vm.c (apply_foreign): Remove cxr cases. Replace uses of
scm_tcs_subrs with scm_tc7_gsubr.
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 31 +------
libguile/debug.h | 1 -
libguile/eval.c | 128 +++++++++++++-----------
libguile/eval.h | 3 -
libguile/evalext.c | 3 +-
libguile/gc.c | 12 +--
libguile/goops.c | 5 +-
libguile/hash.c | 6 +-
libguile/hooks.c | 11 +--
libguile/macros.c | 60 +++++------
libguile/pairs.c | 211 +++++++++++++++++++++++++--------------
libguile/pairs.h | 89 +++++-----------
libguile/print.c | 20 +----
libguile/procprop.c | 136 +++++++++++---------------
libguile/procprop.h | 2 +-
libguile/procs.c | 64 ++----------
libguile/procs.h | 15 ---
libguile/tags.h | 25 +----
libguile/validate.h | 2 -
libguile/vm.c | 11 --
module/ice-9/deprecated.scm | 4 +
module/ice-9/documentation.scm | 3 +-
module/ice-9/session.scm | 16 +---
module/oop/goops.scm | 28 ++----
module/oop/goops/describe.scm | 7 +-
module/system/repl/describe.scm | 21 +---
26 files changed, 364 insertions(+), 550 deletions(-)
diff --git a/libguile/debug.c b/libguile/debug.c
index 91eef16..b220efd 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -138,19 +138,11 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
{
SCM_VALIDATE_PROC (1, proc);
switch (SCM_TYP7 (proc)) {
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
return SCM_SUBR_NAME (proc);
default:
{
SCM name = scm_procedure_property (proc, scm_sym_name);
-#if 0
- /* Source property scm_sym_procname not implemented yet... */
- SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)),
scm_sym_procname);
- if (scm_is_false (name))
- name = scm_procedure_property (proc, scm_sym_name);
-#endif
- if (scm_is_false (name) && SCM_CLOSUREP (proc))
- name = scm_reverse_lookup (SCM_ENV (proc), proc);
if (scm_is_false (name) && SCM_PROGRAM_P (proc))
name = scm_program_name (proc);
return name;
@@ -193,27 +185,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1,
0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
- (SCM proc),
- "Return the module that was current when @var{proc} was defined.")
-#define FUNC_NAME s_scm_procedure_module
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- if (scm_is_true (scm_program_p (proc)))
- return scm_program_module (proc);
- else if (SCM_CLOSUREP (proc))
- {
- SCM env = SCM_ENV (proc);
- while (scm_is_pair (env))
- env = scm_cdr (env);
- return env;
- }
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
diff --git a/libguile/debug.h b/libguile/debug.h
index 2ca0b52..6a1ee5a 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -43,7 +43,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
-SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
diff --git a/libguile/eval.c b/libguile/eval.c
index b68c0ca..4525e4f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -97,6 +97,21 @@
*/
+/* Boot closures. We only see these when compiling eval.scm, because once
+ eval.scm is in the house, closures are standard VM closures.
+ */
+
+static scm_t_bits scm_tc16_boot_closure;
+#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2
(scm_tc16_boot_closure, (code), (env))
+#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
+#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
+#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE
(x)))
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE
(x)))
+#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
+
+
+
#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
@@ -192,7 +207,7 @@ eval (SCM x, SCM env)
}
case SCM_M_LAMBDA:
- return scm_closure (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
@@ -210,11 +225,11 @@ eval (SCM x, SCM env)
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc);
@@ -229,7 +244,7 @@ eval (SCM x, SCM env)
for (; scm_is_pair (args); args = CDR (args))
new_env = scm_cons (CAR (args), new_env);
}
- x = SCM_CLOSURE_BODY (proc);
+ x = BOOT_CLOSURE_BODY (proc);
env = new_env;
goto loop;
}
@@ -242,11 +257,11 @@ eval (SCM x, SCM env)
mx = CDR (mx);
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
scm_wrong_num_args (proc);
@@ -267,7 +282,7 @@ eval (SCM x, SCM env)
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
}
- x = SCM_CLOSURE_BODY (proc);
+ x = BOOT_CLOSURE_BODY (proc);
env = new_env;
goto loop;
}
@@ -390,42 +405,6 @@ eval (SCM x, SCM env)
}
}
-SCM
-scm_closure_apply (SCM proc, SCM args)
-{
- unsigned int nargs;
- int nreq;
- SCM env;
-
- /* Args contains a list of all args. */
- {
- int ilen = scm_ilength (args);
- if (ilen < 0)
- scm_wrong_num_args (proc);
- nargs = ilen;
- }
-
- nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
- {
- if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- env = scm_cons (CAR (args), env);
- env = scm_cons (args, env);
- }
- else
- {
- for (; scm_is_pair (args); args = CDR (args), nreq--)
- env = scm_cons (CAR (args), env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
- }
- return eval (SCM_CLOSURE_BODY (proc), env);
-}
-
-
scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine
words)." },
{ 0 }
@@ -814,18 +793,6 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME
-SCM
-scm_closure (SCM code, SCM env)
-{
- SCM z;
- SCM closcar = scm_cons (code, SCM_EOL);
- z = scm_immutable_cell (SCM_UNPACK (closcar) + scm_tc3_closure,
- (scm_t_bits) env);
- scm_remember_upto_here (closcar);
- return z;
-}
-
-
static SCM
scm_c_primitive_eval (SCM exp)
{
@@ -907,6 +874,45 @@ scm_apply (SCM proc, SCM arg1, SCM args)
}
+static SCM
+boot_closure_apply (SCM closure, SCM args)
+{
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
+ SCM new_env = BOOT_CLOSURE_ENV (closure);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (closure);
+ for (; nreq; nreq--, args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ new_env = scm_cons (args, new_env);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (closure);
+ for (; scm_is_pair (args); args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ }
+ return eval (BOOT_CLOSURE_BODY (closure), new_env);
+}
+
+static int
+boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
+{
+ SCM args;
+ scm_puts ("#<boot-closure ", port);
+ scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
+ scm_putc (' ', port);
+ args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS
(closure)),
+ scm_from_locale_symbol ("_"));
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ scm_display (args, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
void
scm_init_eval ()
{
@@ -922,6 +928,10 @@ scm_init_eval ()
f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
scm_permanent_object (f_apply);
+ scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
+ scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
+ scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
+
primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
scm_c_primitive_eval);
var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
diff --git a/libguile/eval.h b/libguile/eval.h
index 62b84c1..6341f14 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -73,14 +73,11 @@ SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
-SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
-SCM_INTERNAL SCM scm_closure_apply (SCM proc, SCM args);
#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
-SCM_API SCM scm_closure (SCM code, SCM env);
SCM_API SCM scm_primitive_eval (SCM exp);
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 78b666f..27dd985 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -75,7 +75,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
case scm_tc3_cons:
switch (SCM_TYP7 (obj))
{
- case scm_tcs_closures:
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_number:
@@ -84,7 +83,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
case scm_tc7_pws:
case scm_tc7_program:
case scm_tc7_bytevector:
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/gc.c b/libguile/gc.c
index a0715f0..6a70250 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -631,7 +631,7 @@ scm_storage_prehistory ()
pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
handled in `scm_alloc_struct ()'. */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
- GC_REGISTER_DISPLACEMENT (scm_tc3_closure);
+ /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */
if (!GC_is_visible (scm_sys_protects))
@@ -754,18 +754,12 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)";
case scm_tcs_cons_nimcar:
return "cons (non-immediate car)";
- case scm_tcs_closures:
- return "closures";
case scm_tc7_pws:
return "pws";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
return "vector";
-#ifdef CCLO
- case scm_tc7_cclo:
- return "compiled closure";
-#endif
case scm_tc7_number:
switch (tag)
{
@@ -795,8 +789,8 @@ scm_i_tag_name (scm_t_bits tag)
case scm_tc7_variable:
return "variable";
break;
- case scm_tcs_subrs:
- return "subrs";
+ case scm_tc7_gsubr:
+ return "gsubr";
break;
case scm_tc7_port:
return "port";
diff --git a/libguile/goops.c b/libguile/goops.c
index 4fa5ef3..f6b18ac 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -205,8 +205,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
{
case scm_tcs_cons_nimcar:
return scm_class_pair;
- case scm_tcs_closures:
- return scm_class_procedure;
case scm_tc7_symbol:
return scm_class_symbol;
case scm_tc7_vector:
@@ -225,7 +223,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_cxr:
case scm_tc7_gsubr:
if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
@@ -293,7 +290,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc3_struct:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
- case scm_tc3_closure:
+ /* case scm_tc3_unused: */
/* Never reached */
break;
}
diff --git a/libguile/hash.c b/libguile/hash.c
index e6e38ba..e56fab0 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 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 License
@@ -169,8 +169,8 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- case scm_tcs_closures:
- case scm_tcs_subrs:
+ /* case scm_tcs_closures: */
+ case scm_tc7_gsubr:
return 262 % n;
}
}
diff --git a/libguile/hooks.c b/libguile/hooks.c
index c6541fa..d7bf018 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -203,16 +203,13 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
"procedure is not specified.")
#define FUNC_NAME s_scm_add_hook_x
{
- SCM arity, rest;
- int n_args;
+ SCM rest;
+ int n_args, p_req, p_opt, p_rest;
SCM_VALIDATE_HOOK (1, hook);
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
+ SCM_ASSERT (scm_i_procedure_arity (proc, &p_req, &p_opt, &p_rest),
proc, SCM_ARG2, FUNC_NAME);
n_args = SCM_HOOK_ARITY (hook);
- if (scm_to_int (SCM_CAR (arity)) > n_args
- || (scm_is_false (SCM_CADDR (arity))
- && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
- < n_args)))
+ if (p_req > n_args || (!p_rest && p_req + p_opt < n_args))
scm_wrong_type_arg (FUNC_NAME, 2, proc);
rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
SCM_SET_HOOK_PROCEDURES (hook,
diff --git a/libguile/macros.c b/libguile/macros.c
index d7c054e..0d71400 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -46,46 +46,42 @@ static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
SCM code = SCM_MACRO_CODE (macro);
- if (!SCM_CLOSUREP (code)
- || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- macro, port, pstate)))
- {
- scm_puts ("#<", port);
- if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
- scm_puts ("extended-", port);
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
- if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("primitive-", port);
+ /* FIXME: doesn't catch boot closures; but do we care? */
+ if (!SCM_PROGRAM_P (code))
+ scm_puts ("primitive-", port);
- if (SCM_MACRO_TYPE (macro) == 0)
- scm_puts ("syntax", port);
+ if (SCM_MACRO_TYPE (macro) == 0)
+ scm_puts ("syntax", port);
#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_MACRO_TYPE (macro) == 1)
- scm_puts ("macro", port);
+ if (SCM_MACRO_TYPE (macro) == 1)
+ scm_puts ("macro", port);
#endif
- if (SCM_MACRO_TYPE (macro) == 2)
- scm_puts ("macro!", port);
- if (SCM_MACRO_TYPE (macro) == 3)
- scm_puts ("builtin-macro!", port);
- if (SCM_MACRO_TYPE (macro) == 4)
- scm_puts ("syncase-macro", port);
-
- scm_putc (' ', port);
- scm_iprin1 (scm_macro_name (macro), port, pstate);
+ if (SCM_MACRO_TYPE (macro) == 2)
+ scm_puts ("macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 3)
+ scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
- if (SCM_MACRO_IS_EXTENDED (macro))
- {
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_2 (macro), port);
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_3 (macro), port);
- }
+ scm_putc (' ', port);
+ scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
}
+ scm_putc ('>', port);
+
return 1;
}
@@ -273,7 +269,7 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1,
0, 0,
SCM_VALIDATE_SMOB (1, m, macro);
data = SCM_PACK (SCM_SMOB_DATA (m));
- if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data))
+ if (scm_is_true (scm_procedure_p (data)))
return data;
else
return SCM_BOOL_F;
diff --git a/libguile/pairs.c b/libguile/pairs.c
index fb8b21f..68fa4c9 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -96,36 +96,6 @@ SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM
-scm_car (SCM pair)
-{
- if (!scm_is_pair (pair))
- scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
- return SCM_CAR (pair);
-}
-
-SCM
-scm_cdr (SCM pair)
-{
- if (!scm_is_pair (pair))
- scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
- return SCM_CDR (pair);
-}
-
-SCM
-scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern)
-{
- do
- {
- if (!scm_is_pair (tree))
- scm_wrong_type_arg_msg (NULL, 0, tree, "pair");
- tree = (pattern & 1) ? SCM_CAR (tree) : SCM_CDR (tree);
- pattern >>= 2;
- }
- while (pattern);
- return tree;
-}
-
SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
(SCM pair, SCM value),
"Stores @var{value} in the car field of @var{pair}. The value
returned\n"
@@ -159,59 +129,146 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
* two bits is only needed to indicate when cxr-ing is ready. This is the
* case, when all remaining pairs of bits equal 00. */
-typedef struct {
- const char *name;
- unsigned char pattern;
-} t_cxr;
-
-static const t_cxr cxrs[] =
-{
- {"cdr", 0x02}, /* 00000010 */
- {"car", 0x03}, /* 00000011 */
- {"cddr", 0x0a}, /* 00001010 */
- {"cdar", 0x0b}, /* 00001011 */
- {"cadr", 0x0e}, /* 00001110 */
- {"caar", 0x0f}, /* 00001111 */
- {"cdddr", 0x2a}, /* 00101010 */
- {"cddar", 0x2b}, /* 00101011 */
- {"cdadr", 0x2e}, /* 00101110 */
- {"cdaar", 0x2f}, /* 00101111 */
- {"caddr", 0x3a}, /* 00111010 */
- {"cadar", 0x3b}, /* 00111011 */
- {"caadr", 0x3e}, /* 00111110 */
- {"caaar", 0x3f}, /* 00111111 */
- {"cddddr", 0xaa}, /* 10101010 */
- {"cdddar", 0xab}, /* 10101011 */
- {"cddadr", 0xae}, /* 10101110 */
- {"cddaar", 0xaf}, /* 10101111 */
- {"cdaddr", 0xba}, /* 10111010 */
- {"cdadar", 0xbb}, /* 10111011 */
- {"cdaadr", 0xbe}, /* 10111110 */
- {"cdaaar", 0xbf}, /* 10111111 */
- {"cadddr", 0xea}, /* 11101010 */
- {"caddar", 0xeb}, /* 11101011 */
- {"cadadr", 0xee}, /* 11101110 */
- {"cadaar", 0xef}, /* 11101111 */
- {"caaddr", 0xfa}, /* 11111010 */
- {"caadar", 0xfb}, /* 11111011 */
- {"caaadr", 0xfe}, /* 11111110 */
- {"caaaar", 0xff}, /* 11111111 */
- {0, 0}
-};
+/* The compiler should unroll this. */
+#define CHASE_PAIRS(tree, FUNC_NAME, pattern) \
+ scm_t_uint32 pattern_var = pattern; \
+ do \
+ { \
+ if (!scm_is_pair (tree)) \
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair"); \
+ tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree); \
+ pattern_var >>= 2; \
+ } \
+ while (pattern_var); \
+ return tree
+
+
+SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
+}
+SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
+}
+SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
+}
+SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
+}
+SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
+}
+SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
+}
+SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
+}
+SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
+}
+SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
+}
+SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
+}
+SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
+}
+SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
+}
+SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
+}
+SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
+}
+SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
+}
+SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
+}
+SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
+}
+SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
+}
+SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
+}
+SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
+}
+SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
+}
+SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
+}
+SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
+}
+SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
+}
+SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
+}
+SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
+}
+SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
+}
+SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
+}
+SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
+}
+SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
+{
+ CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
+}
void
scm_init_pairs ()
{
- unsigned int subnr = 0;
-
- for (subnr = 0; cxrs[subnr].name; subnr++)
- {
- SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
- scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
- }
-
#include "libguile/pairs.x"
}
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 47bb187..81d89b5 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -112,67 +112,34 @@ SCM_API SCM scm_cdr (SCM x);
SCM_API SCM scm_set_car_x (SCM pair, SCM value);
SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);
-#define SCM_I_D_PAT 0x02 /* 00000010 */
-#define SCM_I_A_PAT 0x03 /* 00000011 */
-#define SCM_I_DD_PAT 0x0a /* 00001010 */
-#define SCM_I_DA_PAT 0x0b /* 00001011 */
-#define SCM_I_AD_PAT 0x0e /* 00001110 */
-#define SCM_I_AA_PAT 0x0f /* 00001111 */
-#define SCM_I_DDD_PAT 0x2a /* 00101010 */
-#define SCM_I_DDA_PAT 0x2b /* 00101011 */
-#define SCM_I_DAD_PAT 0x2e /* 00101110 */
-#define SCM_I_DAA_PAT 0x2f /* 00101111 */
-#define SCM_I_ADD_PAT 0x3a /* 00111010 */
-#define SCM_I_ADA_PAT 0x3b /* 00111011 */
-#define SCM_I_AAD_PAT 0x3e /* 00111110 */
-#define SCM_I_AAA_PAT 0x3f /* 00111111 */
-#define SCM_I_DDDD_PAT 0xaa /* 10101010 */
-#define SCM_I_DDDA_PAT 0xab /* 10101011 */
-#define SCM_I_DDAD_PAT 0xae /* 10101110 */
-#define SCM_I_DDAA_PAT 0xaf /* 10101111 */
-#define SCM_I_DADD_PAT 0xba /* 10111010 */
-#define SCM_I_DADA_PAT 0xbb /* 10111011 */
-#define SCM_I_DAAD_PAT 0xbe /* 10111110 */
-#define SCM_I_DAAA_PAT 0xbf /* 10111111 */
-#define SCM_I_ADDD_PAT 0xea /* 11101010 */
-#define SCM_I_ADDA_PAT 0xeb /* 11101011 */
-#define SCM_I_ADAD_PAT 0xee /* 11101110 */
-#define SCM_I_ADAA_PAT 0xef /* 11101111 */
-#define SCM_I_AADD_PAT 0xfa /* 11111010 */
-#define SCM_I_AADA_PAT 0xfb /* 11111011 */
-#define SCM_I_AAAD_PAT 0xfe /* 11111110 */
-#define SCM_I_AAAA_PAT 0xff /* 11111111 */
-
-SCM_API SCM scm_i_chase_pairs (SCM x, scm_t_uint32 pattern);
-
-#define scm_cddr(x) scm_i_chase_pairs ((x), SCM_I_DD_PAT)
-#define scm_cdar(x) scm_i_chase_pairs ((x), SCM_I_DA_PAT)
-#define scm_cadr(x) scm_i_chase_pairs ((x), SCM_I_AD_PAT)
-#define scm_caar(x) scm_i_chase_pairs ((x), SCM_I_AA_PAT)
-#define scm_cdddr(x) scm_i_chase_pairs ((x), SCM_I_DDD_PAT)
-#define scm_cddar(x) scm_i_chase_pairs ((x), SCM_I_DDA_PAT)
-#define scm_cdadr(x) scm_i_chase_pairs ((x), SCM_I_DAD_PAT)
-#define scm_cdaar(x) scm_i_chase_pairs ((x), SCM_I_DAA_PAT)
-#define scm_caddr(x) scm_i_chase_pairs ((x), SCM_I_ADD_PAT)
-#define scm_cadar(x) scm_i_chase_pairs ((x), SCM_I_ADA_PAT)
-#define scm_caadr(x) scm_i_chase_pairs ((x), SCM_I_AAD_PAT)
-#define scm_caaar(x) scm_i_chase_pairs ((x), SCM_I_AAA_PAT)
-#define scm_cddddr(x) scm_i_chase_pairs ((x), SCM_I_DDDD_PAT)
-#define scm_cdddar(x) scm_i_chase_pairs ((x), SCM_I_DDDA_PAT)
-#define scm_cddadr(x) scm_i_chase_pairs ((x), SCM_I_DDAD_PAT)
-#define scm_cddaar(x) scm_i_chase_pairs ((x), SCM_I_DDAA_PAT)
-#define scm_cdaddr(x) scm_i_chase_pairs ((x), SCM_I_DADD_PAT)
-#define scm_cdadar(x) scm_i_chase_pairs ((x), SCM_I_DADA_PAT)
-#define scm_cdaadr(x) scm_i_chase_pairs ((x), SCM_I_DAAD_PAT)
-#define scm_cdaaar(x) scm_i_chase_pairs ((x), SCM_I_DAAA_PAT)
-#define scm_cadddr(x) scm_i_chase_pairs ((x), SCM_I_ADDD_PAT)
-#define scm_caddar(x) scm_i_chase_pairs ((x), SCM_I_ADDA_PAT)
-#define scm_cadadr(x) scm_i_chase_pairs ((x), SCM_I_ADAD_PAT)
-#define scm_cadaar(x) scm_i_chase_pairs ((x), SCM_I_ADAA_PAT)
-#define scm_caaddr(x) scm_i_chase_pairs ((x), SCM_I_AADD_PAT)
-#define scm_caadar(x) scm_i_chase_pairs ((x), SCM_I_AADA_PAT)
-#define scm_caaadr(x) scm_i_chase_pairs ((x), SCM_I_AAAD_PAT)
-#define scm_caaaar(x) scm_i_chase_pairs ((x), SCM_I_AAAA_PAT)
+SCM_API SCM scm_cddr (SCM x);
+SCM_API SCM scm_cdar (SCM x);
+SCM_API SCM scm_cadr (SCM x);
+SCM_API SCM scm_caar (SCM x);
+SCM_API SCM scm_cdddr (SCM x);
+SCM_API SCM scm_cddar (SCM x);
+SCM_API SCM scm_cdadr (SCM x);
+SCM_API SCM scm_cdaar (SCM x);
+SCM_API SCM scm_caddr (SCM x);
+SCM_API SCM scm_cadar (SCM x);
+SCM_API SCM scm_caadr (SCM x);
+SCM_API SCM scm_caaar (SCM x);
+SCM_API SCM scm_cddddr (SCM x);
+SCM_API SCM scm_cdddar (SCM x);
+SCM_API SCM scm_cddadr (SCM x);
+SCM_API SCM scm_cddaar (SCM x);
+SCM_API SCM scm_cdaddr (SCM x);
+SCM_API SCM scm_cdadar (SCM x);
+SCM_API SCM scm_cdaadr (SCM x);
+SCM_API SCM scm_cdaaar (SCM x);
+SCM_API SCM scm_cadddr (SCM x);
+SCM_API SCM scm_caddar (SCM x);
+SCM_API SCM scm_cadadr (SCM x);
+SCM_API SCM scm_cadaar (SCM x);
+SCM_API SCM scm_caaddr (SCM x);
+SCM_API SCM scm_caadar (SCM x);
+SCM_API SCM scm_caaadr (SCM x);
+SCM_API SCM scm_caaaar (SCM x);
SCM_INTERNAL void scm_init_pairs (void);
diff --git a/libguile/print.c b/libguile/print.c
index 3069edc..a268a0c 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -428,7 +428,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
switch (SCM_ITAG3 (exp))
{
- case scm_tc3_closure:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
/* These tc3 tags should never occur in an immediate value. They are
@@ -561,22 +560,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
circref:
print_circref (port, pstate, exp);
break;
- case scm_tcs_closures:
- if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- exp, port, pstate)))
- {
- scm_puts ("#<procedure", port);
- scm_putc (' ', port);
- scm_iprin1 (scm_procedure_name (exp), port, pstate);
- scm_putc (' ', port);
- scm_iprin1
- (scm_cons (SCM_I_MAKINUM (SCM_CLOSURE_NUM_REQUIRED_ARGS (exp)),
- scm_from_bool (SCM_CLOSURE_HAS_REST_ARGS (exp))),
- port, pstate);
- scm_putc ('>', port);
- }
- break;
case scm_tc7_number:
switch SCM_TYP16 (exp) {
case scm_tc16_big:
@@ -782,7 +765,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
EXIT_NESTED_DATA (pstate);
break;
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
{
SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
scm_puts (SCM_SUBR_GENERIC (exp)
@@ -820,6 +803,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
break;
default:
+ /* case scm_tcs_closures: */
punk:
scm_ipruk ("type", exp, port);
}
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 96b82ae..c452c28 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -41,68 +41,49 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-static SCM non_closure_props;
-static scm_i_pthread_mutex_t non_closure_props_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM props;
+static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM
-scm_i_procedure_arity (SCM proc)
+int
+scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
- int a = 0, o = 0, r = 0;
if (SCM_IMP (proc))
- return SCM_BOOL_F;
+ return 0;
loop:
switch (SCM_TYP7 (proc))
{
- case scm_tc7_cxr:
- a += 1;
- break;
case scm_tc7_program:
- if (scm_i_program_arity (proc, &a, &o, &r))
- break;
- else
- return SCM_BOOL_F;
+ return scm_i_program_arity (proc, req, opt, rest);
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
{
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- a += SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
else
- {
- return SCM_BOOL_F;
- }
+ return 0;
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;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
goto loop;
- case scm_tcs_closures:
- a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0;
- break;
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- r = 1;
- break;
- }
- else if (!SCM_STRUCT_APPLICABLE_P (proc))
- return SCM_BOOL_F;
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
proc = SCM_STRUCT_PROCEDURE (proc);
goto loop;
default:
- return SCM_BOOL_F;
+ return 0;
}
- return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
@@ -114,18 +95,22 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
- SCM props;
+ SCM ret;
+ int req, opt, rest;
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+
+ return scm_acons (scm_sym_arity,
+ scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest)),
+ ret);
}
#undef FUNC_NAME
@@ -136,14 +121,10 @@ SCM_DEFINE (scm_set_procedure_properties_x,
"set-procedure-properties!", 2, 0, 0
{
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc, alist);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc, alist);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc, alist);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -157,19 +138,22 @@ SCM_DEFINE (scm_procedure_property, "procedure-property",
2, 0, 0,
if (scm_is_eq (key, scm_sym_arity))
/* avoid a cons in this case */
- return scm_i_procedure_arity (proc);
+ {
+ int req, opt, rest;
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+ return scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest));
+ }
else
{
- SCM props;
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_assq_ref (props, key);
+ SCM ret;
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ return scm_assq_ref (ret, key);
}
}
#undef FUNC_NAME
@@ -185,18 +169,12 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc,
- scm_assq_set_x (SCM_PROCPROPS (proc), key, val));
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc,
- scm_assq_set_x (scm_hashq_ref (non_closure_props, proc,
- SCM_EOL),
- key, val));
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc,
+ scm_assq_set_x (scm_hashq_ref (props, proc,
+ SCM_EOL),
+ key, val));
+ scm_i_pthread_mutex_unlock (&props_lock);
return SCM_UNSPECIFIED;
}
@@ -208,7 +186,7 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
void
scm_init_procprop ()
{
- non_closure_props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 7a11314..50f04b2 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -33,7 +33,7 @@ SCM_API SCM scm_sym_system_procedure;
-SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
+SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
diff --git a/libguile/procs.c b/libguile/procs.c
index 1d1be06..71d50bd 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -100,8 +100,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
- case scm_tcs_closures:
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
case scm_tc7_pws:
case scm_tc7_program:
return SCM_BOOL_T;
@@ -114,45 +113,14 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a closure.")
-#define FUNC_NAME s_scm_closure_p
-{
- return scm_from_bool (SCM_CLOSUREP (obj));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p
{
- if (SCM_NIMP (obj))
- {
- again:
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
- case scm_tc7_gsubr:
- return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
- case scm_tc7_program:
- {
- int a, o, r;
- if (scm_i_program_arity (obj, &a, &o, &r))
- return scm_from_bool (a == 0);
- else
- return SCM_BOOL_F;
- }
- case scm_tc7_pws:
- obj = SCM_PROCEDURE (obj);
- goto again;
- default:
- return SCM_BOOL_F;
- }
- }
- return SCM_BOOL_F;
+ int req, opt, rest;
+ return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest)
+ && req == 0);
}
#undef FUNC_NAME
@@ -163,7 +131,7 @@ scm_subr_p (SCM obj)
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
{
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
return 1;
default:
;
@@ -181,25 +149,11 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
"documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
- SCM code;
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
- proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_program_properties (proc), sym_documentation);
- switch (SCM_TYP7 (proc))
- {
- case scm_tcs_closures:
- code = SCM_CLOSURE_BODY (proc);
- if (scm_is_null (SCM_CDR (code)))
- return SCM_BOOL_F;
- code = SCM_CAR (code);
- if (scm_is_string (code))
- return code;
- else
- return SCM_BOOL_F;
- default:
- return SCM_BOOL_F;
- }
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -232,7 +186,7 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
switch (SCM_TYP7 (procedure)) {
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
name = SCM_SUBR_NAME (procedure);
break;
default:
diff --git a/libguile/procs.h b/libguile/procs.h
index 369d9e1..cb19e4c 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -47,20 +47,6 @@
-/* Closures
- */
-
-#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
-#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
-#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
-#define SCM_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (SCM_CAR (SCM_CODE (x)))
-#define SCM_CLOSURE_HAS_REST_ARGS(x) scm_is_true (SCM_CADR (SCM_CODE (x)))
-#define SCM_CLOSURE_BODY(x) SCM_CDDR (SCM_CODE (x))
-#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
-#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
-#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
-#define SCM_TOP_LEVEL(ENV) (scm_is_null (ENV) || (scm_is_true
(scm_procedure_p (SCM_CAR (ENV)))))
-
/* Procedure-with-setter
Four representations for procedure-with-setters were
@@ -122,7 +108,6 @@ 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_procedure_p (SCM obj);
-SCM_API SCM scm_closure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
diff --git a/libguile/tags.h b/libguile/tags.h
index aee2d58..915f6f3 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -386,7 +386,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc3_cons 0
#define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0)
-#define scm_tc3_closure 3
+#define scm_tc3_unused 3
#define scm_tc3_imm24 4
#define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4)
@@ -431,7 +431,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_program 79
#define scm_tc7_unused_9 85
#define scm_tc7_unused_10 87
-#define scm_tc7_cxr 93
+#define scm_tc7_unused_20 93
#define scm_tc7_unused_11 95
#define scm_tc7_unused_12 101
#define scm_tc7_unused_18 103
@@ -652,30 +652,9 @@ enum scm_tc8_tags
case scm_tc3_struct + 112:\
case scm_tc3_struct + 120
-/* For closures
- */
-#define scm_tcs_closures \
- scm_tc3_closure + 0:\
- case scm_tc3_closure + 8:\
- case scm_tc3_closure + 16:\
- case scm_tc3_closure + 24:\
- case scm_tc3_closure + 32:\
- case scm_tc3_closure + 40:\
- case scm_tc3_closure + 48:\
- case scm_tc3_closure + 56:\
- case scm_tc3_closure + 64:\
- case scm_tc3_closure + 72:\
- case scm_tc3_closure + 80:\
- case scm_tc3_closure + 88:\
- case scm_tc3_closure + 96:\
- case scm_tc3_closure + 104:\
- case scm_tc3_closure + 112:\
- case scm_tc3_closure + 120
-
/* For subrs
*/
#define scm_tcs_subrs \
- scm_tc7_cxr:\
case scm_tc7_gsubr
diff --git a/libguile/validate.h b/libguile/validate.h
index be4ed48..0945658 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -296,8 +296,6 @@
#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj,
MEMOIZED_P, "memoized code")
-#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj,
CLOSUREP, "closure")
-
#define SCM_VALIDATE_PROC(pos, proc) \
do { \
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
diff --git a/libguile/vm.c b/libguile/vm.c
index ca6d747..37f74e5 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -269,17 +269,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int
headroom)
switch (SCM_TYP7 (proc))
{
- case scm_tcs_closures:
- /* FIXME: pre-boot closures should be smobs */
- {
- SCM arglist = SCM_EOL;
- while (nargs--)
- arglist = scm_cons (args[nargs], arglist);
- return scm_closure_apply (proc, arglist);
- }
- case scm_tc7_cxr:
- if (nargs != 1) scm_wrong_num_args (proc);
- return scm_i_chase_pairs (args[0], (scm_t_bits) SCM_SUBRF (proc));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badproc;
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 3176ebc..0d632b2 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -224,3 +224,7 @@
(define ($sinh z) (sinh z))
(define ($cosh z) (cosh z))
(define ($tanh z) (tanh z))
+(define (closure? x)
+ (issue-deprecation-warning
+ "`closure?' is deprecated. Use `procedure?' instead.")
+ (procedure? x))
diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm
index bbd6713..37c3bf7 100644
--- a/module/ice-9/documentation.scm
+++ b/module/ice-9/documentation.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 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
@@ -201,7 +201,6 @@ OBJECT can be a procedure, macro or any object that has its
(and (macro? object)
(object-documentation (macro-transformer object)))
(and (procedure? object)
- (not (closure? object))
(procedure-name object)
(let ((docstring (search-documentation-files
(procedure-name object))))
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 70708c3..f6cad46 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -163,10 +163,8 @@ You don't seem to have regular expressions installed.\n")
(cons (list module
name
(try-value-help name object)
- (cond ((closure? object)
+ (cond ((procedure? object)
"a procedure")
- ((procedure? object)
- "a primitive procedure")
(else
"an object")))
data))
@@ -498,17 +496,7 @@ It is an image under the mapping EXTRACT."
(= (car arity) 1)
(<= (cadr arity) 1))
(display " argument")
- (display " arguments"))
- (if (closure? obj)
- (let ((formals (cadr (procedure-source obj))))
- (cond
- ((pair? formals)
- (display ": ")
- (display-arg-list formals))
- (else
- (display " in `")
- (display formals)
- (display #\'))))))))
+ (display " arguments")))))
(display ".\n"))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 0195036..50d9828 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1161,20 +1161,15 @@
;;; compute-getters-n-setters
;;;
-;; FIXME!!!
-(define (make-thunk thunk)
- (lambda () (thunk)))
-
(define (compute-getters-n-setters class slots)
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
(and thunk
- (cond ((not (thunk? thunk))
- (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
- name class thunk))
- ((closure? thunk) thunk)
- (else (make-thunk thunk)))))
+ (if (thunk? thunk)
+ thunk
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
@@ -1187,18 +1182,11 @@
(else
(let ((get (car l))
(set (cadr l)))
- ;; note that we allow non-closures; we only check arity on
- ;; the closures, though, because we inline their dispatch
- ;; in %get-slot-value / %set-slot-value.
- (if (or (not (procedure? get))
- (and (closure? get)
- (not (= (car (procedure-property get 'arity)) 1))))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? get))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (if (or (not (procedure? set))
- (and (closure? set)
- (not (= (car (procedure-property set 'arity)) 2))))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? set))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
(map (lambda (s)
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index fa7bc46..86b2d2c 100644
--- a/module/oop/goops/describe.scm
+++ b/module/oop/goops/describe.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation,
Inc.
+;;;; Copyright (C) 1998, 1999, 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
@@ -67,10 +67,7 @@
(display x))
(display " is ")
(display (if name #\a "an anonymous"))
- (display (cond ((closure? x) " procedure")
- ((not (struct? x)) " primitive procedure")
- ((entity? x) " entity")
- (else " operator")))
+ (display " procedure")
(display " with ")
(arity x)))
diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm
index 590d223..7077f37 100644
--- a/module/system/repl/describe.scm
+++ b/module/system/repl/describe.scm
@@ -1,6 +1,6 @@
;;; Describe objects
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -200,17 +200,7 @@
(define-method (display-object (obj <procedure>))
(cond
- ((closure? obj)
- ;; Construct output from the source.
- (display "(")
- (display (procedure-name obj))
- (let ((args (cadr (procedure-source obj))))
- (cond ((null? args) (display ")"))
- ((pair? args)
- (let ((str (with-output-to-string (lambda () (display args)))))
- (format #t " ~a" (string-upcase! (substring str 1)))))
- (else
- (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ ;; FIXME: VM programs, ...
(else
;; Primitive procedure. Let's lookup the dictionary.
(and-let* ((entry (lookup-procedure obj)))
@@ -240,10 +230,8 @@
(define-method (display-type (obj <procedure>))
(cond
((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
- ((closure? obj) (display-class <procedure> "a procedure"))
((procedure-with-setter? obj)
(display-class <procedure-with-setter> "a procedure with setter"))
- ((not (struct? obj)) (display "a primitive procedure"))
(else (display-class <procedure> "a procedure")))
(display ".\n"))
@@ -252,9 +240,8 @@
(display-file (entry-file entry))))
(define-method (display-documentation (obj <procedure>))
- (cond ((cond ((closure? obj) (procedure-documentation obj))
- ((lookup-procedure obj) => entry-text)
- (else #f))
+ (cond ((or (procedure-documentation obj)
+ (and=> (lookup-procedure obj) entry-text))
=> format-documentation)
(else (next-method))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-94-g314b871,
Andy Wingo <=