X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/14f1d9fec8091a5d29c3f2ac57b31c28825476cb..2ae87f26a8f84a16944f9fcdd0bbcae45939a509:/oop/goops.scm

diff --git a/oop/goops.scm b/oop/goops.scm
index 892cb9ab6..c8f1f1837 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -1,21 +1,20 @@
 ;;; installed-scm-file
 
-;;;; 	Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 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
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
 ;;;; 
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
 ;;;; 
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING.  If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 ;;;; 
 
 
@@ -27,58 +26,66 @@
 ;;;;
 
 (define-module (oop goops)
-  :use-module (oop goops goopscore)
-  :use-module (oop goops util)
-  :use-module (oop goops dispatch)
-  :use-module (oop goops compile)
-  :no-backtrace
-  )
-
-(export			  ; Define the exported symbols of this file
-    goops-version is-a?
-    ensure-metaclass ensure-metaclass-with-supers
-    define-class   class make-class
-    define-generic make-generic ensure-generic
-    define-accessor make-accessor ensure-accessor
-    define-method make-method method add-method!
-    object-eqv? object-equal?
-    class-slot-ref class-slot-set! slot-unbound slot-missing 
-    slot-definition-name  slot-definition-options slot-definition-allocation
-    slot-definition-getter slot-definition-setter slot-definition-accessor
-    slot-definition-init-value slot-definition-init-form
-    slot-definition-init-thunk slot-definition-init-keyword 
-    slot-init-function class-slot-definition
-    method-source
-    compute-cpl compute-std-cpl compute-get-n-set compute-slots
-    compute-getter-method compute-setter-method
-    allocate-instance initialize make-instance make
-    no-next-method  no-applicable-method no-method
-    change-class update-instance-for-different-class
-    shallow-clone deep-clone
-    class-redefinition
-    apply-generic apply-method apply-methods
-    compute-applicable-methods %compute-applicable-methods
-    method-more-specific? sort-applicable-methods
-    class-subclasses class-methods
-    goops-error
-    min-fixnum max-fixnum
-)
-
-;;; *fixme* Should go into goops.c
-
-(export
-    instance?  slot-ref-using-class
-    slot-set-using-class! slot-bound-using-class?
-    slot-exists-using-class? slot-ref slot-set! slot-bound? class-of
-    class-name class-direct-supers class-direct-subclasses
-    class-direct-methods class-direct-slots class-precedence-list
-    class-slots class-environment
-    generic-function-name
-    generic-function-methods method-generic-function method-specializers
-    primitive-generic-generic enable-primitive-generic!
-    method-procedure accessor-method-slot-definition
-    slot-exists? make find-method get-keyword
-    %logand)
+  :export-syntax (define-class class standard-define-class
+		  define-generic define-accessor define-method
+		  define-extended-generic define-extended-generics
+		  method)
+  :export (goops-version is-a? class-of
+           ensure-metaclass ensure-metaclass-with-supers
+	   make-class
+	   make-generic ensure-generic
+	   make-extended-generic
+	   make-accessor ensure-accessor
+	   process-class-pre-define-generic
+	   process-class-pre-define-accessor
+	   process-define-generic
+	   process-define-accessor
+	   make-method add-method!
+	   object-eqv? object-equal?
+	   class-slot-ref class-slot-set! slot-unbound slot-missing 
+	   slot-definition-name  slot-definition-options
+	   slot-definition-allocation
+	   slot-definition-getter slot-definition-setter
+	   slot-definition-accessor
+	   slot-definition-init-value slot-definition-init-form
+	   slot-definition-init-thunk slot-definition-init-keyword 
+	   slot-init-function class-slot-definition
+	   method-source
+	   compute-cpl compute-std-cpl compute-get-n-set compute-slots
+	   compute-getter-method compute-setter-method
+	   allocate-instance initialize make-instance make
+	   no-next-method  no-applicable-method no-method
+	   change-class update-instance-for-different-class
+	   shallow-clone deep-clone
+	   class-redefinition
+	   apply-generic apply-method apply-methods
+	   compute-applicable-methods %compute-applicable-methods
+	   method-more-specific? sort-applicable-methods
+	   class-subclasses class-methods
+	   goops-error
+	   min-fixnum max-fixnum
+	   ;;; *fixme* Should go into goops.c
+	   instance?  slot-ref-using-class
+	   slot-set-using-class! slot-bound-using-class?
+	   slot-exists-using-class? slot-ref slot-set! slot-bound?
+	   class-name class-direct-supers class-direct-subclasses
+	   class-direct-methods class-direct-slots class-precedence-list
+	   class-slots class-environment
+	   generic-function-name
+	   generic-function-methods method-generic-function method-specializers
+	   primitive-generic-generic enable-primitive-generic!
+	   method-procedure accessor-method-slot-definition
+	   slot-exists? make find-method get-keyword)
+  :replace (<class> <operator-class> <entity-class> <entity>)
+  :no-backtrace)
+
+;; First initialize the builtin part of GOOPS
+(%init-goops-builtins)
+
+;; Then load the rest of GOOPS
+(use-modules (oop goops util)
+	     (oop goops dispatch)
+	     (oop goops compile))
 
 
 (define min-fixnum (- (expt 2 29)))
