diff options
author | Andy Wingo <wingo@pobox.com> | 2017-09-08 10:44:44 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-09-14 09:24:50 +0200 |
commit | 95f66b197cd756766a404a4f3495627fb6e196e9 (patch) | |
tree | 232244d1b4af186339b5a8af58ff2bd0b6bdfe59 /module/oop | |
parent | cfe2279fea0987291bd772c769a204ca33e656b9 (diff) | |
download | guile-95f66b197cd756766a404a4f3495627fb6e196e9.tar.gz |
GOOPS instance migration implemented in Scheme
* libguile/goops.c (scm_class_of): Call out directly to the GOOPS-local
`migrate-instance' if an instance needs to migrate.
(scm_sys_struct_data): New internal temporary function used by the
Scheme `migrate-instance'. Exorcise the evil one from the old C
implementation.
* libguile/goops.h (scm_change_object_class): Remove function used only
internally in GOOPS.
* module/oop/goops.scm (migrate-instance): Implement the
hell/purgatory/etc logic in Scheme instead of C.
Diffstat (limited to 'module/oop')
-rw-r--r-- | module/oop/goops.scm | 29 |
1 files changed, 28 insertions, 1 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index c78d0bd3c..48370c68b 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017 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 @@ -27,6 +27,8 @@ (define-module (oop goops) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module ((ice-9 control) #:select (let/ec)) + #:use-module (ice-9 threads) #:use-module ((language tree-il primitives) :select (add-interesting-primitive!)) #:export-syntax (define-class class standard-define-class @@ -2932,6 +2934,31 @@ var{initargs}." (define-method (change-class (old-instance <object>) (new-class <class>)) (change-object-class old-instance (class-of old-instance) new-class)) +(define migrate-instance + (let ((lock (make-mutex)) + (stack '())) + (lambda (instance) + (let ((key (%struct-data instance))) + (let/ec return + (dynamic-wind + (lambda () + (with-mutex lock + (if (memv key stack) + (return #f) + (set! stack (cons key stack))))) + (lambda () + (let* ((old-class (struct-vtable instance)) + (new-class (slot-ref old-class 'redefined))) + ;; Although migrate-indirect-instance-if-needed should + ;; only be called if the "valid" flag is not present on + ;; the old-class, it's possible that multiple threads can + ;; race, so we need to check again here. + (when new-class + (change-class instance new-class)))) + (lambda () + (with-mutex lock + (set! stack (delq! key stack)))))))))) + ;;; ;;; {make} ;;; |