summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/goops.c20
-rw-r--r--module/language/tree-il/compile-glil.scm4
-rw-r--r--module/oop/goops.scm22
-rw-r--r--test-suite/tests/goops.test43
4 files changed, 56 insertions, 33 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
index 4a2e24d24..884b4b673 100644
--- 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 e4df6e1bd..7c926f2a9 100644
--- 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 f2f61c58b..b92c82013 100644
--- 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 1705ee811..d8a5ecfad 100644
--- 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))))