add procedure_minimum_arity

* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_minimum_arity): New public
  function, will replace (procedure-property foo 'arity).

* libguile/programs.c (scm_i_program_arity): Rework to always provide
  the most permissive arity.

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.")

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

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
+/* procedure-minimum-arity support. */
-   can -- use program-arguments or the like. */
+static void
-static SCM sym_arglist;
+parse_arity (SCM arity, int *req, int *opt, int *rest)
-int
-scm_i_program_arity (SCM program, 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,6 +358,36 @@ 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);