X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/9ff56d9e65fa9292ef09a8ca01abd825147b37ac..583a23bf104c84d9617222856e188f3f3af4934d:/module/oop/goops.scm

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2f6625c3f..486a652c0 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,44 +1,44 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; 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.
-;;;; 
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
 ;;;; 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
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; 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
-;;;; 
+;;;;
 
 
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon stklos.stk from the STk distribution by
-;;;; Erick Gallesio <eg@unice.fr>.
+;;;; This file was based upon stklos.stk from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (define-module (oop goops)
-  :use-module (srfi srfi-1)
-  :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
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops util)
+  #:export-syntax (define-class class standard-define-class
+                   define-generic define-accessor define-method
+                   define-extended-generic define-extended-generics
+                   method)
+  #:export (is-a? class-of
            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?
+	   add-method!
 	   class-slot-ref class-slot-set! slot-unbound slot-missing 
 	   slot-definition-name  slot-definition-options
 	   slot-definition-allocation
@@ -67,37 +67,85 @@
 	   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
+	   class-slots
 	   generic-function-name
-	   generic-function-methods method-generic-function method-specializers
+	   generic-function-methods method-generic-function
+	   method-specializers method-formals
 	   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)
+	   slot-exists? make find-method get-keyword))
 
 (define *goops-module* (current-module))
 
 ;; First initialize the builtin part of GOOPS
