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.

module/oop/goops.scm

@@ -25,12 +25,14 @@
 ;;;;
 
 (define-module (oop goops)
-  :use-module (srfi srfi-1)
+  #:use-module (srfi srfi-1)
-  :export-syntax (define-class class standard-define-class
+  #: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
+  #: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)
+	   slot-exists? make find-method get-keyword))
-  :no-backtrace)
 
 (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)
+(use-modules (oop goops dispatch))
-	     (oop goops dispatch)
+
-	     (oop goops compile))
+;;;
+;;; 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)
+(define-method (compute-getter-method (class <class>) g-n-s)
-  (let ((init-thunk (cadr slotdef))
+  (let ((name (car g-n-s)))
-	(g-n-s (cddr slotdef)))
     (make <accessor-method>
           #:specializers (list class)
-	  #:procedure (cond ((pair? g-n-s)
+          #:procedure (lambda (o) (slot-ref o name))
-			     (make-generic-bound-check-getter (car g-n-s)))
+          #:slot-definition 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>) g-n-s)
-  (let ((g-n-s (cddr slotdef)))
+  (let ((name (car g-n-s)))
     (make <accessor-method>
       #:specializers (list class <top>)
-	  #:procedure (if (pair? g-n-s)
+      #:procedure (lambda (o v) (slot-set! o name v))
-			  (cadr g-n-s)
+      #:slot-definition g-n-s)))
-			  (standard-set g-n-s))
-	  #:slot-definition slotdef)))
 
 (define (make-generic-bound-check-getter proc)
   (lambda (o) (assert-bound (proc o) o)))

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 internal)
-  :use-module (oop goops util)
+  #:re-export (compute-cmethod))
-  :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)))))

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)

test-suite/tests/goops.test

@@ -599,3 +599,37 @@
           (pass-if-equal 100 (slot-ref a 'test))
           (pass-if-equal 100 (slot-ref b 'test))
           (pass-if-equal 200 (slot-ref c 'test)))))))
+
+(with-test-prefix "accessor slots"
+  (let* ((a-accessor (make-accessor 'a))
+         (b-accessor (make-accessor 'b))
+         (<a> (class ()
+                (a #:init-keyword #:a #:accessor a-accessor)
+                #:name '<a>))
+         (<b> (class ()
+                (b #:init-keyword #:b #:accessor b-accessor)
+                #:name '<b>))
+         (<ab> (class (<a> <b>) #:name '<ab>))
+         (<ba> (class (<b> <a>) #:name '<ba>))
+         (<cab> (class (<ab>)
+                  (a #:init-keyword #:a)
+                  #:name '<cab>))
+         (<cba> (class (<ba>)
+                  (a #:init-keyword #:a)
+                  #:name '<cba>))
+         (a (make <a> #:a 'a))
+         (b (make <b> #:b 'b))
+         (ab (make <ab> #:a 'a #:b 'b))
+         (ba (make <ba> #:a 'a #:b 'b))
+         (cab (make <cab> #:a 'a #:b 'b))
+         (cba (make <cba> #:a 'a #:b 'b)))
+    (pass-if-equal "a accessor on a" 'a (a-accessor a))
+    (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
+    (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
+    (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
+    (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
+    (pass-if-equal "b accessor on a" 'b (b-accessor b))
+    (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
+    (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
+    (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
+    (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))