mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +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
parent
fa1a30726d
commit
48ad85fb56
4 changed files with 56 additions and 33 deletions
|
|
@ -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));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue