1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Conflicts:
	module/oop/goops.scm
This commit is contained in:
Andy Wingo 2015-01-22 14:54:17 +01:00
commit 4247d8e34e
2 changed files with 64 additions and 14 deletions

View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 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
@ -1269,12 +1269,20 @@
;; '(index size) for instance allocated slots
;; '() for other slots
(verify-accessors name g-n-s)
(cons name
(cons (compute-slot-init-function name s)
(if (or (integer? g-n-s)
(zero? size))
g-n-s
(append g-n-s (list index size)))))))
(case (slot-definition-allocation s)
((#:each-subclass #:class)
(unless (and (zero? size) (pair? g-n-s))
(error "Class-allocated slots should not reserve fields"))
;; Don't initialize the slot; that's handled when the slot
;; is allocated, in compute-get-n-set.
(cons name (cons #f g-n-s)))
(else
(cons name
(cons (compute-slot-init-function name s)
(if (or (integer? g-n-s)
(zero? size))
g-n-s
(append g-n-s (list index size)))))))))
slots))
;;; compute-cpl
@ -1426,6 +1434,12 @@
;;; compute-get-n-set
;;;
(define-method (compute-get-n-set (class <class>) s)
(define (class-slot-init-value)
(let ((thunk (slot-definition-init-thunk s)))
(if thunk
(thunk)
(slot-definition-init-value s))))
(case (slot-definition-allocation s)
((#:instance) ;; Instance slot
;; get-n-set is just its offset
@ -1440,7 +1454,7 @@
(let ((name (slot-definition-name s)))
(if (memq name (map slot-definition-name (class-direct-slots class)))
;; This slot is direct; create a new shared variable
(make-closure-variable class)
(make-closure-variable class (class-slot-init-value))
;; Slot is inherited. Find its definition in superclass
(let loop ((l (cdr (class-precedence-list class))))
(let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
@ -1450,7 +1464,7 @@
((#:each-subclass) ;; slot shared by instances of direct subclass.
;; (Thomas Buerger, April 1998)
(make-closure-variable class))
(make-closure-variable class (class-slot-init-value)))
((#:virtual) ;; No allocation
;; slot-ref and slot-set! function must be given by the user
@ -1462,10 +1476,9 @@
(list get set)))
(else (next-method))))
(define (make-closure-variable class)
(let ((shared-variable (make-unbound)))
(list (lambda (o) shared-variable)
(lambda (o v) (set! shared-variable v)))))
(define (make-closure-variable class value)
(list (lambda (o) value)
(lambda (o v) (set! value v))))
(define-method (compute-get-n-set (o <object>) s)
(goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))

View file

@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 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
@ -562,3 +562,40 @@
(pass-if-exception "out of range"
exception:out-of-range
(make <foreign-test> #:a (ash 1 64))))
(with-test-prefix "#:each-subclass"
(let* ((<subclass-allocation-test>
(class ()
(test #:init-value '() #:allocation #:each-subclass)
#:name '<subclass-allocation-test>))
(a (make <subclass-allocation-test>)))
(pass-if-equal '() (slot-ref a 'test))
(let ((b (make <subclass-allocation-test>)))
(pass-if-equal '() (slot-ref b 'test))
(slot-set! a 'test 100)
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
;; #:init-value of the class shouldn't reinitialize slot when
;; instances are allocated.
(make <subclass-allocation-test>)
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(let ((<test-subclass>
(class (<subclass-allocation-test>))))
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(let ((c (make <test-subclass>)))
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(pass-if-equal '() (slot-ref c 'test))
(slot-set! c 'test 200)
(pass-if-equal 200 (slot-ref c 'test))
(make <test-subclass>)
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(pass-if-equal 200 (slot-ref c 'test)))))))