Fix foreign slot initialization and access

* libguile/goops.c (scm_sys_initialize_object): Refactor initialization
  so that we don't ref uninitialized slots before initializing them.
  This allows foreign slots, whose initial value is 0, to be initialized
  via #:init-form.

* module/oop/goops.scm (@slot-ref, @slot-set!): Remove definitions.
  Change callers to use struct-ref and struct-set!.  slot-ref and
  slot-set! were only marginally more efficient and were much more
  dangerous.  This change allows the standard accessors to work on
  foreign slots; that was not the case before, as the 'u' fields of the
  struct were read as if they were 'p' slots.
* module/language/tree-il/compile-glil.scm (lambda): Remove support for
  compiling @slot-ref/@slot-set!.  These were private to GOOPS.

* test-suite/tests/goops.test ("active-slot"): Update to not expect a
  ref before initialization.
  ("foreign slots"): Add tests.

diff --git a/libguile/goops.c b/libguile/goops.c
index 4a2e24d..884b4b6 100644 (file)
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -659,7 +659,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
        get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
     {
       SCM slot_name  = SCM_CAR (slots);
-      SCM slot_value = SCM_PACK (0);
+      SCM slot_value = SCM_GOOPS_UNBOUND;
 
       if (!scm_is_null (SCM_CDR (slot_name)))
        {
@@ -683,12 +683,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
              slot_value = scm_i_get_keyword (tmp,
                                              initargs,
                                              n_initargs,
-                                             SCM_PACK (0),
+                                             SCM_GOOPS_UNBOUND,
                                              FUNC_NAME);
            }
        }
 
-      if (SCM_UNPACK (slot_value))
+      if (!SCM_GOOPS_UNBOUNDP (slot_value))
        /* set slot to provided value */
        set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
       else
@@ -696,14 +696,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
          /* set slot to its :init-form if it exists */
          tmp = SCM_CADAR (get_n_set);
          if (scm_is_true (tmp))
-           {
-             slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
-             if (SCM_GOOPS_UNBOUNDP (slot_value))
-                set_slot_value (class,
-                                obj,
-                                SCM_CAR (get_n_set),
-                                scm_call_0 (tmp));
-           }
+            set_slot_value (class,
+                            obj,
+                            SCM_CAR (get_n_set),
+                            scm_call_0 (tmp));
        }
     }
 

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e4df6e1..7c926f2 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013,2014 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
@@ -113,8 +113,6 @@
    (list . list)
    (vector . vector)
    ((class-of . 1) . class-of)
-   ((@slot-ref . 2) . slot-ref)
-   ((@slot-set! . 3) . slot-set)
    ((vector-ref . 2) . vector-ref)
    ((vector-set! . 3) . vector-set)
    ((variable-ref . 1) . variable-ref)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f2f61c5..b92c820 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014 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
@@ -82,13 +82,7 @@
 
 (eval-when (expand load eval)
   (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
-  (add-interesting-primitive! 'class-of)
-  (define (@slot-ref o n)
-    (struct-ref o n))
-  (define (@slot-set! o n v)
-    (struct-set! o n v))
-  (add-interesting-primitive! '@slot-ref)
-  (add-interesting-primitive! '@slot-set!))
+  (add-interesting-primitive! 'class-of))
 
 ;; Then load the rest of GOOPS
 (use-modules (oop goops util)
@@ -1121,7 +1115,7 @@
   (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.
+;; lookup.
 
 (eval-when (expand load eval)
   (define num-standard-pre-cache 20))
@@ -1133,9 +1127,9 @@
     (define (make-one x)
       (define (body-trans form)
         (cond ((not (pair? form)) form)
-              ((eq? (car form) '@slot-ref)
+              ((eq? (car form) 'struct-ref)
                `(,(car form) ,(cadr form) ,x))
-              ((eq? (car form) '@slot-set!)
+              ((eq? (car form) 'struct-set!)
                `(,(car form) ,(cadr form) ,x ,(cadddr form)))
               (else
                (map body-trans form))))
@@ -1148,16 +1142,16 @@
                ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
 
 (define-standard-accessor-method ((bound-check-get n) o)
-  (let ((x (@slot-ref o n)))
+  (let ((x (struct-ref o n)))
     (if (unbound? x)
         (slot-unbound o)
         x)))
 
 (define-standard-accessor-method ((standard-get n) o)
-  (@slot-ref o n))
+  (struct-ref o n))
 
 (define-standard-accessor-method ((standard-set n) o v)
-  (@slot-set! o n v))
+  (struct-set! o n v))
 
 ;;; compute-getters-n-setters
 ;;;

diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 1705ee8..d8a5ecf 100644 (file)
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014 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
@@ -474,9 +474,9 @@
             (x bar)
             (set! (x bar) 2)
             (equal? (reverse z)
-                    '(before-ref before-set! 1 before-ref after-ref
-                      after-set! 1 1 before-ref after-ref
-                      before-set! 2 before-ref after-ref after-set! 2 2)))
+                    '(before-set! 1 before-ref after-ref
+                       after-set! 1 1 before-ref after-ref
+                       before-set! 2 before-ref after-ref after-set! 2 2)))
          (current-module))))
 
 (use-modules (oop goops composite-slot))
@@ -527,3 +527,38 @@
                      exception:no-applicable-method
     (eval '(quxy 1)
          (current-module))))
+
+(with-test-prefix "foreign slots"
+  (define-class <foreign-test> ()
+    (a #:init-keyword #:a #:class <foreign-slot>
+       #:accessor test-a)
+    (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
+       #:accessor test-b))
+
+  (pass-if-equal "constructing, no initargs"
+      '(0 3)
+    (let ((x (make <foreign-test>)))
+      (list (slot-ref x 'a)
+            (slot-ref x 'b))))
+
+  (pass-if-equal "constructing, initargs"
+      '(1 2)
+    (let ((x (make <foreign-test> #:a 1 #:b 2)))
+      (list (slot-ref x 'a)
+            (slot-ref x 'b))))
+
+  (pass-if-equal "getters"
+      '(0 3)
+    (let ((x (make <foreign-test>)))
+      (list (test-a x) (test-b x))))
+
+  (pass-if-equal "setters"
+      '(10 20)
+    (let ((x (make <foreign-test>)))
+      (set! (test-a x) 10)
+      (set! (test-b x) 20)
+      (list (test-a x) (test-b x))))
+
+  (pass-if-exception "out of range"
+      exception:out-of-range
+    (make <foreign-test> #:a (ash 1 64))))