-(eval-case
- ((load-toplevel compile-toplevel)
-  (%init-goops-builtins)))
+(eval-when (expand load eval)
+  (%init-goops-builtins))
+
+(eval-when (expand load eval)
+  (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
+  (add-interesting-primitive! 'class-of))
 
 ;; Then load the rest of GOOPS
-(use-modules (oop goops util)
-	     (oop goops dispatch)
-	     (oop goops compile))
+(use-modules (oop goops dispatch))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compute-cmethod methods types)
+  (match methods
+    ((method . methods)
+     (cond
+      ((is-a? method <accessor-method>)
+       (match types
+         ((class . _)
+          (let* ((name (car (accessor-method-slot-definition method)))
+                 (g-n-s (assq name (slot-ref class 'getters-n-setters)))
+                 (init-thunk (cadr g-n-s))
+                 (g-n-s (cddr g-n-s)))
+            (match types
+              ((class)
+               (cond ((pair? 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))))
+              ((class value)
+               (if (pair? g-n-s)
+                   (cadr g-n-s)
+                   (standard-set g-n-s))))))))
+      (else
+       (let ((make-procedure (slot-ref method 'make-procedure)))
+         (if make-procedure
+             (make-procedure
+              (if (null? methods)
+                  (lambda args
+                    (no-next-method (method-generic-function method) args))
+                  (compute-cmethod methods types)))
+             (method-procedure method))))))))
 
 
-(define min-fixnum (- (expt 2 29)))
-
-(define max-fixnum (- (expt 2 29) 1))
+(eval-when (expand load eval)
+  (define min-fixnum (- (expt 2 29)))
+  (define max-fixnum (- (expt 2 29) 1)))
 
 ;;
 ;; goops-error
 ;;
 (define (goops-error format-string . args)
-  (save-stack)
   (scm-error 'goops-error #f format-string args '()))
 
 ;;
@@ -125,14 +173,13 @@
 	      (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
 	      new))))))
 
-(define (ensure-metaclass supers env)
+(define (ensure-metaclass supers)
   (if (null? supers)
       <class>
       (let* ((all-metas (map (lambda (x) (class-of x)) supers))
-	     (all-cpls  (apply append
-			       (map (lambda (m)
-				      (cdr (class-precedence-list m))) 
-				    all-metas)))
+	     (all-cpls  (append-map (lambda (m)
+                                      (cdr (class-precedence-list m))) 
+                                    all-metas))
 	     (needed-metas '()))
 	;; Find the most specific metaclasses.  The new metaclass will be
 	;; a subclass of these.
@@ -156,17 +203,6 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define (define-class-pre-definition kw val)
-  (case kw
-    ((#:getter #:setter)
-     `(if (or (not (defined? ',val))
-              (not (is-a? ,val <generic>)))
-          (define-generic ,val)))
-    ((#:accessor)
-     `(if (or (not (defined? ',val))
-              (not (is-a? ,val <accessor>)))
-          (define-accessor ,val)))
-    (else #f)))
 
 (define (kw-do-map mapper f kwargs)
   (define (keywords l)
@@ -182,31 +218,34 @@
          (a (args kwargs)))
     (mapper f k a)))
 
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
-  ;; Some slot options require extra definitions to be made. In
-  ;; particular, we want to make sure that the generic function objects
-  ;; which represent accessors exist before `make-class' tries to add
-  ;; methods to them.
-  ;;
-  ;; Postpone some error handling to class macro.
-  ;;
-  `(begin
-     ;; define accessors
-     ,@(append-map (lambda (slot)
-                     (kw-do-map filter-map
-                                define-class-pre-definition 
-                                (if (pair? slot) (cdr slot) '())))
-                   (take-while (lambda (x) (not (keyword? x))) slots))
-     (if (and (defined? ',name)
-              (is-a? ,name <class>)
-              (memq <object> (class-precedence-list ,name)))
-         (class-redefinition ,name
-                             (class ,supers ,@slots #:name ',name))
-         (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define standard-define-class define-class)
+(define (make-class supers slots . options)
+  (let* ((name (get-keyword #:name options (make-unbound)))
+         (supers (if (not (or-map (lambda (class)
+                                    (memq <object>
+                                          (class-precedence-list class)))
+                                  supers))
+                     (append supers (list <object>))
+                     supers))
+         (metaclass (or (get-keyword #:metaclass options #f)
+                        (ensure-metaclass supers))))
+
+    ;; Verify that all direct slots are different and that we don't inherit
+    ;; several time from the same class
+    (let ((tmp1 (find-duplicate supers))
+          (tmp2 (find-duplicate (map slot-definition-name slots))))
+      (if tmp1
+          (goops-error "make-class: super class ~S is duplicate in class ~S"
+                       tmp1 name))
+      (if tmp2
+          (goops-error "make-class: slot ~S is duplicate in class ~S"
+                       tmp2 name)))
+
+    ;; Everything seems correct, build the class
+    (apply make metaclass
+           #:dsupers supers
+           #:slots slots 
+           #:name name
+           options)))
 
 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 ;;;
@@ -231,11 +270,9 @@
         (else
          `(list ',def))))
      slots))
-    
   (if (not (list? supers))
       (goops-error "malformed superclass list: ~S" supers))
-  (let ((slot-defs (cons #f '()))
-        (slots (take-while (lambda (x) (not (keyword? x))) slots))
+  (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
         (options (or (find-tail keyword? slots) '())))
     `(make-class
       ;; evaluate super class variables
@@ -245,37 +282,65 @@
       ;; evaluate class options
       ,@options)))
 
-(define (make-class supers slots . options)
-  (let ((env (or (get-keyword #:environment options #f)
-		 (top-level-env))))
-    (let* ((name (get-keyword #:name options (make-unbound)))
-	   (supers (if (not (or-map (lambda (class)
-				      (memq <object>
-					    (class-precedence-list class)))
-				    supers))
-		       (append supers (list <object>))
-		       supers))
-	   (metaclass (or (get-keyword #:metaclass options #f)
-			  (ensure-metaclass supers env))))
-
-      ;; Verify that all direct slots are different and that we don't inherit
-      ;; several time from the same class
-      (let ((tmp1 (find-duplicate supers))
-	    (tmp2 (find-duplicate (map slot-definition-name slots))))
-	(if tmp1
-	    (goops-error "make-class: super class ~S is duplicate in class ~S"
-			 tmp1 name))
-	(if tmp2
-	    (goops-error "make-class: slot ~S is duplicate in class ~S"
-			 tmp2 name)))
-
-      ;; Everything seems correct, build the class
-      (apply make metaclass
-	     #:dsupers supers
-	     #:slots slots 
-	     #:name name
-	     #:environment env
-	     options))))
+(define-syntax define-class-pre-definition
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (k arg rest ...) out ...)
+       (keyword? (syntax->datum #'k))
+       (case (syntax->datum #'k)
+         ((#:getter #:setter)
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <generic>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
+         ((#:accessor)
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <accessor>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
+         (else
+          #'(define-class-pre-definition (rest ...) out ...))))
+      ((_ () out ...)
+       #'(begin out ...)))))
+       
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+  (lambda (x)
+    (syntax-case x ()
+      ((_ () out ...)
+       #'(begin out ...))
+      ((_ (slot rest ...) out ...)
+       (keyword? (syntax->datum #'slot))
+       #'(begin out ...))
+      ((_ (slot rest ...) out ...)
+       (identifier? #'slot)
+       #'(define-class-pre-definitions (rest ...)
+         out ...))
+      ((_ ((slotname slotopt ...) rest ...) out ...)
+       #'(define-class-pre-definitions (rest ...) 
+         out ... (define-class-pre-definition (slotopt ...)))))))
+
+(define-syntax-rule (define-class name supers slot ...)
+  (begin
+    (define-class-pre-definitions (slot ...))
+    (if (and (defined? 'name)
+             (is-a? name <class>)
+             (memq <object> (class-precedence-list name)))
+        (class-redefinition name
+                            (class supers slot ... #:name 'name))
+        (toplevel-define! 'name (class supers slot ... #:name 'name)))))
+       
+(define-syntax-rule (standard-define-class arg ...)
+  (define-class arg ...))
 
 ;;;
 ;;; {Generic functions and accessors}
@@ -309,24 +374,21 @@
                   names))
         (goops-error "no prefixes supplied"))))
 
-(define (make-generic . name)
-  (let ((name (and (pair? name) (car name))))
-    (make <generic> #:name name)))
+(define* (make-generic #:optional 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)))
+(define* (make-extended-generic gfs #:optional name)
+  (let* ((gfs (if (list? 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)
+			   (append-map (lambda (gf)
 					 (if (is-a? gf <generic-with-setter>)
 					     (list (ensure-generic (setter gf)
 								   sname))
 					     '()))
-				       gfs)))
+				       gfs))
 			  (es (make <extended-generic-with-setter>
 				#:name name
 				#:extends gfs
@@ -345,63 +407,64 @@
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (cons eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (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)
-	  ((procedure-with-setter? old-definition)
-	   (make <generic-with-setter>
-		 #:name name
-		 #:default (procedure old-definition)
-		 #:setter (setter old-definition)))
-	  ((procedure? old-definition)
-	   (make <generic> #:name name #:default old-definition))
-	  (else (make <generic> #:name name)))))
+	    gfs)
+  (invalidate-method-cache! eg))
+
+(define* (ensure-generic old-definition #:optional name)
+  (cond ((is-a? old-definition <generic>) old-definition)
+        ((procedure-with-setter? old-definition)
+         (make <generic-with-setter>
+           #:name name
+           #:default (procedure old-definition)
+           #:setter (setter old-definition)))
+        ((procedure? old-definition)
+         (if (generic-capability? old-definition) old-definition
+             (make <generic> #:name name #:default old-definition)))
+        (else (make <generic> #:name name))))
 
 ;; same semantics as <generic>
-(define-macro (define-accessor name)
-  (if (not (symbol? name))
-      (goops-error "bad accessor name: ~S" name))
-  `(define ,name
-     (if (and (defined? ',name) (is-a? ,name <accessor>))
-         (make <accessor> #:name ',name)
-         (ensure-accessor (if (defined? ',name) ,name #f) ',name))))
+(define-syntax-rule (define-accessor name)
+  (define name
+    (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
+          ((is-a? name <accessor>) (make <accessor> #:name 'name))
+          (else                    (ensure-accessor name '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 <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 ((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-accessor proc (make-generic name)))
-	  ((procedure-with-setter? proc)
-	   (make <accessor>
-		 #:name name
-		 #:default (procedure proc)
-		 #:setter (ensure-generic (setter proc) name)))
-	  ((procedure? proc)
-	   (ensure-accessor (ensure-generic proc name) name))
-	  (else
-	   (make-accessor name)))))
+(define* (make-accessor #:optional name)
+  (make <accessor>
+    #:name name
+    #:setter (make <generic>
+               #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+  (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-accessor proc (make-generic name)))
+        ((procedure-with-setter? proc)
+         (make <accessor>
+           #:name name
+           #:default (procedure proc)
+           #:setter (ensure-generic (setter proc) name)))
+        ((procedure? proc)
+         (ensure-accessor (if (generic-capability? proc)
+                              (make <generic> #:name name #:default proc)
+                              (ensure-generic proc name))
+                          name))
+        (else
+         (make-accessor name))))
 
 (define (upgrade-accessor generic setter)
   (let ((methods (slot-ref generic 'methods))
@@ -421,78 +484,136 @@
 		(slot-set! method 'generic-function gws))
 	      methods)
     (slot-set! gws 'methods methods)
+    (invalidate-method-cache! gws)
     gws))
 
 ;;;
 ;;; {Methods}
 ;;;
 
-(define-macro (define-method head . body)
-  (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 ,(cdr head) ,@body)))
-                   (else
-                    `(begin
-                       (if (or (not (defined? ',name))
-                               (not (is-a? ,name <accessor>)))
-                           (define-accessor ,name))
-                       (add-method! (setter ,name)
-                                    (method ,(cdr head) ,@body)))))))
-          ((not (symbol? gf))
-           `(add-method! ,gf (method ,(cdr head) ,@body)))
-          (else
-           `(begin
-              ;; FIXME: this code is how it always was, but it's quite
-              ;; cracky: it will only define the generic function if it
-              ;; was undefined before (ok), or *was defined to #f*. The
-              ;; latter is crack. But there are bootstrap issues about
-              ;; fixing this -- change it to (is-a? ,gf <generic>) and
-              ;; see.
-              (if (or (not (defined? ',gf))
-                      (not ,gf))
-                  (define-generic ,gf))
-              (add-method! ,gf
-                           (method ,(cdr head) ,@body)))))))
-
-(define (make-method specializers procedure)
-  (make <method>
-	#:specializers specializers
-	#:procedure procedure))
-
-(define-macro (method args . body)
-  (letrec ((specializers
-	    (lambda (ls)
-	      (cond ((null? ls) (list (list 'quote '())))
-		    ((pair? ls) (cons (if (pair? (car ls))
-					  (cadar ls)
-					  '<top>)
-				      (specializers (cdr ls))))
-		    (else '(<top>)))))
-	   (formals
-	    (lambda (ls)
-	      (if (pair? ls)
-		  (cons (if (pair? (car ls)) (caar ls) (car ls))
-			(formals (cdr ls)))
-		  ls))))
-    `(make <method>
-       #:specializers (cons* ,@(specializers args))
-       #:formals ',(formals args)
-       #:body ',body
-       #:compile-env (compile-time-environment)
-       #:procedure (lambda ,(formals args)
-                     ,@(if (null? body)
-                           '(begin)
-                           body)))))
+(define (toplevel-define! name val)
+  (module-define! (current-module) name val))
+
+(define-syntax define-method
+  (syntax-rules (setter)
+    ((_ ((setter name) . args) body ...)
+     (begin
+       (if (or (not (defined? 'name))
+               (not (is-a? name <accessor>)))
+           (toplevel-define! 'name
+                             (ensure-accessor
+                              (if (defined? 'name) name #f) 'name)))
+       (add-method! (setter name) (method args body ...))))
+    ((_ (name . args) body ...)
+     (begin
+       ;; FIXME: this code is how it always was, but it's quite cracky:
+       ;; it will only define the generic function if it was undefined
+       ;; before (ok), or *was defined to #f*. The latter is crack. But
+       ;; there are bootstrap issues about fixing this -- change it to
+       ;; (is-a? name <generic>) and see.
+       (if (or (not (defined? 'name))
+               (not name))
+           (toplevel-define! 'name (make <generic> #:name 'name)))
+       (add-method! name (method args body ...))))))
+
+(define-syntax method
+  (lambda (x)
+    (define (parse-args args)
+      (let lp ((ls args) (formals '()) (specializers '()))
+        (syntax-case ls ()
+          (((f s) . rest)
+           (and (identifier? #'f) (identifier? #'s))
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'s specializers)))
+          ((f . rest)
+           (identifier? #'f)
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'<top> specializers)))
+          (()
+           (list (reverse formals)
+                 (reverse (cons #''() specializers))))
+          (tail
+           (identifier? #'tail)
+           (list (append (reverse formals) #'tail)
+                 (reverse (cons #'<top> specializers)))))))
+
+    (define (find-free-id exp referent)
+      (syntax-case exp ()
+        ((x . y)
+         (or (find-free-id #'x referent)
+             (find-free-id #'y referent)))
+        (x
+         (identifier? #'x)
+         (let ((id (datum->syntax #'x referent)))
+           (and (free-identifier=? #'x id) id)))
+        (_ #f)))
+
+    (define (compute-procedure formals body)
+      (syntax-case body ()
+        ((body0 ...)
+         (with-syntax ((formals formals))
+           #'(lambda formals body0 ...)))))
+
+    (define (->proper args)
+      (let lp ((ls args) (out '()))
+        (syntax-case ls ()
+          ((x . xs)        (lp #'xs (cons #'x out)))
+          (()              (reverse out))
+          (tail            (reverse (cons #'tail out))))))
+
+    (define (compute-make-procedure formals body next-method)
+      (syntax-case body ()
+        ((body ...)
+         (with-syntax ((next-method next-method))
+           (syntax-case formals ()
+             ((formal ...)
+              #'(lambda (real-next-method)
+                  (lambda (formal ...)
+                    (let ((next-method (lambda args
+                                         (if (null? args)
+                                             (real-next-method formal ...)
+                                             (apply real-next-method args)))))
+                      body ...))))
+             (formals
+              (with-syntax (((formal ...) (->proper #'formals)))
+                #'(lambda (real-next-method)
+                    (lambda formals
+                      (let ((next-method (lambda args
+                                           (if (null? args)
+                                               (apply real-next-method formal ...)
+                                               (apply real-next-method args)))))
+                        body ...))))))))))
+
+    (define (compute-procedures formals body)
+      ;; So, our use of this is broken, because it operates on the
+      ;; pre-expansion source code. It's equivalent to just searching
+      ;; for referent in the datums. Ah well.
+      (let ((id (find-free-id body 'next-method)))
+        (if id
+            ;; return a make-procedure
+            (values #'#f
+                    (compute-make-procedure formals body id))
+            (values (compute-procedure formals body)
+                    #'#f))))
+
+    (syntax-case x ()
+      ((_ args) #'(method args (if #f #f)))
+      ((_ args body0 body1 ...)
+       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
+         (call-with-values
+             (lambda ()
+               (compute-procedures #'formals #'(body0 body1 ...)))
+           (lambda (procedure make-procedure)
+             (with-syntax ((procedure procedure)
+                           (make-procedure make-procedure))
+               #'(make <method>
+                   #:specializers (cons* specializer ...)
+                   #:formals 'formals
+                   #:body '(body0 body1 ...)
+                   #:make-procedure make-procedure
+                   #:procedure procedure)))))))))
 
 ;;;
 ;;; {add-method!}
@@ -502,7 +623,7 @@
   ;; Add method in all the classes which appears in its specializers list
   (for-each* (lambda (x)
 	       (let ((dm (class-direct-methods x)))
-		 (if (not (memv m dm))
+		 (if (not (memq m dm))
 		     (slot-set! x 'direct-methods (cons m dm)))))
 	     (method-specializers m)))
 
@@ -528,15 +649,25 @@
 		methods)
 	      (loop (cdr l)))))))
 
+(define (method-n-specializers m)
+  (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+  (fold (lambda (m n) (max n (method-n-specializers m)))
+        0
+        (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+  (%invalidate-method-cache! gf)
+  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+  (for-each (lambda (gf) (invalidate-method-cache! gf))
+            (slot-ref gf 'extended-by)))
+
 (define internal-add-method!
   (method ((gf <generic>) (m <method>))
     (slot-set! m  'generic-function gf)
     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
-    (let ((specializers (slot-ref m 'specializers)))
-      (slot-set! gf 'n-specialized
-                 (max (length* specializers)
-                      (slot-ref gf 'n-specialized))))
-    (%invalidate-method-cache! gf)
+    (invalidate-method-cache! gf)
     (add-method-in-classes! m)
     *unspecified*))
 
@@ -566,12 +697,16 @@
 ;;;
 (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))
-	 (body (cddr proc)))
-    (cons 'method
-	  (cons (map* list args spec)
-		body))))
+	 (src (procedure-source (slot-ref m 'procedure))))
+    (and src
+         (let ((args (cadr src))
+               (body (cddr src)))
+           (cons 'method
+                 (cons (map* list args spec)
+                       body))))))
+
+(define-method (method-formals (m <method>))
+  (slot-ref m 'formals))
 
 ;;;
 ;;; Slots
@@ -611,6 +746,10 @@
 (define (slot-init-function class slot-name)
   (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
 
+(define (accessor-method-slot-definition obj)
+  "Return the slot definition of the accessor @var{obj}."
+  (slot-ref obj 'slot-definition))
+
 
 ;;;
 ;;; {Standard methods used by the C runtime}
@@ -619,14 +758,15 @@
 ;;; Methods to compare objects
 ;;;
 
-(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))
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f)) 
+(set-primitive-generic! equal? g-equal?)
 
 ;;;
 ;;; methods to display/write an object
@@ -658,17 +798,6 @@
 	  (display #\> file))
 	(next-method))))
 
-(define-method (write (o <foreign-object>) file)
-  (let ((class (class-of o)))
-    (if (slot-bound? class 'name)
-	(begin
-	  (display "#<foreign-object " file)
-	  (display (class-name class) file)
-	  (display #\space file)
-	  (display-address o file)
-	  (display #\> file))
-	(next-method))))
-
 (define-method (write (class <class>) file)
   (let ((meta (class-of class)))
     (if (and (slot-bound? class 'name)
@@ -764,6 +893,7 @@
 	 (slot-set! val2
 		    'extended-by
 		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (invalidate-method-cache! gf)
 	 var)))
 
 (module-define! duplicate-handlers 'merge-generics merge-generics)
@@ -947,7 +1077,7 @@
 		    ;; remove the method from its GF
 		    (slot-set! gf 'methods
 			       (delq1! m (slot-ref gf 'methods)))
-		    (%invalidate-method-cache! gf)
+		    (invalidate-method-cache! gf)
 		    ;; remove the method from its specializers
 		    (remove-method-in-classes! m))))
 	    (class-direct-methods c)))
@@ -979,7 +1109,6 @@
 		      (make-class (class-direct-supers c)
 				  (class-direct-slots c)
 				  #:name (class-name c)
-				  #:environment (slot-ref c 'environment)
 				  #:metaclass (class-of c))))
 
 ;;;
@@ -988,11 +1117,10 @@
 
 ;;; compute-slot-accessors
 ;;;
-(define (compute-slot-accessors class slots env)
+(define (compute-slot-accessors class slots)
   (for-each
       (lambda (s g-n-s)
-	(let ((name            (slot-definition-name     s))
-	      (getter-function (slot-definition-getter   s))
+	(let ((getter-function (slot-definition-getter   s))
 	      (setter-function (slot-definition-setter   s))
 	      (accessor        (slot-definition-accessor s)))
 	  (if getter-function
@@ -1009,115 +1137,73 @@
 			     (compute-setter-method class g-n-s))))))
       slots (slot-ref class 'getters-n-setters)))
 
-(define-method (compute-getter-method (class <class>) slotdef)
-  (let ((init-thunk (cadr slotdef))
-	(g-n-s (cddr slotdef)))
+(define-method (compute-getter-method (class <class>) g-n-s)
+  (let ((name (car g-n-s)))
     (make <accessor-method>
           #:specializers (list class)
-	  #:procedure (cond ((pair? 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)
-  (let ((g-n-s (cddr slotdef)))
+          #:procedure (lambda (o) (slot-ref o name))
+          #:slot-definition g-n-s)))
+
+(define-method (compute-setter-method (class <class>) g-n-s)
+  (let ((name (car g-n-s)))
     (make <accessor-method>
-          #:specializers (list class <top>)
-	  #:procedure (if (pair? g-n-s)
-			  (cadr g-n-s)
-			  (standard-set g-n-s))
-	  #:slot-definition slotdef)))
+      #:specializers (list class <top>)
+      #:procedure (lambda (o v) (slot-set! o name v))
+      #:slot-definition g-n-s)))
 
 (define (make-generic-bound-check-getter proc)
-  (let ((source (and (closure? proc) (procedure-source proc))))
-    (if (and source (null? (cdddr source)))
-	(let ((obj (caadr source)))
-	  ;; smart closure compilation
-	  (local-eval
-	   `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
-	   (procedure-environment proc)))
-	(lambda (o) (assert-bound (proc o) o)))))
-
-(define n-standard-accessor-methods 10)
-
-(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-set-methods (make-vector n-standard-accessor-methods #f))
-
-(define (standard-accessor-method make methods)
-  (lambda (index)
-    (cond ((>= index n-standard-accessor-methods) (make index))
-	  ((vector-ref methods index))
-	  (else (let ((m (make index)))
-		  (vector-set! methods index m)
-		  m)))))
+  (lambda (o) (assert-bound (proc o) o)))
 
 ;; the idea is to compile the index into the procedure, for fastest
-;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-
-(eval-case
- ((load-toplevel compile-toplevel)
-  (use-modules ((language scheme translate) :select (define-scheme-translator))
-               ((language ghil) :select (make-ghil-inline))
-               (system base pmatch))
-
-  ;; unfortunately, can't use define-inline because these are primitive
-  ;; syntaxen.
-  (define-scheme-translator @slot-ref
-    ((,obj ,index) (guard (integer? index)
-                          (>= index 0) (< index max-fixnum))
-     (make-ghil-inline #f #f 'slot-ref
-                       (list (retrans obj) (retrans index)))))
-
-  (define-scheme-translator @slot-set!
-    ((,obj ,index ,val) (guard (integer? index)
-                               (>= index 0) (< index max-fixnum))
-     (make-ghil-inline #f #f 'slot-set
-                       (list (retrans obj) (retrans index) (retrans val)))))))
-
-;; Irritatingly, we can't use `compile' here, as the module shadows
-;; the binding.
-(define (make-bound-check-get index)
-  ((@ (system base compile) compile)
-   `(lambda (o) (let ((x (@slot-ref o ,index)))
-                  (if (unbound? x)
-                      (slot-unbound obj)
-                      x)))
-   #:env *goops-module*))
-
-(define (make-get index)
-  ((@ (system base compile) compile)
-   `(lambda (o) (@slot-ref o ,index))
-   #:env *goops-module*))
-
-(define (make-set index)
-  ((@ (system base compile) compile)
-   `(lambda (o v) (@slot-set! o ,index v))
-   #:env *goops-module*))
-
-(define bound-check-get
-  (standard-accessor-method make-bound-check-get bound-check-get-methods))
-(define standard-get (standard-accessor-method make-get standard-get-methods))
-(define standard-set (standard-accessor-method make-set standard-set-methods))
+;; lookup.
+
+(eval-when (expand load eval)
+  (define num-standard-pre-cache 20))
+
+(define-macro (define-standard-accessor-method form . body)
+  (let ((name (caar form))
+        (n-var (cadar form))
+        (args (cdr form)))
+    (define (make-one x)
+      (define (body-trans form)
+        (cond ((not (pair? form)) form)
+              ((eq? (car form) 'struct-ref)
+               `(,(car form) ,(cadr form) ,x))
+              ((eq? (car form) 'struct-set!)
+               `(,(car form) ,(cadr form) ,x ,(cadddr form)))
+              (else
+               (map body-trans form))))
+      `(lambda ,args ,@(map body-trans body)))
+    `(define ,name
+       (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
+         (lambda (n)
+           (if (< n ,num-standard-pre-cache)
+               (vector-ref cache n)
+               ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+
+(define-standard-accessor-method ((bound-check-get n) o)
+  (let ((x (struct-ref o n)))
+    (if (unbound? x)
+        (slot-unbound o)
+        x)))
+
+(define-standard-accessor-method ((standard-get n) o)
+  (struct-ref o n))
+
+(define-standard-accessor-method ((standard-set n) o v)
+  (struct-set! o n v))
 
 ;;; compute-getters-n-setters
 ;;;
-(define (make-thunk thunk)
-  (lambda () (thunk)))
-
-(define (compute-getters-n-setters class slots env)
+(define (compute-getters-n-setters class slots)
 
   (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)))))
+	       (if (thunk? thunk)
+                   thunk
+                   (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+                                name class thunk))))
 	(let ((init (slot-definition-init-value s)))
 	  (and (not (unbound? init))
 	       (lambda () init)))))
@@ -1130,18 +1216,11 @@
 	  (else
 	   (let ((get (car l)) 
 		 (set (cadr l)))
-             ;; note that we allow non-closures; we only check arity on
-             ;; the closures, though, because we inline their dispatch
-             ;; in %get-slot-value / %set-slot-value.
-	     (if (or (not (procedure? get))
-                     (and (closure? get)
-                          (not (= (car (procedure-property get 'arity)) 1))))
-		 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+	     (if (not (procedure? get))
+                 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
 			      slot class get))
-	     (if (or (not (procedure? set))
-                     (and (closure? set)
-                          (not (= (car (procedure-property set 'arity)) 2))))
-		 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+	     (if (not (procedure? set))
+                 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
 			      slot class set))))))
 
   (map (lambda (s)
@@ -1161,12 +1240,20 @@
 	   ;;   '(index size) for instance allocated slots
 	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
-	   (cons name
-		 (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)))))))
+           (case (slot-definition-allocation s)
+             ((#:each-subclass #:class)
+              (unless (and (zero? size) (pair? g-n-s))
+                (error "Class-allocated slots should not reserve fields"))
+              ;; Don't initialize the slot; that's handled when the slot
+              ;; is allocated, in compute-get-n-set.
+              (cons name (cons #f g-n-s)))
+             (else
+              (cons name
+                    (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
@@ -1318,6 +1405,12 @@
 ;;; compute-get-n-set
 ;;;
 (define-method (compute-get-n-set (class <class>) s)
+  (define (class-slot-init-value)
+    (let ((thunk (slot-definition-init-thunk s)))
+      (if thunk
+          (thunk)
+          (slot-definition-init-value s))))
+
   (case (slot-definition-allocation s)
     ((#:instance) ;; Instance slot
      ;; get-n-set is just its offset
@@ -1332,7 +1425,7 @@
      (let ((name (slot-definition-name s)))
        (if (memq name (map slot-definition-name (class-direct-slots class)))
 	   ;; This slot is direct; create a new shared variable
-	   (make-closure-variable class)
+	   (make-closure-variable class (class-slot-init-value))
 	   ;; Slot is inherited. Find its definition in superclass
 	   (let loop ((l (cdr (class-precedence-list class))))
 	     (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
@@ -1342,23 +1435,21 @@
 
     ((#:each-subclass) ;; slot shared by instances of direct subclass.
      ;; (Thomas Buerger, April 1998)
-     (make-closure-variable class))
+     (make-closure-variable class (class-slot-init-value)))
 
     ((#:virtual) ;; No allocation
      ;; slot-ref and slot-set! function must be given by the user
      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
-	   (set (get-keyword #:slot-set! (slot-definition-options s) #f))
-	   (env (class-environment class)))
+	   (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
        (if (not (and get set))
 	   (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
 			s))
        (list get set)))
     (else    (next-method))))
 
-(define (make-closure-variable class)
-  (let ((shared-variable (make-unbound)))
-    (list (lambda (o) shared-variable)
-	  (lambda (o v) (set! shared-variable v)))))
+(define (make-closure-variable class value)
+  (list (lambda (o) value)
+        (lambda (o v) (set! value v))))
 
 (define-method (compute-get-n-set (o <object>) s)
   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
@@ -1376,9 +1467,7 @@
 (define-method (initialize (class <class>) initargs)
   (next-method)
   (let ((dslots (get-keyword #:slots initargs '()))
-	(supers (get-keyword #:dsupers	  initargs '()))
-	(env    (get-keyword #:environment initargs (top-level-env))))
-
+	(supers (get-keyword #:dsupers	  initargs '())))
     (slot-set! class 'name	  	(get-keyword #:name initargs '???))
     (slot-set! class 'direct-supers 	supers)
     (slot-set! class 'direct-slots  	dslots)
@@ -1386,15 +1475,13 @@
     (slot-set! class 'direct-methods    '())
     (slot-set! class 'cpl		(compute-cpl class))
     (slot-set! class 'redefined		#f)
-    (slot-set! class 'environment	env)
     (let ((slots (compute-slots class)))
       (slot-set! class 'slots	  	  slots)
       (slot-set! class 'nfields	  	  0)
       (slot-set! class 'getters-n-setters (compute-getters-n-setters class 
-								     slots 
-								     env))
+								     slots))
       ;; Build getters - setters - accessors
-      (compute-slot-accessors class slots env))
+      (compute-slot-accessors class slots))
 
     ;; Update the "direct-subclasses" of each inherited classes
     (for-each (lambda (x)
@@ -1405,38 +1492,22 @@
 
     ;; Support for the underlying structs:
     
-    ;; Inherit class flags (invisible on scheme level) from supers
-    (%inherit-magic! class supers)
-
     ;; Set the layout slot
-    (%prep-layout! class)))
+    (%prep-layout! class)
+    ;; Inherit class flags (invisible on scheme level) from supers
+    (%inherit-magic! class supers)))
 
 (define (initialize-object-procedure object initargs)
   (let ((proc (get-keyword #:procedure initargs #f)))
     (cond ((not proc))
 	  ((pair? proc)
-	   (apply set-object-procedure! object proc))
-	  ((valid-object-procedure? proc)
-	   (set-object-procedure! object proc))
+	   (apply slot-set! object 'procedure proc))
 	  (else
-	   (set-object-procedure! object
-				  (lambda args (apply proc args)))))))
-
-(define-method (initialize (class <operator-class>) initargs)
-  (next-method)
-  (initialize-object-procedure 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)
-  (next-method)
-  (initialize-object-procedure entity initargs))
+           (slot-set! object 'procedure proc)))))
 
-(define-method (initialize (ews <entity-with-setter>) initargs)
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
   (next-method)
-  (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+  (initialize-object-procedure applicable-struct initargs))
 
 (define-method (initialize (generic <generic>) initargs)
   (let ((previous-definition (get-keyword #:default initargs #f))
@@ -1450,6 +1521,10 @@
 	(set-procedure-property! generic 'name name))
     ))
 
+(define-method (initialize (gws <generic-with-setter>) initargs)
+  (next-method)
+  (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+
 (define-method (initialize (eg <extended-generic>) initargs)
   (next-method)
   (slot-set! eg 'extends (get-keyword #:extends initargs '())))
@@ -1461,15 +1536,12 @@
   (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 dummy-procedure))
-  (slot-set! method 'code-table '())
+	     (get-keyword #:procedure initargs #f))
   (slot-set! method 'formals (get-keyword #:formals initargs '()))
   (slot-set! method 'body (get-keyword #:body initargs '()))
-  (slot-set! method 'compile-env (get-keyword #:compile-env initargs #f)))
+  (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
              
 
-(define-method (initialize (obj <foreign-object>) initargs))
-
 ;;;
 ;;; {Change-class}
 ;;;