summaryrefslogtreecommitdiff
path: root/libguile/procprop.c
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1998-11-26 07:44:35 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1998-11-26 07:44:35 +0000
commit089067091c8d8b7e0e8df4345d4725d94fcca698 (patch)
treea7ccaf39a9ca51723f5b6616ca507d2a84f35e41 /libguile/procprop.c
parente845cb8486b4fba59f9bb8b051f3a5e1dd76fcb9 (diff)
downloadguile-089067091c8d8b7e0e8df4345d4725d94fcca698.tar.gz
* procprop.c (scm_i_procedure_arity): Made global; New code to
handle operators and entities. (scm_procedure_property): No need to call scm_procedure_p since scm_i_procedure_arity now does all necessary type checking. Added #include "objects.h".
Diffstat (limited to 'libguile/procprop.c')
-rw-r--r--libguile/procprop.c45
1 files changed, 40 insertions, 5 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 7bb99e963..1e87dde0d 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,20 +42,24 @@
#include <stdio.h>
#include "_scm.h"
+
#include "alist.h"
#include "eval.h"
#include "procs.h"
#include "gsubr.h"
+#include "objects.h"
#include "procprop.h"
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-static SCM
-scm_i_procedure_arity (proc)
+SCM
+scm_i_procedure_arity (SCM proc)
{
int a = 0, o = 0, r = 0;
+ if (SCM_IMP (proc))
+ return SCM_BOOL_F;
loop:
switch (SCM_TYP7 (proc))
{
@@ -88,7 +92,7 @@ scm_i_procedure_arity (proc)
if (SCM_CCLO_SUBR (proc) == scm_f_gsubr_apply)
{
int type = SCM_INUM (SCM_GSUBR_TYPE (proc));
- a = SCM_GSUBR_REQ (type);
+ a += SCM_GSUBR_REQ (type);
o = SCM_GSUBR_OPT (type);
r = SCM_GSUBR_REST (type);
break;
@@ -109,6 +113,32 @@ scm_i_procedure_arity (proc)
if (SCM_NIMP (proc))
r = 1;
break;
+ case scm_tcs_cons_gloc:
+ if (!SCM_I_OPERATORP (proc))
+ return SCM_BOOL_F;
+ {
+ SCM *p = (SCM_I_ENTITYP (proc)
+ ? &SCM_ENTITY_PROC_0 (proc)
+ : &SCM_OPERATOR_PROC_0 (proc));
+ SCM arity;
+ int i, amin = -1, amax = 0;
+ for (i = 0; i < 4; ++i)
+ if (SCM_NFALSEP (arity = scm_i_procedure_arity (p[i])))
+ {
+ if (amin < 0)
+ amin = i;
+ amax = i;
+ }
+ if (amin < 0)
+ /* no procedures in the struct! */
+ return SCM_BOOL_F;
+ a += amin;
+ o = amax - amin;
+ r = SCM_NFALSEP (arity) && SCM_NFALSEP (SCM_CADDR (arity));
+ break;
+ }
+ default:
+ return SCM_BOOL_F;
}
return SCM_LIST3 (SCM_MAKINUM (a),
SCM_MAKINUM (o),
@@ -169,10 +199,15 @@ scm_procedure_property (p, k)
SCM k;
{
SCM assoc;
+ if (k == scm_sym_arity)
+ {
+ SCM arity;
+ SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (p)),
+ p, SCM_ARG1, s_procedure_property);
+ return arity;
+ }
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
p, SCM_ARG1, s_procedure_property);
- if (k == scm_sym_arity)
- return scm_i_procedure_arity (p);
assoc = scm_sloppy_assq (k,
SCM_PROCPROPS (SCM_NIMP (p) && SCM_CLOSUREP (p)
? p