Fix accessor struct field inlining

* module/oop/goops/compile.scm: Inline into goops.scm, leaving a
  compatible interface stub behind.

* module/oop/goops/dispatch.scm: Don't import (oop goops compile), to
  break circularities.

* module/oop/goops.scm: Move (oop goops util) include up to the top, and
  import (ice-9 match).
  (compute-cmethod): Move here from compile.scm.  Add a special case for
  accessor methods, so as to fix bug #17355.
  (compute-getter-method, compute-setter-method): #:procedure slot is
  now generic.

* test-suite/tests/goops.test ("accessor slots"): New test.

3 files changed, 74 insertions, 69 deletions

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 9ab1eb22a..486a652c0 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -25,12 +25,14 @@
 ;;;;
 
 (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 (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
@@ -71,8 +73,7 @@
 	   method-specializers method-formals
 	   primitive-generic-generic enable-primitive-generic!
 	   method-procedure accessor-method-slot-definition
-	   slot-exists? make find-method get-keyword)
-  :no-backtrace)
+	   slot-exists? make find-method get-keyword))
 
 (define *goops-module* (current-module))
 
@@ -85,9 +86,56 @@
   (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))))))))
 
 
 (eval-when (expand load eval)
@@ -1089,27 +1137,19 @@
 			     (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)
   (lambda (o) (assert-bound (proc o) o)))
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 8c546e03f..93fdbf76e 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1999, 2001, 2006, 2009, 2015 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,40 +16,6 @@
 ;;;; 
 
 
-;; There are circularities here; you can't import (oop goops compile)
-;; before (oop goops). So when compiling, make sure that things are
-;; kosher.
-(eval-when (expand) (resolve-module '(oop goops)))
-
 (define-module (oop goops compile)
-  :use-module (oop goops)
-  :use-module (oop goops util)
-  :export (compute-cmethod)
-  :no-backtrace
-  )
-
-;;;
-;;; 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)
-  (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
-    (if make-procedure
-        (make-procedure
-         (if (null? (cdr methods))
-             (lambda args
-               (no-next-method (method-generic-function (car methods)) args))
-             (compute-cmethod (cdr methods) types)))
-        (method-procedure (car methods)))))
+  #:use-module (oop goops internal)
+  #:re-export (compute-cmethod))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index 0198a9f40..666597441 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012, 2015 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -24,7 +24,6 @@
 (define-module (oop goops dispatch)
   #:use-module (oop goops)
   #:use-module (oop goops util)
-  #:use-module (oop goops compile)
   #:use-module (system base target)
   #:export (memoize-method!)
   #:no-backtrace)
@@ -251,7 +250,7 @@
           (else
            (parse (1+ n) (cdr ls)))))
   (define (memoize len rest? types)
-    (let* ((cmethod (compute-cmethod applicable types))
+    (let* ((cmethod ((@@ (oop goops) compute-cmethod) applicable types))
            (cache (cons (vector len types rest? cmethod)
                         (slot-ref gf 'effective-methods))))
       (slot-set! gf 'effective-methods cache)