@@ -151,15 +158,31 @@
 (define (define-class-pre-definition keyword exp env)
   (case keyword
     ((#:getter #:setter)
-     (if (defined? exp env)
-	 `(define ,exp (ensure-generic ,exp ',exp))
-	 `(define ,exp (make-generic ',exp))))
+     `(process-class-pre-define-generic ',exp))
     ((#:accessor)
-     (if (defined? exp env)
-	 `(define ,exp (ensure-accessor ,exp ',exp))
-	 `(define ,exp (make-accessor ',exp))))
+     `(process-class-pre-define-accessor ',exp))
     (else #f)))
 
+(define (process-class-pre-define-generic name)
+  (let ((var (module-variable (current-module) name)))
+    (if (not (and var
+		  (variable-bound? var)
+		  (is-a? (variable-ref var) <generic>)))
+	(process-define-generic name))))
+
+(define (process-class-pre-define-accessor name)
+  (let ((var (module-variable (current-module) name)))
+    (cond ((or (not var)
+	       (not (variable-bound? var)))
+	   (process-define-accessor name))
+	  ((or (is-a? (variable-ref var) <accessor>)
+	       (is-a? (variable-ref var) <extended-generic-with-setter>)))
+	  ((is-a? (variable-ref var) <generic>)
+	   ;;*fixme* don't mutate an imported object!
+	   (variable-set! var (ensure-accessor (variable-ref var) name)))
+	  (else
+	   (process-define-accessor name)))))
+
 ;;; This code should be implemented in C.
 ;;;
 (define define-class
@@ -198,7 +221,7 @@
 	   (name cadr)
 	   (slots cdddr))
     
-    (procedure->macro
+    (procedure->memoizing-macro
       (lambda (exp env)
 	(cond ((not (top-level-env? env))
 	       (goops-error "define-class: Only allowed at top level"))
@@ -209,23 +232,17 @@
 		 `(begin
 		    ;; define accessors
 		    ,@(pre-definitions (slots exp) env)
-		 
-		    ,(if (defined? name env)
-		      
-			 ;; redefine an old class
-			 `(define ,name
-			    (let ((old ,name)
-				  (new (class ,@(cddr exp) #:name ',name)))
-			      (if (and (is-a? old <class>)
-				       ;; Prevent redefinition of non-objects
-				       (memq <object>
-					     (class-precedence-list old)))
-				  (class-redefinition old new)
-				  new)))
-		      
-			 ;; define a new class
-			 `(define ,name
-			    (class ,@(cddr exp) #:name ',name)))))))))))
+		    ;; update the current-module
+		    (let* ((class (class ,@(cddr exp) #:name ',name))
+			   (var (module-ensure-local-variable!
+				 (current-module) ',name))
+			   (old (and (variable-bound? var)
+				     (variable-ref var))))
+		      (if (and old
+			       (is-a? old <class>)
+			       (memq <object> (class-precedence-list old)))
+			  (variable-set! var (class-redefinition old class))
+			  (variable-set! var class)))))))))))
 
 (define standard-define-class define-class)
 
@@ -335,23 +352,95 @@
 ;;;
 
 (define define-generic
-  (procedure->macro
+  (procedure->memoizing-macro
     (lambda (exp env)
       (let ((name (cadr exp)))
 	(cond ((not (symbol? name))
 	       (goops-error "bad generic function name: ~S" name))
-	      ((defined? name env)
-	       `(define ,name
-		  (if (is-a? ,name <generic>)
-		      (make <generic> #:name ',name)
-		      (ensure-generic ,name ',name))))
+	      ((top-level-env? env)
+	       `(process-define-generic ',name))
 	      (else
 	       `(define ,name (make <generic> #:name ',name))))))))
 
+(define (process-define-generic name)
+  (let ((var (module-ensure-local-variable! (current-module) name)))
+    (if (or (not var)
+	    (not (variable-bound? var))
+	    (is-a? (variable-ref var) <generic>))
+	;; redefine if NAME isn't defined previously, or is another generic
+	(variable-set! var (make <generic> #:name name))
+	;; otherwise try to upgrade the object to a generic
+	(variable-set! var (ensure-generic (variable-ref var) 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 define-extended-generics
+  (procedure->memoizing-macro
+    (lambda (exp env)
+      (let ((names (cadr exp))
+	    (prefixes (get-keyword #:prefix (cddr exp) #f)))
+	(if prefixes
+	    `(begin
+	       ,@(map (lambda (name)
+			`(define-extended-generic ,name
+			   (list ,@(map (lambda (prefix)
+					  (symbol-append prefix name))
+					prefixes))))
+		      names))
+	    (goops-error "no prefixes supplied"))))))
+
 (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)
@@ -365,40 +454,48 @@
 	  (else (make <generic> #:name name)))))
 
 (define define-accessor
-  (procedure->macro
+  (procedure->memoizing-macro
     (lambda (exp env)
       (let ((name (cadr exp)))
 	(cond ((not (symbol? name))
 	       (goops-error "bad accessor name: ~S" name))
-	      ((defined? name env)
-	       `(define ,name
-		  (if (and (is-a? ,name <generic-with-setter>)
-			   (is-a? (setter ,name) <generic>))
-		      (make-accessor ',name)
-		      (ensure-accessor ,name ',name))))
+	      ((top-level-env? env)
+	       `(process-define-accessor ',name))
 	      (else
 	       `(define ,name (make-accessor ',name))))))))
 
+(define (process-define-accessor name)
+  (let ((var (module-ensure-local-variable! (current-module) name)))
+    (if (or (not var)
+	    (not (variable-bound? var))
+	    (is-a? (variable-ref var) <accessor>)
+	    (is-a? (variable-ref var) <extended-generic-with-setter>))
+	;; redefine if NAME isn't defined previously, or is another accessor
+	(variable-set! var (make-accessor name))
+	;; otherwise try to upgrade the object to an accessor
+	(variable-set! var (ensure-accessor (variable-ref var) name)))))
+
 (define (make-setter-name name)
   (string->symbol (string-append "setter:" (symbol->string name))))
 
 (define (make-accessor . name)
   (let ((name (and (pair? name) (car name))))
-    (make <generic-with-setter>
+    (make <accessor>
 	  #:name name
 	  #:setter (make <generic>
 		         #:name (and name (make-setter-name name))))))
 
 (define (ensure-accessor proc . name)
   (let ((name (and (pair? name) (car name))))
-    (cond ((is-a? proc <generic-with-setter>)
-	   (if (is-a? (setter proc) <generic>)
-	       proc
-	       (upgrade-generic-with-setter proc (setter proc))))
+    (cond ((and (is-a? proc <accessor>)
+		(is-a? (setter proc) <generic>))
+	   proc)
+	  ((is-a? proc <generic-with-setter>)
+	   (upgrade-accessor proc (setter proc)))
 	  ((is-a? proc <generic>)
-	   (upgrade-generic-with-setter proc (make-generic name)))
+	   (upgrade-accessor proc (make-generic name)))
 	  ((procedure-with-setter? proc)
-	   (make <generic-with-setter>
+	   (make <accessor>
 		 #:name name
 		 #:default (procedure proc)
 		 #:setter (ensure-generic (setter proc) name)))
@@ -407,11 +504,19 @@
 	  (else
 	   (make-accessor name)))))
 
-(define (upgrade-generic-with-setter generic setter)
-  (let ((methods (generic-function-methods generic))
-	(gws (make <generic-with-setter>
+(define (upgrade-accessor generic setter)
+  (let ((methods (slot-ref generic 'methods))
+	(gws (make (if (is-a? generic <extended-generic>)
+		       <extended-generic-with-setter>
+		       <accessor>)
 		   #: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))
@@ -426,40 +531,53 @@
 (define define-method
   (procedure->memoizing-macro
     (lambda (exp env)
-      (let ((name (cadr exp)))
-	(if (and (pair? name)
-		 (eq? (car name) 'setter)
-		 (pair? (cdr name))
-		 (symbol? (cadr name))
-		 (null? (cddr name)))
-	    (let ((name (cadr name)))
-	      (cond ((not (symbol? name))
-		     (goops-error "bad method name: ~S" name))
-		    ((defined? name env)
+      (let ((head (cadr exp)))
+	(if (not (pair? head))
+	    (goops-error "bad method head: ~S" head)
+	    (let ((gf (car head)))
+	      (cond ((and (pair? gf)
+			  (eq? (car gf) 'setter)
+			  (pair? (cdr gf))
+			  (symbol? (cadr gf))
+			  (null? (cddr gf)))
+		     ;; named setter method
+		     (let ((name (cadr gf)))
+		       (cond ((not (symbol? name))
+			      `(add-method! (setter ,name)
+					    (method ,(cdadr exp)
+						    ,@(cddr exp))))
+			     ((defined? name env)
+			      `(begin
+				 ;; *fixme* Temporary hack for the current
+				 ;;         module system
+				 (if (not ,name)
+				     (define-accessor ,name))
+				 (add-method! (setter ,name)
+					      (method ,(cdadr exp)
+						      ,@(cddr exp)))))
+			     (else
+			      `(begin
+				 (define-accessor ,name)
+				 (add-method! (setter ,name)
+					      (method ,(cdadr exp)
+						      ,@(cddr exp))))))))
+		    ((not (symbol? gf))
+		     `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
+		    ((defined? gf env)
 		     `(begin
-			;; *fixme* Temporary hack for the current module system
-			(if (not ,name)
-			    (define-generic ,name))
-			(add-method! (setter ,name) (method ,@(cddr exp)))))
+			;; *fixme* Temporary hack for the current
+			;;         module system
+			(if (not ,gf)
+			    (define-generic ,gf))
+			(add-method! ,gf
+				     (method ,(cdadr exp)
+					     ,@(cddr exp)))))
 		    (else
 		     `(begin
-			(define-accessor ,name)
-			(add-method! (setter ,name) (method ,@(cddr exp)))))))
-	    (cond ((pair? name)
-		   ;; Convert new syntax to old
-		   `(define-method ,(car name) ,(cdr name) ,@(cddr exp)))
-		  ((not (symbol? name))
-		   (goops-error "bad method name: ~S" name))
-		  ((defined? name env)
-		   `(begin
-		      ;; *fixme* Temporary hack for the current module system
-		      (if (not ,name)
-			  (define-generic ,name))
-		      (add-method! ,name (method ,@(cddr exp)))))
-		  (else
-		   `(begin
-		      (define-generic ,name)
-		      (add-method! ,name (method ,@(cddr exp)))))))))))
+			(define-generic ,gf)
+			(add-method! ,gf
+				     (method ,(cdadr exp)
+					     ,@(cddr exp))))))))))))
 
 (define (make-method specializers procedure)
   (make <method>
@@ -469,7 +587,7 @@
 (define method
   (letrec ((specializers
 	    (lambda (ls)
-	      (cond ((null? ls) (list ls))
+	      (cond ((null? ls) (list (list 'quote '())))
 		    ((pair? ls) (cons (if (pair? (car ls))
 					  (cadar ls)
 					  '<top>)
@@ -486,7 +604,7 @@
 	(let ((args (cadr exp))
 	      (body (cddr exp)))
 	  `(make <method>
-		 #:specializers (list* ,@(specializers args))
+		 #:specializers (cons* ,@(specializers args))
 		 #:procedure (lambda ,(formals args)
 			       ,@(if (null? body)
 				     (list *unspecified*)
@@ -514,7 +632,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)
@@ -531,21 +649,8 @@
   (slot-set! gf 'methods (compute-new-list-of-methods gf m))
   (let ((specializers (slot-ref m 'specializers)))
     (slot-set! gf 'n-specialized
-	       (let ((n-specialized (slot-ref gf 'n-specialized)))
-		 ;; The magnitude indicates # specializers.
-		 ;; A negative value indicates that at least one
-		 ;; method has rest arguments. (Ugly but effective
-		 ;; space optimization saving one slot in GF objects.)
-		 (cond ((negative? n-specialized)
-			(- (max (+ 1 (length* specializers))
-				(abs n-specialized))))
-		       ((list? specializers)
-			(max (length specializers)
-			     n-specialized))
-		       (else
-			(- (+ 1 (max (length* specializers)
-				     n-specialized)))))
-		 )))
+	       (max (length* specializers)
+		    (slot-ref gf 'n-specialized))))
   (%invalidate-method-cache! gf)
   (add-method-in-classes! m)
   *unspecified*)
@@ -557,17 +662,17 @@
 			#:specializers (list <generic> <method>)
 			#:procedure internal-add-method!))
 
-(define-method add-method! ((proc <procedure>) (m <method>))
+(define-method (add-method! (proc <procedure>) (m <method>))
   (if (generic-capability? proc)
       (begin
 	(enable-primitive-generic! proc)
 	(add-method! proc m))
       (next-method)))
 
-(define-method add-method! ((pg <primitive-generic>) (m <method>))
+(define-method (add-method! (pg <primitive-generic>) (m <method>))
   (add-method! (primitive-generic-generic pg) m))
 
-(define-method add-method! (obj (m <method>))
+(define-method (add-method! obj (m <method>))
   (goops-error "~S is not a valid generic function" obj))
 
 ;;;
@@ -577,7 +682,7 @@
 ;;;
 ;;; Methods
 ;;;
-(define-method method-source ((m <method>))
+(define-method (method-source (m <method>))
   (let* ((spec (map* class-name (slot-ref m 'specializers)))
 	 (proc (procedure-source (slot-ref m 'procedure)))
 	 (args (cadr proc))
@@ -632,8 +737,14 @@
 ;;; Methods to compare objects
 ;;;
 
-(define-method object-eqv? (x y)    #f)
-(define-method object-equal? (x y)  (eqv? x y))
+(define-method (eqv? x y) #f)
+(define-method (equal? x y) (eqv? x y))
+
+;;; These following two methods are for backward compatibility only.
+;;; They are not called by the Guile interpreter.
+;;;
+(define-method (object-eqv? x y)    #f)
+(define-method (object-equal? x y)  (eqv? x y))
 
 ;;;
 ;;; methods to display/write an object
@@ -647,14 +758,14 @@
 (define (display-address o file)
   (display (number->string (object-address o) 16) file))
 
-(define-method write (o file)
+(define-method (write o file)
   (display "#<instance " file)
   (display-address o file)
   (display #\> file))
 
 (define write-object (primitive-generic-generic write))
 
-(define-method write ((o <object>) file)
+(define-method (write (o <object>) file)
   (let ((class (class-of o)))
     (if (slot-bound? class 'name)
 	(begin
@@ -665,7 +776,7 @@
 	  (display #\> file))
 	(next-method))))
 
-(define-method write ((o <foreign-object>) file)
+(define-method (write (o <foreign-object>) file)
   (let ((class (class-of o)))
     (if (slot-bound? class 'name)
 	(begin
@@ -676,7 +787,7 @@
 	  (display #\> file))
 	(next-method))))
 
-(define-method write ((class <class>) file)
+(define-method (write (class <class>) file)
   (let ((meta (class-of class)))
     (if (and (slot-bound? class 'name)
 	     (slot-bound? meta 'name))
@@ -690,7 +801,7 @@
 	  (display #\> file))
 	(next-method))))
 
-(define-method write ((gf <generic>) file)
+(define-method (write (gf <generic>) file)
   (let ((meta (class-of gf)))
     (if (and (slot-bound? meta 'name)
 	     (slot-bound? gf 'methods))
@@ -707,7 +818,7 @@
 	  (display ")>" file))
 	(next-method))))
 
-(define-method write ((o <method>) file)
+(define-method (write (o <method>) file)
   (let ((meta (class-of o)))
     (if (and (slot-bound? meta 'name)
 	     (slot-bound? o 'specializers))
@@ -727,9 +838,76 @@
 	(next-method))))
 
 ;; Display (do the same thing as write by default)
-(define-method display (o file) 
+(define-method (display o file) 
   (write-object o file))
 
+;;;
+;;; Handling of duplicate bindings in the module system
+;;;
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <top>)
+			       (int2 <module>)
+			       (val2 <top>)
+			       (var <top>)
+			       (val <top>))
+  #f)
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <generic>)
+			       (int2 <module>)
+			       (val2 <generic>)
+			       (var <top>)
+			       (val <boolean>))
+  (and (not (eq? val1 val2))
+       (make-variable (make-extended-generic (list val2 val1) name))))
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <generic>)
+			       (int2 <module>)
+			       (val2 <generic>)
+			       (var <top>)
+			       (gf <extended-generic>))
+  (and (not (memq val2 (slot-ref gf 'extends)))
+       (begin
+	 (slot-set! gf
+		    'extends
+		    (cons val2 (delq! val2 (slot-ref gf 'extends))))
+	 (slot-set! val2
+		    'extended-by
+		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+	 var)))
+
+(module-define! duplicate-handlers 'merge-generics merge-generics)
+
+(define-method (merge-accessors (module <module>)
+				(name <symbol>)
+				(int1 <module>)
+				(val1 <top>)
+				(int2 <module>)
+				(val2 <top>)
+				(var <top>)
+				(val <top>))
+  #f)
+
+(define-method (merge-accessors (module <module>)
+				(name <symbol>)
+				(int1 <module>)
+				(val1 <accessor>)
+				(int2 <module>)
+				(val2 <accessor>)
+				(var <top>)
+				(val <top>))
+  (merge-generics module name int1 val1 int2 val2 var val))
+
+(module-define! duplicate-handlers 'merge-accessors merge-accessors)
+
 ;;;
 ;;; slot access
 ;;;
@@ -752,42 +930,42 @@
 (define (class-slot-set! class slot value)
   ((cadr (class-slot-g-n-s class slot)) #f value))
 
-(define-method slot-unbound ((c <class>) (o <object>) s)
+(define-method (slot-unbound (c <class>) (o <object>) s)
   (goops-error "Slot `~S' is unbound in object ~S" s o))
 
-(define-method slot-unbound ((c <class>) s)
+(define-method (slot-unbound (c <class>) s)
   (goops-error "Slot `~S' is unbound in class ~S" s c))
 
-(define-method slot-unbound ((o <object>))
+(define-method (slot-unbound (o <object>))
   (goops-error "Unbound slot in object ~S" o))
 
-(define-method slot-missing ((c <class>) (o <object>) s)
+(define-method (slot-missing (c <class>) (o <object>) s)
   (goops-error "No slot with name `~S' in object ~S" s o))
   
-(define-method slot-missing ((c <class>) s)
+(define-method (slot-missing (c <class>) s)
   (goops-error "No class slot with name `~S' in class ~S" s c))
   
 
-(define-method slot-missing ((c <class>) (o <object>) s value)
+(define-method (slot-missing (c <class>) (o <object>) s value)
   (slot-missing c o s))
 
 ;;; Methods for the possible error we can encounter when calling a gf
 
-(define-method no-next-method ((gf <generic>) args)
+(define-method (no-next-method (gf <generic>) args)
   (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
 
-(define-method no-applicable-method ((gf <generic>) args)
+(define-method (no-applicable-method (gf <generic>) args)
   (goops-error "No applicable method for ~S in call ~S"
 	       gf (cons (generic-function-name gf) args)))
 
-(define-method no-method ((gf <generic>) args)
+(define-method (no-method (gf <generic>) args)
   (goops-error "No method defined for ~S"  gf))
 
 ;;;
 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
 ;;;
 
-(define-method shallow-clone ((self <object>))
+(define-method (shallow-clone (self <object>))
   (let ((clone (%allocate-instance (class-of self) '()))
 	(slots (map slot-definition-name
 		    (class-slots (class-of self)))))
@@ -797,7 +975,7 @@
 	      slots)
     clone))
 
-(define-method deep-clone  ((self <object>))
+(define-method (deep-clone  (self <object>))
   (let ((clone (%allocate-instance (class-of self) '()))
 	(slots (map slot-definition-name
 		    (class-slots (class-of self)))))
@@ -830,7 +1008,7 @@
 ;;; 2. Old class header exists on old super classes direct-subclass lists
 ;;; 3. New class header exists on new super classes direct-subclass lists
 
-(define-method class-redefinition ((old <class>) (new <class>))
+(define-method (class-redefinition (old <class>) (new <class>))
   ;; Work on direct methods:
   ;;		1. Remove accessor methods from the old class 
   ;;		2. Patch the occurences of new in the specializers by old
@@ -880,17 +1058,23 @@
 ;;; remove-class-accessors!
 ;;;
 
-(define-method remove-class-accessors! ((c <class>))
+(define-method (remove-class-accessors! (c <class>))
   (for-each (lambda (m)
 	      (if (is-a? m <accessor-method>)
-		  (remove-method-in-classes! m)))
+		  (let ((gf (slot-ref m 'generic-function)))
+		    ;; remove the method from its GF
+		    (slot-set! gf 'methods
+			       (delq1! m (slot-ref gf 'methods)))
+		    (%invalidate-method-cache! gf)
+		    ;; remove the method from its specializers
+		    (remove-method-in-classes! m))))
 	    (class-direct-methods c)))
 
 ;;;
 ;;; update-direct-method!
 ;;;
 
-(define-method update-direct-method! ((m  <method>)
+(define-method (update-direct-method! (m  <method>)
 				      (old <class>)
 				      (new <class>))
   (let loop ((l (method-specializers m)))
@@ -906,7 +1090,7 @@
 ;;; update-direct-subclass!
 ;;;
 
-(define-method update-direct-subclass! ((c <class>)
+(define-method (update-direct-subclass! (c <class>)
 					(old <class>)
 					(new <class>))
   (class-redefinition c
@@ -943,23 +1127,20 @@
 			     (compute-setter-method class g-n-s))))))
       slots (slot-ref class 'getters-n-setters)))
 
-(define-method compute-getter-method ((class <class>) slotdef)
+(define-method (compute-getter-method (class <class>) slotdef)
   (let ((init-thunk (cadr slotdef))
 	(g-n-s (cddr slotdef)))
     (make <accessor-method>
           #:specializers (list class)
 	  #:procedure (cond ((pair? g-n-s)
-			     (if init-thunk
-				 (car g-n-s)
-				 (make-generic-bound-check-getter (car g-n-s))
-				 ))
+			     (make-generic-bound-check-getter (car g-n-s)))
 			    (init-thunk
 			     (standard-get g-n-s))
 			    (else
 			     (bound-check-get g-n-s)))
 	  #:slot-definition slotdef)))
 
-(define-method compute-setter-method ((class <class>) slotdef)
+(define-method (compute-setter-method (class <class>) slotdef)
   (let ((g-n-s (cddr slotdef)))
     (make <accessor-method>
           #:specializers (list class <top>)
@@ -1007,37 +1188,64 @@
 (define standard-set (standard-accessor-method make-set standard-set-methods))
 
 ;;; compute-getters-n-setters
-;;; 
+;;;
+(define (make-thunk thunk)
+  (lambda () (thunk)))
+
 (define (compute-getters-n-setters class slots env)
 
-  (define (compute-slot-init-function s)
-    (or (slot-definition-init-thunk s)
+  (define (compute-slot-init-function name s)
+    (or (let ((thunk (slot-definition-init-thunk s)))
+	  (and thunk
+	       (cond ((not (thunk? thunk))
+		      (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+				   name class thunk))
+		     ((closure? thunk) thunk)
+		     (else (make-thunk thunk)))))
 	(let ((init (slot-definition-init-value s)))
 	  (and (not (unbound? init))
 	       (lambda () init)))))
 
   (define (verify-accessors slot l)
-    (if (pair? l)
-	(let ((get (car l)) 
-	      (set (cadr l)))
-	  (if (not (and (closure? get)
-			(= (car (procedure-property get 'arity)) 1)))
-	      (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
-			   slot class get))
-	  (if (not (and (closure? set)
-			(= (car (procedure-property set 'arity)) 2)))
-	    (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
-			 slot class set)))))
+    (cond ((integer? l))
+	  ((not (and (list? l) (= (length l) 2)))
+	   (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+			slot class l))
+	  (else
+	   (let ((get (car l)) 
+		 (set (cadr l)))
+	     (if (not (and (closure? get)
+			   (= (car (procedure-property get 'arity)) 1)))
+		 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+			      slot class get))
+	     (if (not (and (closure? set)
+			   (= (car (procedure-property set 'arity)) 2)))
+		 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+			      slot class set))))))
 
   (map (lambda (s)
-	 (let* ((g-n-s (compute-get-n-set class s))
+	 ;; The strange treatment of nfields is due to backward compatibility.
+	 (let* ((index (slot-ref class 'nfields))
+		(g-n-s (compute-get-n-set class s))
+		(size (- (slot-ref class 'nfields) index))
 		(name  (slot-definition-name s)))
-	   ; For each slot we have '(name init-function getter setter)
-	   ; If slot, we have the simplest form '(name init-function . index)
+	   ;; NOTE: The following is interdependent with C macros
+	   ;; defined above goops.c:scm_sys_prep_layout_x.
+	   ;;
+	   ;; For simple instance slots, we have the simplest form
+	   ;; '(name init-function . index)
+	   ;; For other slots we have
+	   ;; '(name init-function getter setter . alloc)
+	   ;; where alloc is:
+	   ;;   '(index size) for instance allocated slots
+	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
 	   (cons name
-		 (cons (compute-slot-init-function s)
-		       g-n-s))))
+		 (cons (compute-slot-init-function name s)
+		       (if (or (integer? g-n-s)
+			       (zero? size))
+			   g-n-s
+			   (append g-n-s (list index size)))))))
        slots))
 
 ;;; compute-cpl
@@ -1061,7 +1269,7 @@
 ;;; => cpl (a) = a b d c e f object top
 ;;;
 
-(define-method compute-cpl ((class <class>))
+(define-method (compute-cpl (class <class>))
   (compute-std-cpl class class-direct-supers))
 
 ;; Support
@@ -1137,7 +1345,7 @@
 					     can-go-in-now))))
 		(loop
 		 (filter (lambda (x) (not (eq? x choice)))
-			     elements)
+			 elements)
 		 constraints
 		 (append result (list choice)))))))))
 
@@ -1188,7 +1396,7 @@
 
 ;;; compute-get-n-set
 ;;;
-(define-method compute-get-n-set ((class <class>) s)
+(define-method (compute-get-n-set (class <class>) s)
   (case (slot-definition-allocation s)
     ((#:instance) ;; Instance slot
      ;; get-n-set is just its offset
@@ -1221,7 +1429,7 @@
 	   (set (get-keyword #:slot-set! (slot-definition-options s) #f))
 	   (env (class-environment class)))
        (if (not (and get set))
-	   (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
+	   (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
 			s))
        (list get set)))
     (else    (next-method))))
@@ -1231,20 +1439,20 @@
     (list (lambda (o) shared-variable)
 	  (lambda (o v) (set! shared-variable v)))))
 
-(define-method compute-get-n-set ((o <object>) s)
+(define-method (compute-get-n-set (o <object>) s)
   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
 
-(define-method compute-slots ((class <class>))
+(define-method (compute-slots (class <class>))
   (%compute-slots class))
 
 ;;;
 ;;; {Initialize}
 ;;;
 
-(define-method initialize ((object <object>) initargs)
+(define-method (initialize (object <object>) initargs)
   (%initialize-object object initargs))
 
-(define-method initialize ((class <class>) initargs)
+(define-method (initialize (class <class>) initargs)
   (next-method)
   (let ((dslots (get-keyword #:slots initargs '()))
 	(supers (get-keyword #:dsupers	  initargs '()))
@@ -1282,37 +1490,34 @@
     ;; Set the layout slot
     (%prep-layout! class)))
 
-(define object-procedure-tags
-  '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2))
-
 (define (initialize-object-procedure object initargs)
   (let ((proc (get-keyword #:procedure initargs #f)))
     (cond ((not proc))
 	  ((pair? proc)
 	   (apply set-object-procedure! object proc))
-	  ((memq (tag proc) object-procedure-tags)
+	  ((valid-object-procedure? proc)
 	   (set-object-procedure! object proc))
 	  (else
 	   (set-object-procedure! object
 				  (lambda args (apply proc args)))))))
 
-(define-method initialize ((class <operator-class>) initargs)
+(define-method (initialize (class <operator-class>) initargs)
   (next-method)
   (initialize-object-procedure class initargs))
 
-(define-method initialize ((owsc <operator-with-setter-class>) initargs)
+(define-method (initialize (owsc <operator-with-setter-class>) initargs)
   (next-method)
   (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
 
-(define-method initialize ((entity <entity>) initargs)
+(define-method (initialize (entity <entity>) initargs)
   (next-method)
   (initialize-object-procedure entity initargs))
 
-(define-method initialize ((ews <entity-with-setter>) initargs)
+(define-method (initialize (ews <entity-with-setter>) initargs)
   (next-method)
   (%set-object-setter! ews (get-keyword #:setter initargs #f)))
 
-(define-method initialize ((generic <generic>) initargs)
+(define-method (initialize (generic <generic>) initargs)
   (let ((previous-definition (get-keyword #:default initargs #f))
 	(name (get-keyword #:name initargs #f)))
     (next-method)
@@ -1328,22 +1533,29 @@
 	(set-procedure-property! generic 'name name))
     ))
 
-(define-method initialize ((method <method>) initargs)
+(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)
   (next-method)
   (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
-  (slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '())))
+  (slot-set! method 'procedure
+	     (get-keyword #:procedure initargs dummy-procedure))
   (slot-set! method 'code-table '()))
 
-(define-method initialize ((obj <foreign-object>) initargs))
+(define-method (initialize (obj <foreign-object>) initargs))
 
 ;;;
 ;;; {Change-class}
 ;;;
 
 (define (change-object-class old-instance old-class new-class)
-  (let ((new-instance (allocate-instance new-class ())))
-    ;; Initalize the slot of the new instance
+  (let ((new-instance (allocate-instance new-class '())))
+    ;; Initialize the slots of the new instance
     (for-each (lambda (slot)
 		(if (and (slot-exists-using-class? old-class old-instance slot)
 			 (eq? (slot-definition-allocation
@@ -1372,13 +1584,13 @@
     old-instance))
 
 
-(define-method update-instance-for-different-class ((old-instance <object>)
+(define-method (update-instance-for-different-class (old-instance <object>)
 						    (new-instance
 						     <object>))
   ;;not really important what we do, we just need a default method
   new-instance)
 
-(define-method change-class ((old-instance <object>) (new-class <class>))
+(define-method (change-class (old-instance <object>) (new-class <class>))
   (change-object-class old-instance (class-of old-instance) new-class))
 
 ;;;
@@ -1387,10 +1599,10 @@
 ;;; A new definition which overwrites the previous one which was built-in
 ;;;
 
-(define-method allocate-instance ((class <class>) initargs)
+(define-method (allocate-instance (class <class>) initargs)
   (%allocate-instance class initargs))
 
-(define-method make-instance ((class <class>) . initargs)
+(define-method (make-instance (class <class>) . initargs)
   (let ((instance (allocate-instance class initargs)))
     (initialize instance initargs)
     instance))
@@ -1411,7 +1623,7 @@
 ;;;   - the currified protocol would be imho inefficient in C.
 ;;;
 
-(define-method apply-generic ((gf <generic>) args)
+(define-method (apply-generic (gf <generic>) args)
   (if (null? (slot-ref gf 'methods))
       (no-method gf args))
   (let ((methods (compute-applicable-methods gf args)))
@@ -1424,24 +1636,24 @@
 (define %%compute-applicable-methods
   (make <generic> #:name 'compute-applicable-methods))
 
-(define-method %%compute-applicable-methods ((gf <generic>) args)
+(define-method (%%compute-applicable-methods (gf <generic>) args)
   (%compute-applicable-methods gf args))
 
 (set! compute-applicable-methods %%compute-applicable-methods)
 
-(define-method sort-applicable-methods ((gf <generic>) methods args)
+(define-method (sort-applicable-methods (gf <generic>) methods args)
   (let ((targs (map class-of args)))
     (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
 
-(define-method method-more-specific? ((m1 <method>) (m2 <method>) targs)
+(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
   (%method-more-specific? m1 m2 targs))
 
-(define-method apply-method ((gf <generic>) methods build-next args)
+(define-method (apply-method (gf <generic>) methods build-next args)
   (apply (method-procedure (car methods))
 	 (build-next (cdr methods) args)
 	 args))
 
-(define-method apply-methods ((gf <generic>) (l <list>) args)
+(define-method (apply-methods (gf <generic>) (l <list>) args)
   (letrec ((next (lambda (procs args)
 		   (lambda new-args
 		     (let ((a (if (null? new-args) args new-args)))