summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/eval.i.c103
-rw-r--r--libguile/goops.c24
-rw-r--r--libguile/goops.h16
-rw-r--r--libguile/vm-i-system.c15
-rw-r--r--module/oop/goops/dispatch.scm49
5 files changed, 101 insertions, 106 deletions
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 16ca837b4..d78f498d7 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1026,22 +1026,20 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCT_APPLICABLE_P (proc))
+ {
+ proc = SCM_STRUCT_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ goto evap0;
+ }
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_GENERIC_METHOD_CACHE (proc);
arg1 = SCM_EOL;
goto type_dispatch;
}
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- arg1 = proc;
- proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- goto evap1;
- }
else
goto badfun;
case scm_tc7_subr_1:
@@ -1153,7 +1151,15 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCT_APPLICABLE_P (proc))
+ {
+ proc = SCM_STRUCT_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ goto evap1;
+ }
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_GENERIC_METHOD_CACHE (proc);
#ifdef DEVAL
@@ -1163,17 +1169,6 @@ dispatch:
#endif
goto type_dispatch;
}
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- arg2 = arg1;
- arg1 = proc;
- proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
-#endif
- goto evap2;
- }
else
goto badfun;
case scm_tc7_subr_2:
@@ -1232,33 +1227,33 @@ dispatch:
RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
#endif
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_2 (arg1, arg2);
-#endif
- goto type_dispatch;
- }
- else if (SCM_STRUCT_APPLICABLE_P (proc))
+ if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
#ifdef DEVAL
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
+ debug.info->a.args,
SCM_EOL));
#else
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_ceval_args (x,
+ scm_cons (arg1,
+ scm_cons (arg2,
+ scm_ceval_args (x,
env,
proc))),
SCM_EOL));
#endif
}
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_GENERIC_METHOD_CACHE (proc);
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_list_2 (arg1, arg2);
+#endif
+ goto type_dispatch;
+ }
else
goto badfun;
case scm_tc7_subr_0:
@@ -1458,7 +1453,9 @@ dispatch:
}
#endif /* DEVAL */
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCT_APPLICABLE_P (proc))
+ goto operatorn;
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
arg1 = debug.info->a.args;
@@ -1468,8 +1465,6 @@ dispatch:
x = SCM_GENERIC_METHOD_CACHE (proc);
goto type_dispatch;
}
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- goto operatorn;
else
goto badfun;
case scm_tc7_subr_2:
@@ -1764,33 +1759,25 @@ tail:
#endif
goto tail;
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCT_APPLICABLE_P (proc))
{
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+ debug.vect[0].a.proc = proc;
#endif
- RETURN (scm_apply_generic (proc, args));
+ if (SCM_NIMP (proc))
+ goto tail;
+ else
+ goto badproc;
}
- else if (SCM_STRUCT_APPLICABLE_P (proc))
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
- /* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
- arg1 = proc;
- proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- if (SCM_NIMP (proc))
- goto tail;
- else
- goto badproc;
+ RETURN (scm_apply_generic (proc, args));
}
else
goto badproc;
diff --git a/libguile/goops.c b/libguile/goops.c
index 88408f686..4a38f397c 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1800,40 +1800,31 @@ scm_mcache_compute_cmethod (SCM cache, SCM args)
SCM
scm_apply_generic (SCM gf, SCM args)
{
- SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args);
- if (SCM_PROGRAM_P (cmethod))
- return scm_vm_apply (scm_the_vm (), cmethod, args);
- else if (scm_is_pair (cmethod))
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
- else
- return scm_apply (cmethod, args, SCM_EOL);
+ return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
}
SCM
scm_call_generic_0 (SCM gf)
{
- return scm_apply_generic (gf, SCM_EOL);
+ return scm_call_0 (SCM_STRUCT_PROCEDURE (gf));
}
SCM
scm_call_generic_1 (SCM gf, SCM a1)
{
- return scm_apply_generic (gf, scm_list_1 (a1));
+ return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1);
}
SCM
scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
{
- return scm_apply_generic (gf, scm_list_2 (a1, a2));
+ return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2);
}
SCM
scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
{
- return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
+ return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
}
SCM
@@ -1956,8 +1947,6 @@ static const char extension_gc_hint[] = "GOOPS extension";
static t_extension *extensions = 0;
-SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
-
void
scm_c_extend_primitive_generic (SCM extended, SCM extension)
{
@@ -2554,8 +2543,7 @@ create_standard_classes (void)
scm_class_class, scm_class_class, SCM_EOL);
make_stdcls (&scm_class_applicable_struct_class, "<applicable-struct-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
- /* SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class,
- SCM_VTABLE_FLAG_APPLICABLE_VTABLE); */
+ SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
diff --git a/libguile/goops.h b/libguile/goops.h
index e77bbd995..57604a035 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -63,14 +63,14 @@
/* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */
#define SCM_CLASS_CLASS_LAYOUT \
"pw" /* redefined */ \
- "ur" /* h0 */ \
- "ur" /* h1 */ \
- "ur" /* h2 */ \
- "ur" /* h3 */ \
- "ur" /* h4 */ \
- "ur" /* h5 */ \
- "ur" /* h6 */ \
- "ur" /* h7 */ \
+ "uw" /* h0 */ \
+ "uw" /* h1 */ \
+ "uw" /* h2 */ \
+ "uw" /* h3 */ \
+ "uw" /* h4 */ \
+ "uw" /* h5 */ \
+ "uw" /* h6 */ \
+ "uw" /* h7 */ \
"pw" /* direct supers */ \
"pw" /* direct slots */ \
"pw" /* direct subclasses */ \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index df8424c3e..59a5520f7 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -761,6 +761,11 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
APPLY_HOOK ();
NEXT;
}
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_call;
+ }
if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
{
SCM args = SCM_EOL;
@@ -845,6 +850,11 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
APPLY_HOOK ();
NEXT;
}
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_goto_args;
+ }
if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
{
SCM args = SCM_EOL;
@@ -937,6 +947,11 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
APPLY_HOOK ();
NEXT;
}
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+ {
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
+ goto vm_mv_call;
+ }
if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
{
SCM args = SCM_EOL;
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index ec03f599a..e08e642d4 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -72,7 +72,9 @@
(let lp ((methods methods)
(free free)
(exp `(cache-miss ,gf-sym
- ,(if rest? `(cons* ,@args rest) args))))
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
(cond
((null? methods)
(values `(,(if rest? `(,@args . rest) args)
@@ -189,38 +191,41 @@
;; get out before it blows o/~
;;
(define timer-init 10)
-(define *in-progress* (make-fluid))
-(fluid-set! *in-progress* '())
-
(define (delayed-compile gf)
(let ((timer timer-init))
(lambda args
+ (set! timer (1- timer))
(cond
- ((> timer 0)
- (set! timer (1- timer))
- (cache-dispatch gf args))
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
(else
- (let ((in-progress (fluid-ref *in-progress*)))
- (if (memq gf in-progress)
- (cache-dispatch gf args)
- (with-fluids ((*in-progress* (cons gf in-progress)))
- (let ((dispatch (compute-dispatch-procedure
- gf (slot-ref gf 'effective-methods))))
- (slot-set! gf 'procedure dispatch)
- (apply dispatch args))))))))))
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
(define (cache-dispatch gf args)
(define (map-until n f ls)
(if (or (zero? n) (null? ls))
'()
(cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
- (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
- (let lp ((cache (slot-ref gf 'effective-methods)))
- (cond ((null? cache)
- (cache-miss gf args))
- ((equal? (vector-ref (car cache) 1) types)
- (apply (vector-ref (car cache) 3) args))
- (else (lp (cdr cache)))))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
(define (cache-miss gf args)
(apply (memoize-method! gf args (slot-ref gf '%cache)) args))