summaryrefslogtreecommitdiff
path: root/module/oop
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-09-08 10:44:44 +0200
committerAndy Wingo <wingo@pobox.com>2017-09-14 09:24:50 +0200
commit95f66b197cd756766a404a4f3495627fb6e196e9 (patch)
tree232244d1b4af186339b5a8af58ff2bd0b6bdfe59 /module/oop
parentcfe2279fea0987291bd772c769a204ca33e656b9 (diff)
downloadguile-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.scm29
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}
;;;