* 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.

libguile/ChangeLog

@@ -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.

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
+ *   This version doesn't fully handle multiple-inheritance. It serves
- * booting classes and will be overloaded in Scheme
+ *   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>",

libguile/goops.h

@@ -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;

oop/ChangeLog

@@ -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.

oop/goops.scm

@@ -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))
+  (let ((methods (slot-ref generic 'methods))
-	(gws (make <generic-with-setter>
+	(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)