summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/foreign.c19
-rw-r--r--libguile/foreign.h2
-rw-r--r--libguile/gsubr.c31
-rw-r--r--libguile/gsubr.h1
-rw-r--r--libguile/programs.c71
5 files changed, 58 insertions, 66 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 936f3419c..0992ef4d3 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -792,25 +792,6 @@ get_foreign_stub_code (unsigned int nargs)
return &foreign_stub_code[nargs * 2];
}
-/* Given a foreign procedure, determine its minimum arity. */
-int
-scm_i_foreign_arity (SCM foreign, int *req, int *opt, int *rest)
-{
- const scm_t_uint32 *code = SCM_PROGRAM_CODE (foreign);
-
- if (code < foreign_stub_code)
- return 0;
- if (code > (foreign_stub_code
- + (sizeof(foreign_stub_code) / sizeof(scm_t_uint32))))
- return 0;
-
- *req = (code - foreign_stub_code) / 2;
- *opt = 0;
- *rest = 0;
-
- return 1;
-}
-
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 53f39d5c7..4c1a19f1f 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -101,8 +101,6 @@ SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign,
const union scm_vm_stack_element *argv);
-SCM_INTERNAL int scm_i_foreign_arity (SCM foreign,
- int *req, int *opt, int *rest);
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index d80e5dd42..b456b220a 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -262,37 +262,6 @@ scm_i_primitive_code_p (const scm_t_uint32 *code)
return 1;
}
-/* Given a program that is a primitive, determine its minimum arity.
- This is possible because each primitive's code is 4 32-bit words
- long, and they are laid out contiguously in an ordered pattern. */
-int
-scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
-{
- const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
- unsigned idx, nargs, base, next;
-
- if (!scm_i_primitive_code_p (code))
- return 0;
-
- idx = (code - subr_stub_code) / 4;
-
- nargs = -1;
- next = 0;
- do
- {
- base = next;
- nargs++;
- next = (nargs + 1) * (nargs + 1);
- }
- while (idx >= next);
-
- *rest = (next - idx) < (idx - base);
- *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
- *opt = *rest ? idx - (next - nargs) : idx - base;
-
- return 1;
-}
-
scm_t_uintptr
scm_i_primitive_call_ip (SCM subr)
{
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 725de2cbd..83eebc371 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -55,7 +55,6 @@
SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code);
-SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
union scm_vm_stack_element;
diff --git a/libguile/programs.c b/libguile/programs.c
index 49d4c77b1..ba8e8546b 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -22,6 +22,7 @@
#include <string.h>
#include "_scm.h"
+#include "instructions.h"
#include "modules.h"
#include "programs.h"
#include "procprop.h" /* scm_sym_name */
@@ -236,25 +237,69 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0,
}
#undef FUNC_NAME
+/* It's hacky, but it manages to cover all of the non-keyword cases. */
+static int
+try_parse_arity (SCM program, int *req, int *opt, int *rest)
+{
+ scm_t_uint32 *code = SCM_PROGRAM_CODE (program);
+ scm_t_uint32 slots, min;
+
+ switch (code[0] & 0xff) {
+ case scm_op_assert_nargs_ee:
+ slots = code[0] >> 8;
+ *req = slots - 1;
+ *opt = 0;
+ *rest = 0;
+ return 1;
+ case scm_op_assert_nargs_le:
+ slots = code[0] >> 8;
+ *req = 0;
+ *opt = slots - 1;
+ *rest = 0;
+ return 1;
+ case scm_op_bind_rest:
+ slots = code[0] >> 8;
+ *req = 0;
+ *opt = slots - 1;
+ *rest = 1;
+ return 1;
+ case scm_op_assert_nargs_ge:
+ min = code[0] >> 8;
+ switch (code[1] & 0xff) {
+ case scm_op_assert_nargs_le:
+ slots = code[1] >> 8;
+ *req = min - 1;
+ *opt = slots - 1 - *req;
+ *rest = 0;
+ return 1;
+ case scm_op_bind_rest:
+ slots = code[1] >> 8;
+ *req = min - 1;
+ *opt = slots - min;
+ *rest = 1;
+ return 1;
+ default:
+ return 0;
+ }
+ case scm_op_continuation_call:
+ case scm_op_compose_continuation:
+ *req = 0;
+ *opt = 0;
+ *rest = 1;
+ return 1;
+ default:
+ return 0;
+ }
+}
+
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
static SCM program_minimum_arity = SCM_BOOL_F;
SCM l;
- if (SCM_PRIMITIVE_P (program))
- return scm_i_primitive_arity (program, req, opt, rest);
-
- if (SCM_PROGRAM_IS_FOREIGN (program))
- return scm_i_foreign_arity (program, req, opt, rest);
-
- if (SCM_PROGRAM_IS_CONTINUATION (program)
- || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
- {
- *req = *opt = 0;
- *rest = 1;
- return 1;
- }
+ if (try_parse_arity (program, req, opt, rest))
+ return 1;
if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p)
program_minimum_arity =