1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00

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.
This commit is contained in:
Andy Wingo 2014-04-27 11:02:35 +02:00
parent fa1a30726d
commit 48ad85fb56
4 changed files with 56 additions and 33 deletions

View file

@ -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. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * 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)) get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{ {
SCM slot_name = SCM_CAR (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))) 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, slot_value = scm_i_get_keyword (tmp,
initargs, initargs,
n_initargs, n_initargs,
SCM_PACK (0), SCM_GOOPS_UNBOUND,
FUNC_NAME); FUNC_NAME);
} }
} }
if (SCM_UNPACK (slot_value)) if (!SCM_GOOPS_UNBOUNDP (slot_value))
/* set slot to provided value */ /* set slot to provided value */
set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value); set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
else 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 */ /* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set); tmp = SCM_CADAR (get_n_set);
if (scm_is_true (tmp)) if (scm_is_true (tmp))
{ set_slot_value (class,
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); obj,
if (SCM_GOOPS_UNBOUNDP (slot_value)) SCM_CAR (get_n_set),
set_slot_value (class, scm_call_0 (tmp));
obj,
SCM_CAR (get_n_set),
scm_call_0 (tmp));
}
} }
} }

View file

@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -113,8 +113,6 @@
(list . list) (list . list)
(vector . vector) (vector . vector)
((class-of . 1) . class-of) ((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
((vector-ref . 2) . vector-ref) ((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set) ((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref) ((variable-ref . 1) . variable-ref)

View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; 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> ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -82,13 +82,7 @@
(eval-when (expand load eval) (eval-when (expand load eval)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! 'class-of) (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!))
;; Then load the rest of GOOPS ;; Then load the rest of GOOPS
(use-modules (oop goops util) (use-modules (oop goops util)
@ -1121,7 +1115,7 @@
(lambda (o) (assert-bound (proc o) o))) (lambda (o) (assert-bound (proc o) o)))
;; the idea is to compile the index into the procedure, for fastest ;; 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) (eval-when (expand load eval)
(define num-standard-pre-cache 20)) (define num-standard-pre-cache 20))
@ -1133,9 +1127,9 @@
(define (make-one x) (define (make-one x)
(define (body-trans form) (define (body-trans form)
(cond ((not (pair? form)) form) (cond ((not (pair? form)) form)
((eq? (car form) '@slot-ref) ((eq? (car form) 'struct-ref)
`(,(car form) ,(cadr form) ,x)) `(,(car form) ,(cadr form) ,x))
((eq? (car form) '@slot-set!) ((eq? (car form) 'struct-set!)
`(,(car form) ,(cadr form) ,x ,(cadddr form))) `(,(car form) ,(cadr form) ,x ,(cadddr form)))
(else (else
(map body-trans form)))) (map body-trans form))))
@ -1148,16 +1142,16 @@
((lambda (,n-var) (lambda ,args ,@body)) n))))))) ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
(define-standard-accessor-method ((bound-check-get n) o) (define-standard-accessor-method ((bound-check-get n) o)
(let ((x (@slot-ref o n))) (let ((x (struct-ref o n)))
(if (unbound? x) (if (unbound? x)
(slot-unbound o) (slot-unbound o)
x))) x)))
(define-standard-accessor-method ((standard-get n) o) (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) (define-standard-accessor-method ((standard-set n) o v)
(@slot-set! o n v)) (struct-set! o n v))
;;; compute-getters-n-setters ;;; compute-getters-n-setters
;;; ;;;

View file

@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -474,9 +474,9 @@
(x bar) (x bar)
(set! (x bar) 2) (set! (x bar) 2)
(equal? (reverse z) (equal? (reverse z)
'(before-ref before-set! 1 before-ref after-ref '(before-set! 1 before-ref after-ref
after-set! 1 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! 2 before-ref after-ref after-set! 2 2)))
(current-module)))) (current-module))))
(use-modules (oop goops composite-slot)) (use-modules (oop goops composite-slot))
@ -527,3 +527,38 @@
exception:no-applicable-method exception:no-applicable-method
(eval '(quxy 1) (eval '(quxy 1)
(current-module)))) (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))))