summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/procprop.c25
-rw-r--r--libguile/procprop.h3
-rw-r--r--libguile/programs.c52
3 files changed, 62 insertions, 18 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 2b894977a..b7575d199 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -71,6 +71,31 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return scm_i_program_arity (proc, req, opt, rest);
}
+SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
+ (SCM proc),
+ "Return the \"minimum arity\" of a procedure.\n\n"
+ "If the procedure has only one arity, that arity is returned\n"
+ "as a list of three values: the number of required arguments,\n"
+ "the number of optional arguments, and a boolean indicating\n"
+ "whether or not the procedure takes rest arguments.\n\n"
+ "For a case-lambda procedure, the arity returned is the one\n"
+ "with the lowest minimum number of arguments, and the highest\n"
+ "maximum number of arguments.\n\n"
+ "If it was not possible to determine the arity of the procedure,\n"
+ "@code{#f} is returned.")
+#define FUNC_NAME s_scm_procedure_minimum_arity
+{
+ int req, opt, rest;
+
+ if (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
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"Return @var{obj}'s property list.")
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 50f04b261..0f1fd8e36 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010 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
@@ -34,6 +34,7 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest);
+SCM_API SCM scm_procedure_minimum_arity (SCM proc);
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/programs.c b/libguile/programs.c
index 70c399ba8..12baf68b6 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -334,21 +334,12 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
}
#undef FUNC_NAME
-/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
- can -- use program-arguments or the like. */
-static SCM sym_arglist;
-int
-scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+/* procedure-minimum-arity support. */
+static void
+parse_arity (SCM arity, int *req, int *opt, int *rest)
{
- SCM arities, x;
+ SCM x = scm_cddr (arity);
- arities = scm_program_arities (program);
- if (!scm_is_pair (arities))
- return 0;
- /* take the last arglist, it will be least specific */
- while (scm_is_pair (scm_cdr (arities)))
- arities = scm_cdr (arities);
- x = scm_cddar (arities);
if (scm_is_pair (x))
{
*req = scm_to_int (scm_car (x));
@@ -367,7 +358,37 @@ scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
}
else
*req = *opt = *rest = 0;
-
+}
+
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arities;
+
+ arities = scm_program_arities (program);
+ if (!scm_is_pair (arities))
+ return 0;
+
+ parse_arity (scm_car (arities), req, opt, rest);
+ arities = scm_cdr (arities);
+
+ for (; scm_is_pair (arities); arities = scm_cdr (arities))
+ {
+ int thisreq, thisopt, thisrest;
+
+ parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);
+
+ if (thisreq < *req
+ || (thisreq == *req
+ && ((thisrest && (!*rest || thisopt > *opt))
+ || (!thisrest && !*rest && thisopt > *opt))))
+ {
+ *req = thisreq;
+ *opt = thisopt;
+ *rest = thisrest;
+ }
+ }
+
return 1;
}
@@ -376,9 +397,6 @@ scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
void
scm_bootstrap_programs (void)
{
- /* arglist can't be snarfed, because snarfage is only loaded when (system vm
- program) is loaded. perhaps static-alloc will fix this. */
- sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_programs",
(scm_t_extension_init_func)scm_init_programs, NULL);