guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 83/88: Update (oop goops save) for <slot> objects


From: Andy Wingo
Subject: [Guile-commits] 83/88: Update (oop goops save) for <slot> objects
Date: Fri, 23 Jan 2015 15:26:01 +0000

wingo pushed a commit to branch master
in repository guile.

commit 0b4c068d532a372222d890a4f66e2d47f4de651e
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 19 17:11:21 2015 +0100

    Update (oop goops save) for <slot> objects
    
    * module/oop/goops/describe.scm (describe): Remove commented code.
    * module/oop/goops/save.scm (get-set-for-each, access-for-each): Update
      these hoary routines for the new <slot> universe.
---
 module/oop/goops/describe.scm |   11 +-------
 module/oop/goops/save.scm     |   49 ++++++++++++++++++++---------------------
 2 files changed, 26 insertions(+), 34 deletions(-)

diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index 52eb299..0428b4b 100644
--- a/module/oop/goops/describe.scm
+++ b/module/oop/goops/describe.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software 
Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009, 2015 Free Software 
Foundation, Inc.
 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <address@hidden>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -138,14 +138,7 @@
        (format #t "(No direct method)~%")
        (begin
          (format #t "Class direct methods are:~%")
-         (for-each describe methods))))
-
-;  (format #t "~%Field Initializers ~%    ")
-;  (write (slot-ref x 'initializers)) (newline)
-
-;  (format #t "~%Getters and Setters~%    ")
-;  (write (slot-ref x 'getters-n-setters)) (newline)
-)
+         (for-each describe methods)))))
 
 ;;;
 ;;; Describe for generic functions
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index a4b15ad..20c3b05 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -370,33 +370,32 @@
 ;; Don't export this function!  This is all very temporary.
 ;;
 (define (get-set-for-each proc class)
-  (for-each (lambda (slotdef g-n-s)
-             (let ((g-n-s (cddr g-n-s)))
-               (cond ((integer? g-n-s)
-                      (proc (standard-get g-n-s) (standard-set g-n-s)))
-                     ((not (memq (slot-definition-allocation slotdef)
-                                 '(#:class #:each-subclass)))
-                      (proc (car g-n-s) (cadr g-n-s))))))
-           (class-slots class)
-           (slot-ref class 'getters-n-setters)))
+  (for-each (lambda (slot)
+             (unless (memq (slot-definition-allocation slot)
+                            '(#:class #:each-subclass))
+                (let ((ref (slot-definition-slot-ref slot))
+                      (set (slot-definition-slot-set! slot))
+                      (index (slot-definition-index slot)))
+                  (if ref
+                      (proc ref set)
+                      (proc (standard-get index) (standard-set index))))))
+           (class-slots class)))
 
 (define (access-for-each proc class)
-  (for-each (lambda (slotdef g-n-s)
-             (let ((g-n-s (cddr g-n-s))
-                   (a (slot-definition-accessor slotdef)))
-               (cond ((integer? g-n-s)
-                      (proc (slot-definition-name slotdef)
-                            (and a (generic-function-name a))
-                            (standard-get g-n-s)
-                            (standard-set g-n-s)))
-                     ((not (memq (slot-definition-allocation slotdef)
-                                 '(#:class #:each-subclass)))
-                      (proc (slot-definition-name slotdef)
-                            (and a (generic-function-name a))
-                            (car g-n-s)
-                            (cadr g-n-s))))))
-           (class-slots class)
-           (slot-ref class 'getters-n-setters)))
+  (for-each (lambda (slot)
+              (unless (memq (slot-definition-allocation slot)
+                            '(#:class #:each-subclass))
+                (let ((name (slot-definition-name slot))
+                      (accessor (and=> (slot-definition-accessor slot)
+                                       generic-function-name))
+                      (ref (slot-definition-slot-ref slot))
+                      (set (slot-definition-slot-set! slot))
+                      (index (slot-definition-index slot)))
+                  (if ref
+                      (proc name accessor ref set)
+                      (proc name accessor
+                            (standard-get index) (standard-set index))))))
+           (class-slots class)))
 
 (define-macro (restore class slots . exps)
   "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"



reply via email to

[Prev in Thread] Current Thread [Next in Thread]