mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

GOOPS instance migration implemented in Scheme

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-09-08 10:44:44 +02:00
parent cfe2279fea
commit 95f66b197c
3 changed files with 54 additions and 86 deletions
Download patch file Download diff file Expand all files Collapse all files

29
module/oop/goops.scm
View file

@ -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}
;;;