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

Update (oop goops save) for <slot> objects

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-01-19 17:11:21 +01:00
parent 7c49985fac
commit 0b4c068d53
2 changed files with 26 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/oop/goops/describe.scm
View file

@ -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 <eg@unice.fr>
;;;;
;;;; 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

49
module/oop/goops/save.scm
View file

@ -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 ...)"