mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
* goops.scm (upgrade-generic-with-setter,
compute-new-list-of-methods): Use methods slot directly instead of generic-function-methods. (upgrade-generic-with-setter): Handle <extended-generic>:s. (define-extended-generic): New syntax. (make-extended-generic): New function. * goops.c, goops.h (scm_class_extended_generic_with_setter): New class. (scm_compute_applicable_methods): Use scm_generic_function_methods. * goops.c (scm_generic_function_methods): Support extended generic functions.
This commit is contained in:
Mikael Djurfeldt
parent
717bde134d
commit
bbf8d52350
5 changed files with 164 additions and 42 deletions
|
|
@ -1,3 +1,12 @@
|
|||
2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* goops.c, goops.h (scm_class_extended_generic_with_setter): New
|
||||
class.
|
||||
(scm_compute_applicable_methods): Use scm_generic_function_methods.
|
||||
|
||||
* goops.c (scm_generic_function_methods): Support extended
|
||||
generic functions.
|
||||
|
||||
2002-12-29 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* eval.c (unmemocopy): Bugfix: scm_sym_delay --> scm_sym_future.
|
||||
|
|
|
|||
111
libguile/goops.c
111
libguile/goops.c
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -137,7 +137,9 @@ static SCM scm_goops_lookup_closure;
|
|||
/* Some classes are defined in libguile/objects.c. */
|
||||
SCM scm_class_top, scm_class_object, scm_class_class;
|
||||
SCM scm_class_entity, scm_class_entity_with_setter;
|
||||
SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method;
|
||||
SCM scm_class_generic, scm_class_generic_with_setter;
|
||||
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
|
||||
SCM scm_class_method;
|
||||
SCM scm_class_simple_method, scm_class_accessor;
|
||||
SCM scm_class_procedure_class;
|
||||
SCM scm_class_operator_class, scm_class_operator_with_setter_class;
|
||||
|
|
@ -166,22 +168,11 @@ static SCM scm_sys_goops_loaded (void);
|
|||
*
|
||||
* Compute-cpl
|
||||
*
|
||||
* This version doesn't handle multiple-inheritance. It serves only for
|
||||
* booting classes and will be overloaded in Scheme
|
||||
* This version doesn't fully handle multiple-inheritance. It serves
|
||||
* only for booting classes and will be overloaded in Scheme
|
||||
*
|
||||
******************************************************************************/
|
||||
|
||||
#if 0
|
||||
static SCM
|
||||
compute_cpl (SCM supers, SCM res)
|
||||
{
|
||||
return (SCM_NULLP (supers)
|
||||
? scm_reverse (res)
|
||||
: compute_cpl (SCM_SLOT (SCM_CAR (supers), scm_si_direct_supers),
|
||||
scm_cons (SCM_CAR (supers), res)));
|
||||
}
|
||||
#endif
|
||||
|
||||
static SCM
|
||||
map (SCM (*proc) (SCM), SCM ls)
|
||||
{
|
||||
|
|
@ -325,7 +316,9 @@ compute_getters_n_setters (SCM slots)
|
|||
{
|
||||
init = scm_get_keyword (k_init_value, options, 0);
|
||||
if (init)
|
||||
init = scm_closure (scm_list_2 (SCM_EOL, init), SCM_EOL);
|
||||
init = scm_closure (scm_list_2 (SCM_EOL,
|
||||
scm_list_2 (scm_sym_quote, init)),
|
||||
SCM_EOL);
|
||||
else
|
||||
init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
|
||||
}
|
||||
|
|
@ -620,9 +613,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
|
|||
z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
|
||||
|
||||
/* Initialize its slots */
|
||||
#if 0
|
||||
cpl = compute_cpl (dsupers, scm_list_1 (z));
|
||||
#endif
|
||||
SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
|
||||
cpl = compute_cpl (z);
|
||||
slots = build_slots_list (maplist (dslots), cpl);
|
||||
|
|
@ -900,17 +890,54 @@ SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_SYMBOL (sym_methods, "methods");
|
||||
SCM_SYMBOL (sym_extended_by, "extended-by");
|
||||
SCM_SYMBOL (sym_extends, "extends");
|
||||
|
||||
static
|
||||
SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
|
||||
{
|
||||
SCM gfs = scm_slot_ref (gf, sym_extended_by);
|
||||
method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
|
||||
while (!SCM_NULLP (gfs))
|
||||
{
|
||||
method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
|
||||
gfs = SCM_CDR (gfs);
|
||||
}
|
||||
return method_lists;
|
||||
}
|
||||
|
||||
static
|
||||
SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
|
||||
{
|
||||
if (SCM_IS_A_P (gf, scm_class_extended_generic))
|
||||
{
|
||||
SCM gfs = scm_slot_ref (gf, sym_extends);
|
||||
while (!SCM_NULLP (gfs))
|
||||
{
|
||||
SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
|
||||
method_lists = fold_upward_gf_methods (scm_cons (methods,
|
||||
method_lists),
|
||||
SCM_CAR (gfs));
|
||||
gfs = SCM_CDR (gfs);
|
||||
}
|
||||
}
|
||||
return method_lists;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return the methods of the generic function @var{obj}.")
|
||||
#define FUNC_NAME s_scm_generic_function_methods
|
||||
{
|
||||
SCM methods;
|
||||
SCM_VALIDATE_GENERIC (1, obj);
|
||||
return scm_slot_ref (obj, scm_str2symbol ("methods"));
|
||||
methods = fold_upward_gf_methods (SCM_EOL, obj);
|
||||
methods = fold_downward_gf_methods (methods, obj);
|
||||
return scm_append (methods);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return the generic function for the method @var{obj}.")
|
||||
|
|
@ -1757,7 +1784,7 @@ sort_applicable_methods (SCM method_list, long size, SCM const *targs)
|
|||
We're not allocating elements in this routine, so this should
|
||||
pose no problem.
|
||||
*/
|
||||
v = SCM_WRITABLE_VELTS (vector);
|
||||
v = SCM_WRITABLE_VELTS (vector);
|
||||
}
|
||||
|
||||
/* Use a simple shell sort since it is generally faster than qsort on
|
||||
|
|
@ -1829,7 +1856,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
|
|||
*p++ = scm_class_of (SCM_CAR (args));
|
||||
|
||||
/* Build a list of all applicable methods */
|
||||
for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l))
|
||||
for (l = scm_generic_function_methods (gf); !SCM_NULLP (l); l = SCM_CDR (l))
|
||||
{
|
||||
fl = SPEC_OF (SCM_CAR (l));
|
||||
/* Only accept accessors which match exactly in first arg. */
|
||||
|
|
@ -2022,10 +2049,11 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
|
|||
if (class == scm_class_generic || class == scm_class_generic_with_setter)
|
||||
{
|
||||
z = scm_make_struct (class, SCM_INUM0,
|
||||
scm_list_4 (SCM_EOL,
|
||||
scm_list_5 (SCM_EOL,
|
||||
SCM_INUM0,
|
||||
SCM_BOOL_F,
|
||||
scm_make_mutex ()));
|
||||
scm_make_mutex (),
|
||||
SCM_EOL));
|
||||
scm_set_procedure_property_x (z, scm_sym_name,
|
||||
scm_get_keyword (k_name,
|
||||
args,
|
||||
|
|
@ -2174,7 +2202,7 @@ create_standard_classes (void)
|
|||
k_init_keyword,
|
||||
k_slot_definition));
|
||||
SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
|
||||
SCM gf_slots = scm_list_4 (scm_str2symbol ("methods"),
|
||||
SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
|
||||
scm_list_3 (scm_str2symbol ("n-specialized"),
|
||||
k_init_value,
|
||||
SCM_INUM0),
|
||||
|
|
@ -2185,8 +2213,13 @@ create_standard_classes (void)
|
|||
k_init_thunk,
|
||||
scm_closure (scm_list_2 (SCM_EOL,
|
||||
mutex_slot),
|
||||
SCM_EOL)));
|
||||
|
||||
SCM_EOL)),
|
||||
scm_list_3 (scm_str2symbol ("extended-by"),
|
||||
k_init_value,
|
||||
SCM_EOL));
|
||||
SCM egf_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
|
||||
k_init_value,
|
||||
SCM_EOL));
|
||||
/* Foreign class slot classes */
|
||||
make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
|
||||
scm_class_class, scm_class_top, SCM_EOL);
|
||||
|
|
@ -2262,20 +2295,24 @@ create_standard_classes (void)
|
|||
make_stdcls (&scm_class_generic, "<generic>",
|
||||
scm_class_entity_class, scm_class_entity, gf_slots);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
|
||||
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
|
||||
scm_class_entity_class,
|
||||
scm_list_1 (scm_class_generic),
|
||||
egf_slots);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
|
||||
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
|
||||
scm_class_entity_class,
|
||||
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
|
||||
SCM_EOL);
|
||||
#if 0
|
||||
/* Patch cpl since compute_cpl doesn't support multiple inheritance. */
|
||||
SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,
|
||||
scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,
|
||||
scm_class_generic),
|
||||
SCM_SLOT (scm_class_entity_with_setter,
|
||||
scm_si_cpl),
|
||||
SCM_EOL)));
|
||||
#endif
|
||||
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
|
||||
make_stdcls (&scm_class_extended_generic_with_setter,
|
||||
"<extended-generic-with-setter>",
|
||||
scm_class_entity_class,
|
||||
scm_list_2 (scm_class_extended_generic,
|
||||
scm_class_entity_with_setter),
|
||||
SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
|
||||
SCM_CLASSF_PURE_GENERIC);
|
||||
|
||||
/* Primitive types classes */
|
||||
make_stdcls (&scm_class_boolean, "<boolean>",
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_GOOPS_H
|
||||
#define SCM_GOOPS_H
|
||||
|
||||
/* Copyright (C) 1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -188,6 +188,8 @@ SCM_API SCM scm_class_entity;
|
|||
SCM_API SCM scm_class_entity_with_setter;
|
||||
SCM_API SCM scm_class_generic;
|
||||
SCM_API SCM scm_class_generic_with_setter;
|
||||
SCM_API SCM scm_class_extended_generic;
|
||||
SCM_API SCM scm_class_extended_generic_with_setter;
|
||||
SCM_API SCM scm_class_method;
|
||||
SCM_API SCM scm_class_simple_method;
|
||||
SCM_API SCM scm_class_accessor;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* goops.scm (upgrade-generic-with-setter,
|
||||
compute-new-list-of-methods): Use methods slot directly instead of
|
||||
generic-function-methods.
|
||||
(upgrade-generic-with-setter): Handle <extended-generic>:s.
|
||||
(define-extended-generic): New syntax.
|
||||
(make-extended-generic): New function.
|
||||
|
||||
2002-12-08 Rob Browning <rlb@defaultvalue.org>
|
||||
|
||||
* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; installed-scm-file
|
||||
|
||||
;;;; Copyright (C) 1998,1999,2000,2001,2002 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -53,11 +53,13 @@
|
|||
(define-module (oop goops)
|
||||
:export-syntax (define-class class
|
||||
define-generic define-accessor define-method
|
||||
define-extended-generic
|
||||
method)
|
||||
:export (goops-version is-a?
|
||||
ensure-metaclass ensure-metaclass-with-supers
|
||||
make-class
|
||||
make-generic ensure-generic
|
||||
make-extended-generic
|
||||
make-accessor ensure-accessor
|
||||
make-method add-method!
|
||||
object-eqv? object-equal?
|
||||
|
|
@ -371,10 +373,61 @@
|
|||
(else
|
||||
`(define ,name (make <generic> #:name ',name))))))))
|
||||
|
||||
(define define-extended-generic
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(let ((name (cadr exp)))
|
||||
(cond ((not (symbol? name))
|
||||
(goops-error "bad generic function name: ~S" name))
|
||||
((null? (cddr exp))
|
||||
(goops-error "missing expression"))
|
||||
(else
|
||||
`(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
|
||||
|
||||
(define (make-generic . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(make <generic> #:name name)))
|
||||
|
||||
(define (make-extended-generic gfs . name)
|
||||
(let* ((name (and (pair? name) (car name)))
|
||||
(gfs (if (pair? gfs) gfs (list gfs)))
|
||||
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
|
||||
(let ((ans (if gws?
|
||||
(let* ((sname (and name (make-setter-name name)))
|
||||
(setters
|
||||
(apply append
|
||||
(map (lambda (gf)
|
||||
(if (is-a? gf <generic-with-setter>)
|
||||
(list (ensure-generic (setter gf)
|
||||
sname))
|
||||
'()))
|
||||
gfs)))
|
||||
(es (make <extended-generic-with-setter>
|
||||
#:name name
|
||||
#:extends gfs
|
||||
#:setter (make <extended-generic>
|
||||
#:name sname
|
||||
#:extends setters))))
|
||||
(extended-by! setters (setter es))
|
||||
es)
|
||||
(make <extended-generic>
|
||||
#:name name
|
||||
#:extends gfs))))
|
||||
(extended-by! gfs ans)
|
||||
ans)))
|
||||
|
||||
(define (extended-by! gfs eg)
|
||||
(for-each (lambda (gf)
|
||||
(slot-set! gf 'extended-by
|
||||
(cons eg (slot-ref gf 'extended-by))))
|
||||
gfs))
|
||||
|
||||
(define (not-extended-by! gfs eg)
|
||||
(for-each (lambda (gf)
|
||||
(slot-set! gf 'extended-by
|
||||
(delq! eg (slot-ref gf 'extended-by))))
|
||||
gfs))
|
||||
|
||||
(define (ensure-generic old-definition . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(cond ((is-a? old-definition <generic>) old-definition)
|
||||
|
|
@ -434,10 +487,18 @@
|
|||
(make-accessor name)))))
|
||||
|
||||
(define (upgrade-generic-with-setter generic setter)
|
||||
(let ((methods (generic-function-methods generic))
|
||||
(gws (make <generic-with-setter>
|
||||
(let ((methods (slot-ref generic 'methods))
|
||||
(gws (make (if (is-a? generic <extended-generic>)
|
||||
<extended-generic-with-setter>
|
||||
<generic-with-setter>)
|
||||
#:name (generic-function-name generic)
|
||||
#:extended-by (slot-ref generic 'extended-by)
|
||||
#:setter setter)))
|
||||
(if (is-a? generic <extended-generic>)
|
||||
(let ((gfs (slot-ref generic 'extends)))
|
||||
(not-extended-by! gfs generic)
|
||||
(slot-set! gws 'extends gfs)
|
||||
(extended-by! gfs gws)))
|
||||
;; Steal old methods
|
||||
(for-each (lambda (method)
|
||||
(slot-set! method 'generic-function gws))
|
||||
|
|
@ -553,7 +614,7 @@
|
|||
|
||||
(define (compute-new-list-of-methods gf new)
|
||||
(let ((new-spec (method-specializers new))
|
||||
(methods (generic-function-methods gf)))
|
||||
(methods (slot-ref gf 'methods)))
|
||||
(let loop ((l methods))
|
||||
(if (null? l)
|
||||
(cons new methods)
|
||||
|
|
@ -1351,6 +1412,10 @@
|
|||
(set-procedure-property! generic 'name name))
|
||||
))
|
||||
|
||||
(define-method (initialize (eg <extended-generic>) initargs)
|
||||
(next-method)
|
||||
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
|
||||
|
||||
(define dummy-procedure (lambda args *unspecified*))
|
||||
|
||||
(define-method (initialize (method <method>) initargs)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue