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);