summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-26 04:24:42 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-26 04:24:42 +0000
commit9de33deb2ea07bf6c93651bbd693e7484dd29b33 (patch)
treece3f42882590ee80cfb30221518a120920104a31 /libguile/eval.c
parent52235e71737b47b648b5511396073f023d08a78e (diff)
downloadguile-9de33deb2ea07bf6c93651bbd693e7484dd29b33.tar.gz
* procs.c, procs.h (scm_subr_entry): New type: Stores data
associated with subrs. (SCM_SUBRNUM, SCM_SUBR_ENTRY, SCM_SUBR_GENERIC, SCM_SUBR_PROPS, SCM_SUBR_DOC): New macros. (scm_subr_table): New variable. (scm_mark_subr_table): New function. * init.c (scm_boot_guile_1): Call scm_init_subr_table. * gc.c (scm_gc_mark): Don't mark subr names here. (scm_igc): Call scm_mark_subr_table. * snarf.h (SCM_GPROC, SCM_GPROC1): New macros. * procs.c, procs.h (scm_subr_p): New function (used internally). * gsubr.c, gsubr.h (scm_make_gsubr_with_generic): New function. * objects.c, objects.h (scm_primitive_generic): New class. * objects.h (SCM_CMETHOD_CODE, SCM_CMETHOD_ENV): New macros. * print.c (scm_iprin1): Print primitive-generics. * __scm.h (SCM_WTA_DISPATCH_1, SCM_GASSERT1, SCM_WTA_DISPATCH_2, SCM_GASSERT2): New macros. * eval.c (SCM_CEVAL, SCM_APPLY): Replace scm_wta --> SCM_WTA_DISPATCH_1 for scm_cxr's (unary floating point primitives). NOTE: This means that it is now *required* to use SCM_GPROC1 when creating float scm_cxr's (float scm_cxr's is an obscured representation that will be removed in the future anyway, so backward compatibility is no problem here). * numbers.c: Converted most numeric primitives (all but bit comparison operations and bit operations) to dispatch on generic if args don't match. * eval.c, eval.h (scm_eval_body): New function. * objects.c (scm_call_generic_0, scm_call_generic_1, scm_call_generic_2, scm_call_generic_3, scm_apply_generic): New functions. * eval.c (SCM_CEVAL): Apply the cmethod directly after having called scm_memoize_method instead of doing a second lookup. * objects.h (scm_memoize_method): Now returns the memoized cmethod. * procs.c (scm_make_subr_opt): Use scm_sysintern0 instead of scm_sysintern so that the binding connected with the subr name isn't cleared when we give set = 0.
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c48
1 files changed, 37 insertions, 11 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index c035280f0..81849a47f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -94,7 +94,7 @@ char *alloca ();
#include "eval.h"
-void (*scm_memoize_method) (SCM, SCM);
+SCM (*scm_memoize_method) (SCM, SCM);
@@ -1618,6 +1618,29 @@ scm_eval_args (l, env, proc)
return results;
}
+SCM
+scm_eval_body (SCM code, SCM env)
+{
+ SCM next;
+ again:
+ next = code;
+ while (SCM_NNULLP (next = SCM_CDR (next)))
+ {
+ if (SCM_IMP (SCM_CAR (code)))
+ {
+ if (SCM_ISYMP (SCM_CAR (code)))
+ {
+ code = scm_m_expand_body (code, env);
+ goto again;
+ }
+ }
+ else
+ SCM_XEVAL (SCM_CAR (code), env);
+ code = next;
+ }
+ return SCM_XEVALCAR (code, env);
+}
+
#endif /* !DEVAL */
@@ -2375,32 +2398,33 @@ dispatch:
do
{
int j = n;
- SCM entry = SCM_VELTS (proc)[i];
+ z = SCM_VELTS (proc)[i];
t.arg1 = arg2; /* list of arguments */
do
{
/* More arguments than specifiers => CLASS != ENV */
- if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (entry))
+ if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z))
goto next_method;
t.arg1 = SCM_CDR (t.arg1);
- entry = SCM_CDR (entry);
+ z = SCM_CDR (z);
}
while (--j && SCM_NIMP (t.arg1));
/* Fewer arguments than specifiers => CAR != ENV */
- if (!SCM_CONSP (SCM_CAR (entry)))
+ if (!SCM_CONSP (SCM_CAR (z)))
goto next_method;
+ apply_cmethod:
/* Copy the environment frame so that the dispatch form can
be used also in normal code. */
- env = EXTEND_ENV (SCM_CADR (entry), arg2, SCM_CAR (entry));
- x = SCM_CDR (entry);
+ env = EXTEND_ENV (SCM_CADR (z), arg2, SCM_CAR (z));
+ x = SCM_CDR (z);
goto cdrxbegin;
next_method:
i = (i + 1) & mask;
} while (i != end);
/* No match - call external function and try again */
- scm_memoize_method (x, arg2);
- goto type_dispatch;
+ z = scm_memoize_method (x, arg2);
+ goto apply_cmethod;
}
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
@@ -2817,7 +2841,8 @@ evapply:
}
#endif
floerr:
- scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
+ SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
}
#endif
proc = (SCM) SCM_SNAME (proc);
@@ -3468,7 +3493,8 @@ tail:
RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
#endif
floerr:
- scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
}
#endif
proc = (SCM) SCM_SNAME (proc);