[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 37/88: goops: use computed class slot offsets; untabify
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 37/88: goops: use computed class slot offsets; untabify and fix whitepace |
|
Date: |
Fri, 23 Jan 2015 15:25:37 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 8dfc0ba573a536430897b565e30178484d4652ac
Author: Andy Wingo <address@hidden>
Date: Fri Jan 9 20:07:06 2015 +0100
goops: use computed class slot offsets; untabify and fix whitepace
* module/oop/goops.scm: Untabify and remove trailing whitespace. Change
slot-ref on classes to struct-ref of fixed offsets.
---
module/oop/goops.scm | 867 +++++++++++++++++++++++++-------------------------
1 files changed, 438 insertions(+), 429 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index d00ce67..77c387d 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -97,14 +97,14 @@
make-extended-generic
make-accessor ensure-accessor
add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
+ class-slot-ref class-slot-set! slot-unbound slot-missing
slot-definition-name slot-definition-options
slot-definition-allocation
slot-definition-getter slot-definition-setter
slot-definition-accessor
slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
+ slot-definition-init-thunk slot-definition-init-keyword
slot-init-function class-slot-definition
method-source
compute-cpl compute-std-cpl compute-get-n-set compute-slots
@@ -120,7 +120,7 @@
class-subclasses class-methods
goops-error
min-fixnum max-fixnum
-
+
;;; *fixme* Should go into goops.c
instance? slot-ref-using-class
slot-set-using-class! slot-bound-using-class?
@@ -279,7 +279,8 @@
(lp (cdr slots) res seen))
(else
(lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
- (let* ((class-slots (and (memq <class> cpl) (slot-ref <class> 'slots))))
+ (let* ((class-slots (and (memq <class> cpl)
+ (struct-ref <class> class-index-slots))))
(when class-slots
(check-cpl dslots class-slots))
(let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
@@ -287,7 +288,7 @@
(remove-duplicate-slots (append class-slots res))
(let* ((head (car cpl))
(cpl (cdr cpl))
- (new-slots (slot-ref head 'direct-slots)))
+ (new-slots (struct-ref head class-index-direct-slots)))
(cond
((not class-slots)
(lp cpl (append new-slots res) class-slots))
@@ -351,8 +352,8 @@
(unless (= n nfields) (error "bad nfields"))
(unless (null? slots) (error "inconsistent g-n-s/slots"))
(when is-class?
- (let ((class-layout (symbol->string (slot-ref <class> 'layout))))
- (unless (string-prefix? class-layout layout)
+ (let ((class-layout (struct-ref <class> class-index-layout)))
+ (unless (string-prefix? (symbol->string class-layout) layout)
(error "bad layout for class"))))
layout)
((g-n-s . getters-n-setters)
@@ -375,16 +376,17 @@
(lp n slots getters-n-setters))))))))))
(define (%prep-layout! class)
- (let* ((is-class? (and (memq <class> (slot-ref class 'cpl)) #t))
- (layout (%compute-layout (slot-ref class 'slots)
- (slot-ref class 'getters-n-setters)
- (slot-ref class 'nfields)
- is-class?)))
+ (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
+ (layout (%compute-layout
+ (struct-ref class class-index-slots)
+ (struct-ref class class-index-getters-n-setters)
+ (struct-ref class class-index-nfields)
+ is-class?)))
(%init-layout! class layout)))
(define (make-standard-class class name dsupers dslots)
(let ((z (make-struct/no-tail class)))
- (slot-set! z 'direct-supers dsupers)
+ (struct-set! z class-index-direct-supers dsupers)
(let* ((cpl (compute-cpl z))
(dslots (map (lambda (slot)
(if (pair? slot) slot (list slot)))
@@ -392,18 +394,20 @@
(slots (build-slots-list dslots cpl))
(nfields (length slots))
(g-n-s (%compute-getters-n-setters slots)))
- (slot-set! z 'name name)
- (slot-set! z 'direct-slots dslots)
- (slot-set! z 'direct-subclasses '())
- (slot-set! z 'direct-methods '())
- (slot-set! z 'cpl cpl)
- (slot-set! z 'slots slots)
- (slot-set! z 'nfields nfields)
- (slot-set! z 'getters-n-setters g-n-s)
- (slot-set! z 'redefined #f)
+ (struct-set! z class-index-name name)
+ (struct-set! z class-index-direct-slots dslots)
+ (struct-set! z class-index-direct-subclasses '())
+ (struct-set! z class-index-direct-methods '())
+ (struct-set! z class-index-cpl cpl)
+ (struct-set! z class-index-slots slots)
+ (struct-set! z class-index-nfields nfields)
+ (struct-set! z class-index-getters-n-setters g-n-s)
+ (struct-set! z class-index-redefined #f)
(for-each (lambda (super)
- (let ((subclasses (slot-ref super 'direct-subclasses)))
- (slot-set! super 'direct-subclasses (cons z subclasses))))
+ (let ((subclasses
+ (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (cons z subclasses))))
dsupers)
(%prep-layout! z)
(%inherit-magic! z dsupers)
@@ -432,9 +436,9 @@
;; <top>, <object>, and <class> were partially initialized. Correct
;; them here.
-(slot-set! <object> 'direct-subclasses (list <class>))
-(slot-set! <class> 'direct-supers (list <object>))
-(slot-set! <class> 'cpl (list <class> <object> <top>))
+(struct-set! <object> class-index-direct-subclasses (list <class>))
+(struct-set! <class> class-index-direct-supers (list <object>))
+(struct-set! <class> class-index-cpl (list <class> <object> <top>))
(define-standard-class <foreign-slot> (<top>))
(define-standard-class <protected-slot> (<foreign-slot>))
@@ -460,10 +464,11 @@
(cons (list 'name) tail))
((_ (name class) tail)
(cons (list 'name #:class class) tail)))))
- (let ((dslots (fold-<class>-slots macro-fold-right visit '())))
- (slot-set! <class> 'direct-slots dslots)
- (slot-set! <class> 'slots dslots)
- (slot-set! <class> 'getters-n-setters (%compute-getters-n-setters
dslots))))
+ (let* ((dslots (fold-<class>-slots macro-fold-right visit '()))
+ (g-n-s (%compute-getters-n-setters dslots)))
+ (struct-set! <class> class-index-direct-slots dslots)
+ (struct-set! <class> class-index-slots dslots)
+ (struct-set! <class> class-index-getters-n-setters g-n-s)))
;; Applicables and their classes.
(define-standard-class <procedure-class> (<class>))
@@ -865,13 +870,13 @@
(define (memoize-method! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
- %compute-applicable-methods
- compute-applicable-methods)
- gf args)))
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
(cond (applicable
(memoize-effective-method! gf args applicable))
- (else
- (no-applicable-method gf args)))))
+ (else
+ (no-applicable-method gf args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)
@@ -908,36 +913,36 @@
(let ((table-of-metas '()))
(lambda (meta-supers)
(let ((entry (assoc meta-supers table-of-metas)))
- (if entry
- ;; Found a previously created metaclass
- (cdr entry)
- ;; Create a new meta-class which inherit from "meta-supers"
- (let ((new (make <class> #:dsupers meta-supers
- #:slots '()
- #:name (gensym "metaclass"))))
- (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
- new))))))
+ (if entry
+ ;; Found a previously created metaclass
+ (cdr entry)
+ ;; Create a new meta-class which inherit from "meta-supers"
+ (let ((new (make <class> #:dsupers meta-supers
+ #:slots '()
+ #:name (gensym "metaclass"))))
+ (set! table-of-metas (cons (cons meta-supers new)
table-of-metas))
+ new))))))
(define (ensure-metaclass supers)
(if (null? supers)
<class>
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
- (all-cpls (append-map (lambda (m)
- (cdr (class-precedence-list m)))
+ (all-cpls (append-map (lambda (m)
+ (cdr (class-precedence-list m)))
all-metas))
- (needed-metas '()))
- ;; Find the most specific metaclasses. The new metaclass will be
- ;; a subclass of these.
- (for-each
- (lambda (meta)
- (if (and (not (member meta all-cpls))
- (not (member meta needed-metas)))
- (set! needed-metas (append needed-metas (list meta)))))
- all-metas)
- ;; Now return a subclass of the metaclasses we found.
- (if (null? (cdr needed-metas))
- (car needed-metas) ; If there's only one, just use it.
- (ensure-metaclass-with-supers needed-metas)))))
+ (needed-metas '()))
+ ;; Find the most specific metaclasses. The new metaclass will be
+ ;; a subclass of these.
+ (for-each
+ (lambda (meta)
+ (if (and (not (member meta all-cpls))
+ (not (member meta needed-metas)))
+ (set! needed-metas (append needed-metas (list meta)))))
+ all-metas)
+ ;; Now return a subclass of the metaclasses we found.
+ (if (null? (cdr needed-metas))
+ (car needed-metas) ; If there's only one, just use it.
+ (ensure-metaclass-with-supers needed-metas)))))
;;;
;;; {Classes}
@@ -974,7 +979,7 @@
;; Everything seems correct, build the class
(apply make metaclass
#:dsupers supers
- #:slots slots
+ #:slots slots
#:name name
options)))
@@ -1047,7 +1052,7 @@
#'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
#'(begin out ...)))))
-
+
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
;; which represent accessors exist before `make-class' tries to add
@@ -1065,7 +1070,7 @@
#'(define-class-pre-definitions (rest ...)
out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
- #'(define-class-pre-definitions (rest ...)
+ #'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax-rule (define-class name supers slot ...)
@@ -1077,7 +1082,7 @@
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))
-
+
(define-syntax-rule (standard-define-class arg ...)
(define-class arg ...))
@@ -1125,42 +1130,42 @@
(define* (make-extended-generic gfs #:optional name)
(let* ((gfs (if (list? gfs) gfs (list gfs)))
- (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
+ (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
(let ((ans (if gws?
- (let* ((sname (and name (make-setter-name name)))
- (setters
- (append-map (lambda (gf)
- (if (is-a? gf <generic-with-setter>)
- (list (ensure-generic (setter gf)
- sname))
- '()))
- gfs))
- (es (make <extended-generic-with-setter>
- #:name name
- #:extends gfs
- #:setter (make <extended-generic>
- #:name sname
- #:extends setters))))
- (extended-by! setters (setter es))
- es)
- (make <extended-generic>
- #:name name
- #:extends gfs))))
+ (let* ((sname (and name (make-setter-name name)))
+ (setters
+ (append-map (lambda (gf)
+ (if (is-a? gf <generic-with-setter>)
+ (list (ensure-generic (setter gf)
+ sname))
+ '()))
+ gfs))
+ (es (make <extended-generic-with-setter>
+ #:name name
+ #:extends gfs
+ #:setter (make <extended-generic>
+ #:name sname
+ #:extends setters))))
+ (extended-by! setters (setter es))
+ es)
+ (make <extended-generic>
+ #:name name
+ #:extends gfs))))
(extended-by! gfs ans)
ans)))
(define (extended-by! gfs eg)
(for-each (lambda (gf)
- (slot-set! gf 'extended-by
- (cons eg (slot-ref gf 'extended-by))))
- gfs)
+ (slot-set! gf 'extended-by
+ (cons eg (slot-ref gf 'extended-by))))
+ gfs)
(invalidate-method-cache! eg))
(define (not-extended-by! gfs eg)
(for-each (lambda (gf)
- (slot-set! gf 'extended-by
- (delq! eg (slot-ref gf 'extended-by))))
- gfs)
+ (slot-set! gf 'extended-by
+ (delq! eg (slot-ref gf 'extended-by))))
+ gfs)
(invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional name)
@@ -1214,21 +1219,21 @@
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
- (gws (make (if (is-a? generic <extended-generic>)
- <extended-generic-with-setter>
- <accessor>)
- #:name (generic-function-name generic)
- #:extended-by (slot-ref generic 'extended-by)
- #:setter setter)))
+ (gws (make (if (is-a? generic <extended-generic>)
+ <extended-generic-with-setter>
+ <accessor>)
+ #:name (generic-function-name generic)
+ #:extended-by (slot-ref generic 'extended-by)
+ #:setter setter)))
(if (is-a? generic <extended-generic>)
- (let ((gfs (slot-ref generic 'extends)))
- (not-extended-by! gfs generic)
- (slot-set! gws 'extends gfs)
- (extended-by! gfs gws)))
+ (let ((gfs (slot-ref generic 'extends)))
+ (not-extended-by! gfs generic)
+ (slot-set! gws 'extends gfs)
+ (extended-by! gfs gws)))
;; Steal old methods
(for-each (lambda (method)
- (slot-set! method 'generic-function gws))
- methods)
+ (slot-set! method 'generic-function gws))
+ methods)
(slot-set! gws 'methods methods)
(invalidate-method-cache! gws)
gws))
@@ -1247,9 +1252,9 @@
;;
;; (define-method M (a . l) ....)
;; (define-method M (a) ....)
-;;
+;;
;; we consider that the second method is more specific.
-;;
+;;
;; Precondition: `a' and `b' are methods and are applicable to `types'.
(define (%method-more-specific? a b types)
(let lp ((a-specializers (method-specializers a))
@@ -1439,32 +1444,32 @@
(define (add-method-in-classes! m)
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
- (let ((dm (class-direct-methods x)))
- (if (not (memq m dm))
- (slot-set! x 'direct-methods (cons m dm)))))
- (method-specializers m)))
+ (let ((dm (class-direct-methods x)))
+ (unless (memq m dm)
+ (struct-set! x class-index-direct-methods (cons m dm)))))
+ (method-specializers m)))
(define (remove-method-in-classes! m)
;; Remove method in all the classes which appears in its specializers list
(for-each* (lambda (x)
- (slot-set! x
- 'direct-methods
- (delv! m (class-direct-methods x))))
- (method-specializers m)))
+ (struct-set! x
+ class-index-direct-methods
+ (delv! m (class-direct-methods x))))
+ (method-specializers m)))
(define (compute-new-list-of-methods gf new)
(let ((new-spec (method-specializers new))
- (methods (slot-ref gf 'methods)))
+ (methods (slot-ref gf 'methods)))
(let loop ((l methods))
(if (null? l)
- (cons new methods)
- (if (equal? (method-specializers (car l)) new-spec)
- (begin
- ;; This spec. list already exists. Remove old method from
dependents
- (remove-method-in-classes! (car l))
- (set-car! l new)
- methods)
- (loop (cdr l)))))))
+ (cons new methods)
+ (if (equal? (method-specializers (car l)) new-spec)
+ (begin
+ ;; This spec. list already exists. Remove old method from
dependents
+ (remove-method-in-classes! (car l))
+ (set-car! l new)
+ methods)
+ (loop (cdr l)))))))
(define (method-n-specializers m)
(length* (slot-ref m 'specializers)))
@@ -1495,8 +1500,8 @@
(define-method (add-method! (proc <procedure>) (m <method>))
(if (generic-capability? proc)
(begin
- (enable-primitive-generic! proc)
- (add-method! proc m))
+ (enable-primitive-generic! proc)
+ (add-method! proc m))
(next-method)))
(define-method (add-method! (pg <primitive-generic>) (m <method>))
@@ -1514,7 +1519,7 @@
;;;
(define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers)))
- (src (procedure-source (slot-ref m 'procedure))))
+ (src (procedure-source (slot-ref m 'procedure))))
(and src
(let ((args (cadr src))
(body (cddr src)))
@@ -1561,7 +1566,7 @@
(assq slot-name (class-slots class)))
(define (slot-init-function class slot-name)
- (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+ (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
(define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}."
@@ -1582,7 +1587,7 @@
;; When this generic gets called, we will have already checked eq? and
;; eqv? -- the purpose of this generic is to extend equality. So by
;; default, there is no extension, thus the #f return.
-(add-method! g-equal? (method (x y) #f))
+(add-method! g-equal? (method (x y) #f))
(set-primitive-generic! equal? g-equal?)
;;;
@@ -1590,7 +1595,7 @@
;;;
; Code for writing objects must test that the slots they use are
-; bound. Otherwise a slot-unbound method will be called and will
+; bound. Otherwise a slot-unbound method will be called and will
; conduct to an infinite loop.
;; Write
@@ -1607,66 +1612,66 @@
(define-method (write (o <object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
- (begin
- (display "#<" file)
- (display (class-name class) file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
+ (begin
+ (display "#<" file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address o file)
+ (display #\> file))
+ (next-method))))
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
- (slot-bound? meta 'name))
- (begin
- (display "#<" file)
- (display (class-name meta) file)
- (display #\space file)
- (display (class-name class) file)
- (display #\space file)
- (display-address class file)
- (display #\> file))
- (next-method))))
+ (slot-bound? meta 'name))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (display #\space file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address class file)
+ (display #\> file))
+ (next-method))))
(define-method (write (gf <generic>) file)
(let ((meta (class-of gf)))
(if (and (slot-bound? meta 'name)
- (slot-bound? gf 'methods))
- (begin
- (display "#<" file)
- (display (class-name meta) file)
- (let ((name (generic-function-name gf)))
- (if name
- (begin
- (display #\space file)
- (display name file))))
- (display " (" file)
- (display (length (generic-function-methods gf)) file)
- (display ")>" file))
- (next-method))))
+ (slot-bound? gf 'methods))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (let ((name (generic-function-name gf)))
+ (if name
+ (begin
+ (display #\space file)
+ (display name file))))
+ (display " (" file)
+ (display (length (generic-function-methods gf)) file)
+ (display ")>" file))
+ (next-method))))
(define-method (write (o <method>) file)
(let ((meta (class-of o)))
(if (and (slot-bound? meta 'name)
- (slot-bound? o 'specializers))
- (begin
- (display "#<" file)
- (display (class-name meta) file)
- (display #\space file)
- (display (map* (lambda (spec)
- (if (slot-bound? spec 'name)
- (slot-ref spec 'name)
- spec))
- (method-specializers o))
- file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
+ (slot-bound? o 'specializers))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (display #\space file)
+ (display (map* (lambda (spec)
+ (if (slot-bound? spec 'name)
+ (slot-ref spec 'name)
+ spec))
+ (method-specializers o))
+ file)
+ (display #\space file)
+ (display-address o file)
+ (display #\> file))
+ (next-method))))
;; Display (do the same thing as write by default)
-(define-method (display o file)
+(define-method (display o file)
(write-object o file))
;;;
@@ -1688,65 +1693,65 @@
(define <module> (find-subclass <top> '<module>))
(define-method (merge-generics (module <module>)
- (name <symbol>)
- (int1 <module>)
- (val1 <top>)
- (int2 <module>)
- (val2 <top>)
- (var <top>)
- (val <top>))
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
#f)
(define-method (merge-generics (module <module>)
- (name <symbol>)
- (int1 <module>)
- (val1 <generic>)
- (int2 <module>)
- (val2 <generic>)
- (var <top>)
- (val <boolean>))
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (val <boolean>))
(and (not (eq? val1 val2))
(make-variable (make-extended-generic (list val2 val1) name))))
(define-method (merge-generics (module <module>)
- (name <symbol>)
- (int1 <module>)
- (val1 <generic>)
- (int2 <module>)
- (val2 <generic>)
- (var <top>)
- (gf <extended-generic>))
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (gf <extended-generic>))
(and (not (memq val2 (slot-ref gf 'extends)))
(begin
- (slot-set! gf
- 'extends
- (cons val2 (delq! val2 (slot-ref gf 'extends))))
- (slot-set! val2
- 'extended-by
- (cons gf (delq! gf (slot-ref val2 'extended-by))))
+ (slot-set! gf
+ 'extends
+ (cons val2 (delq! val2 (slot-ref gf 'extends))))
+ (slot-set! val2
+ 'extended-by
+ (cons gf (delq! gf (slot-ref val2 'extended-by))))
(invalidate-method-cache! gf)
- var)))
+ var)))
(module-define! duplicate-handlers 'merge-generics merge-generics)
(define-method (merge-accessors (module <module>)
- (name <symbol>)
- (int1 <module>)
- (val1 <top>)
- (int2 <module>)
- (val2 <top>)
- (var <top>)
- (val <top>))
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
#f)
(define-method (merge-accessors (module <module>)
- (name <symbol>)
- (int1 <module>)
- (val1 <accessor>)
- (int2 <module>)
- (val2 <accessor>)
- (var <top>)
- (val <top>))
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <accessor>)
+ (int2 <module>)
+ (val2 <accessor>)
+ (var <top>)
+ (val <top>))
(merge-generics module name int1 val1 int2 val2 var val))
(module-define! duplicate-handlers 'merge-accessors merge-accessors)
@@ -1756,19 +1761,20 @@
;;;
(define (class-slot-g-n-s class slot-name)
- (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
- (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
- (slot-missing class slot-name)))))
+ (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
+ (getters-n-setters (struct-ref class class-index-getters-n-setters))
+ (g-n-s (cddr (or (assq slot-name getters-n-setters)
+ (slot-missing class slot-name)))))
(if (not (memq (slot-definition-allocation this-slot)
- '(#:class #:each-subclass)))
- (slot-missing class slot-name))
+ '(#:class #:each-subclass)))
+ (slot-missing class slot-name))
g-n-s))
(define (class-slot-ref class slot)
(let ((x ((car (class-slot-g-n-s class slot)) #f)))
(if (unbound? x)
- (slot-unbound class slot)
- x)))
+ (slot-unbound class slot)
+ x)))
(define (class-slot-set! class slot value)
((cadr (class-slot-g-n-s class slot)) #f value))
@@ -1784,10 +1790,10 @@
(define-method (slot-missing (c <class>) (o <object>) s)
(goops-error "No slot with name `~S' in object ~S" s o))
-
+
(define-method (slot-missing (c <class>) s)
(goops-error "No class slot with name `~S' in class ~S" s c))
-
+
(define-method (slot-missing (c <class>) (o <object>) s value)
(slot-missing c o s))
@@ -1799,7 +1805,7 @@
(define-method (no-applicable-method (gf <generic>) args)
(goops-error "No applicable method for ~S in call ~S"
- gf (cons (generic-function-name gf) args)))
+ gf (cons (generic-function-name gf) args)))
(define-method (no-method (gf <generic>) args)
(goops-error "No method defined for ~S" gf))
@@ -1810,26 +1816,26 @@
(define-method (shallow-clone (self <object>))
(let ((clone (%allocate-instance (class-of self) '()))
- (slots (map slot-definition-name
- (class-slots (class-of self)))))
+ (slots (map slot-definition-name
+ (class-slots (class-of self)))))
(for-each (lambda (slot)
- (if (slot-bound? self slot)
- (slot-set! clone slot (slot-ref self slot))))
- slots)
+ (if (slot-bound? self slot)
+ (slot-set! clone slot (slot-ref self slot))))
+ slots)
clone))
(define-method (deep-clone (self <object>))
(let ((clone (%allocate-instance (class-of self) '()))
- (slots (map slot-definition-name
- (class-slots (class-of self)))))
+ (slots (map slot-definition-name
+ (class-slots (class-of self)))))
(for-each (lambda (slot)
- (if (slot-bound? self slot)
- (slot-set! clone slot
- (let ((value (slot-ref self slot)))
- (if (instance? value)
- (deep-clone value)
- value)))))
- slots)
+ (if (slot-bound? self slot)
+ (slot-set! clone slot
+ (let ((value (slot-ref self slot)))
+ (if (instance? value)
+ (deep-clone value)
+ value)))))
+ slots)
clone))
;;;
@@ -1842,42 +1848,42 @@
;;; Has correct the following conditions:
;;; Methods
-;;;
+;;;
;;; 1. New accessor specializers refer to new header
-;;;
+;;;
;;; Classes
-;;;
+;;;
;;; 1. New class cpl refers to the new class header
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists
(define-method (class-redefinition (old <class>) (new <class>))
;; Work on direct methods:
- ;; 1. Remove accessor methods from the old class
- ;; 2. Patch the occurences of new in the specializers by old
- ;; 3. Displace the methods from old to new
- (remove-class-accessors! old) ;; -1-
+ ;; 1. Remove accessor methods from the old class
+ ;; 2. Patch the occurences of new in the specializers by old
+ ;; 3. Displace the methods from old to new
+ (remove-class-accessors! old) ;; -1-
(let ((methods (class-direct-methods new)))
(for-each (lambda (m)
- (update-direct-method! m new old)) ;; -2-
+ (update-direct-method! m new old)) ;; -2-
methods)
- (slot-set! new
- 'direct-methods
- (append methods (class-direct-methods old))))
+ (struct-set! new
+ class-index-direct-methods
+ (append methods (class-direct-methods old))))
;; Substitute old for new in new cpl
- (set-car! (slot-ref new 'cpl) old)
-
+ (set-car! (struct-ref new class-index-cpl) old)
+
;; Remove the old class from the direct-subclasses list of its super classes
- (for-each (lambda (c) (slot-set! c 'direct-subclasses
- (delv! old (class-direct-subclasses c))))
- (class-direct-supers old))
+ (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
+ (delv! old (class-direct-subclasses c))))
+ (class-direct-supers old))
;; Replace the new class with the old in the direct-subclasses of the supers
(for-each (lambda (c)
- (slot-set! c 'direct-subclasses
- (cons old (delv! new (class-direct-subclasses c)))))
- (class-direct-supers new))
+ (struct-set! c class-index-direct-subclasses
+ (cons old (delv! new (class-direct-subclasses c)))))
+ (class-direct-supers new))
;; Swap object headers
(%modify-class old new)
@@ -1885,14 +1891,14 @@
;; Now old is NEW!
;; Redefine all the subclasses of old to take into account modification
- (for-each
- (lambda (c)
- (update-direct-subclass! c new old))
- (class-direct-subclasses new))
+ (for-each
+ (lambda (c)
+ (update-direct-subclass! c new old))
+ (class-direct-subclasses new))
;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class
- (slot-set! new 'redefined old)
+ (struct-set! new class-index-redefined old)
(%invalidate-class new) ;must come after slot-set!
old)
@@ -1903,44 +1909,44 @@
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
- (if (is-a? m <accessor-method>)
- (let ((gf (slot-ref m 'generic-function)))
- ;; remove the method from its GF
- (slot-set! gf 'methods
- (delq1! m (slot-ref gf 'methods)))
- (invalidate-method-cache! gf)
- ;; remove the method from its specializers
- (remove-method-in-classes! m))))
- (class-direct-methods c)))
+ (if (is-a? m <accessor-method>)
+ (let ((gf (slot-ref m 'generic-function)))
+ ;; remove the method from its GF
+ (slot-set! gf 'methods
+ (delq1! m (slot-ref gf 'methods)))
+ (invalidate-method-cache! gf)
+ ;; remove the method from its specializers
+ (remove-method-in-classes! m))))
+ (class-direct-methods c)))
;;;
;;; update-direct-method!
;;;
(define-method (update-direct-method! (m <method>)
- (old <class>)
- (new <class>))
+ (old <class>)
+ (new <class>))
(let loop ((l (method-specializers m)))
- ;; Note: the <top> in dotted list is never used.
+ ;; Note: the <top> in dotted list is never used.
;; So we can work as if we had only proper lists.
- (if (pair? l)
- (begin
- (if (eqv? (car l) old)
- (set-car! l new))
- (loop (cdr l))))))
+ (if (pair? l)
+ (begin
+ (if (eqv? (car l) old)
+ (set-car! l new))
+ (loop (cdr l))))))
;;;
;;; update-direct-subclass!
;;;
(define-method (update-direct-subclass! (c <class>)
- (old <class>)
- (new <class>))
+ (old <class>)
+ (new <class>))
(class-redefinition c
- (make-class (class-direct-supers c)
- (class-direct-slots c)
- #:name (class-name c)
- #:metaclass (class-of c))))
+ (make-class (class-direct-supers c)
+ (class-direct-slots c)
+ #:name (class-name c)
+ #:metaclass (class-of c))))
;;;
;;; {Utilities for INITIALIZE methods}
@@ -1951,44 +1957,44 @@
(define (compute-slot-accessors class slots)
(for-each
(lambda (s g-n-s)
- (let ((getter-function (slot-definition-getter s))
- (setter-function (slot-definition-setter s))
- (accessor (slot-definition-accessor s)))
- (if getter-function
- (add-method! getter-function
- (compute-getter-method class g-n-s)))
- (if setter-function
- (add-method! setter-function
- (compute-setter-method class g-n-s)))
- (if accessor
- (begin
- (add-method! accessor
- (compute-getter-method class g-n-s))
- (add-method! (setter accessor)
- (compute-setter-method class g-n-s))))))
- slots (slot-ref class 'getters-n-setters)))
+ (let ((getter-function (slot-definition-getter s))
+ (setter-function (slot-definition-setter s))
+ (accessor (slot-definition-accessor s)))
+ (if getter-function
+ (add-method! getter-function
+ (compute-getter-method class g-n-s)))
+ (if setter-function
+ (add-method! setter-function
+ (compute-setter-method class g-n-s)))
+ (if accessor
+ (begin
+ (add-method! accessor
+ (compute-getter-method class g-n-s))
+ (add-method! (setter accessor)
+ (compute-setter-method class g-n-s))))))
+ slots (struct-ref class class-index-getters-n-setters)))
(define-method (compute-getter-method (class <class>) slotdef)
(let ((init-thunk (cadr slotdef))
- (g-n-s (cddr slotdef)))
+ (g-n-s (cddr slotdef)))
(make <accessor-method>
#:specializers (list class)
- #:procedure (cond ((pair? g-n-s)
- (make-generic-bound-check-getter (car g-n-s)))
- (init-thunk
- (standard-get g-n-s))
- (else
- (bound-check-get g-n-s)))
- #:slot-definition slotdef)))
+ #:procedure (cond ((pair? g-n-s)
+ (make-generic-bound-check-getter (car g-n-s)))
+ (init-thunk
+ (standard-get g-n-s))
+ (else
+ (bound-check-get g-n-s)))
+ #:slot-definition slotdef)))
(define-method (compute-setter-method (class <class>) slotdef)
(let ((g-n-s (cddr slotdef)))
(make <accessor-method>
#:specializers (list class <top>)
- #:procedure (if (pair? g-n-s)
- (cadr g-n-s)
- (standard-set g-n-s))
- #:slot-definition slotdef)))
+ #:procedure (if (pair? g-n-s)
+ (cadr g-n-s)
+ (standard-set g-n-s))
+ #:slot-definition slotdef)))
(define (make-generic-bound-check-getter proc)
(lambda (o)
@@ -2032,47 +2038,47 @@
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
- (and thunk
- (if (thunk? thunk)
+ (and thunk
+ (if (thunk? thunk)
thunk
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
name class thunk))))
- (let ((init (slot-definition-init-value s)))
- (and (not (unbound? init))
- (lambda () init)))))
+ (let ((init (slot-definition-init-value s)))
+ (and (not (unbound? init))
+ (lambda () init)))))
(define (verify-accessors slot l)
(cond ((integer? l))
- ((not (and (list? l) (= (length l) 2)))
- (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
- slot class l))
- (else
- (let ((get (car l))
- (set (cadr l)))
- (if (not (procedure? get))
+ ((not (and (list? l) (= (length l) 2)))
+ (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+ slot class l))
+ (else
+ (let ((get (car l))
+ (set (cadr l)))
+ (if (not (procedure? get))
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
- slot class get))
- (if (not (procedure? set))
+ slot class get))
+ (if (not (procedure? set))
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
- slot class set))))))
+ slot class set))))))
(map (lambda (s)
- ;; The strange treatment of nfields is due to backward compatibility.
- (let* ((index (slot-ref class 'nfields))
- (g-n-s (compute-get-n-set class s))
- (size (- (slot-ref class 'nfields) index))
- (name (slot-definition-name s)))
- ;; NOTE: The following is interdependent with C macros
- ;; defined above goops.c:scm_sys_prep_layout_x.
- ;;
- ;; For simple instance slots, we have the simplest form
- ;; '(name init-function . index)
- ;; For other slots we have
- ;; '(name init-function getter setter . alloc)
- ;; where alloc is:
- ;; '(index size) for instance allocated slots
- ;; '() for other slots
- (verify-accessors name g-n-s)
+ ;; The strange treatment of nfields is due to backward compatibility.
+ (let* ((index (slot-ref class 'nfields))
+ (g-n-s (compute-get-n-set class s))
+ (size (- (slot-ref class 'nfields) index))
+ (name (slot-definition-name s)))
+ ;; NOTE: The following is interdependent with C macros
+ ;; defined above goops.c:scm_sys_prep_layout_x.
+ ;;
+ ;; For simple instance slots, we have the simplest form
+ ;; '(name init-function . index)
+ ;; For other slots we have
+ ;; '(name init-function getter setter . alloc)
+ ;; where alloc is:
+ ;; '(index size) for instance allocated slots
+ ;; '() for other slots
+ (verify-accessors name g-n-s)
(case (slot-definition-allocation s)
((#:each-subclass #:class)
(unless (and (zero? size) (pair? g-n-s))
@@ -2111,24 +2117,26 @@
(case (slot-definition-allocation s)
((#:instance) ;; Instance slot
;; get-n-set is just its offset
- (let ((already-allocated (slot-ref class 'nfields)))
- (slot-set! class 'nfields (+ already-allocated 1))
+ (let ((already-allocated (struct-ref class class-index-nfields)))
+ (struct-set! class class-index-nfields (+ already-allocated 1))
already-allocated))
((#:class) ;; Class slot
- ;; Class-slots accessors are implemented as 2 closures around
+ ;; Class-slots accessors are implemented as 2 closures around
;; a Scheme variable. As instance slots, class slots must be
;; unbound at init time.
(let ((name (slot-definition-name s)))
(if (memq name (map slot-definition-name (class-direct-slots class)))
- ;; This slot is direct; create a new shared variable
- (make-closure-variable class (class-slot-init-value))
- ;; Slot is inherited. Find its definition in superclass
- (let loop ((l (cdr (class-precedence-list class))))
- (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
- (if r
- (cddr r)
- (loop (cdr l))))))))
+ ;; This slot is direct; create a new shared variable
+ (make-closure-variable class (class-slot-init-value))
+ ;; Slot is inherited. Find its definition in superclass
+ (let loop ((l (cdr (class-precedence-list class))))
+ (let ((r (assoc name
+ (struct-ref (car l)
+ class-index-getters-n-setters))))
+ (if r
+ (cddr r)
+ (loop (cdr l))))))))
((#:each-subclass) ;; slot shared by instances of direct subclass.
;; (Thomas Buerger, April 1998)
@@ -2137,10 +2145,10 @@
((#:virtual) ;; No allocation
;; slot-ref and slot-set! function must be given by the user
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
- (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
+ (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
(if (not (and get set))
- (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
- s))
+ (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
+ s))
(list get set)))
(else (next-method))))
@@ -2165,31 +2173,32 @@
(define-method (initialize (class <class>) initargs)
(next-method)
(let ((dslots (get-keyword #:slots initargs '()))
- (supers (get-keyword #:dsupers initargs '())))
- (slot-set! class 'name (get-keyword #:name initargs '???))
- (slot-set! class 'direct-supers supers)
- (slot-set! class 'direct-slots dslots)
- (slot-set! class 'direct-subclasses '())
- (slot-set! class 'direct-methods '())
- (slot-set! class 'cpl (compute-cpl class))
- (slot-set! class 'redefined #f)
+ (supers (get-keyword #:dsupers initargs '())))
+ (let ((name (get-keyword #:name initargs '???)))
+ (struct-set! class class-index-name name))
+ (struct-set! class class-index-direct-supers supers)
+ (struct-set! class class-index-direct-slots dslots)
+ (struct-set! class class-index-direct-subclasses '())
+ (struct-set! class class-index-direct-methods '())
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (struct-set! class class-index-redefined #f)
(let ((slots (compute-slots class)))
- (slot-set! class 'slots slots)
- (slot-set! class 'nfields 0)
- (slot-set! class 'getters-n-setters (compute-getters-n-setters class
- slots))
+ (struct-set! class class-index-slots slots)
+ (struct-set! class class-index-nfields 0)
+ (let ((getters-n-setters (compute-getters-n-setters class slots)))
+ (struct-set! class class-index-getters-n-setters getters-n-setters))
;; Build getters - setters - accessors
(compute-slot-accessors class slots))
;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x)
- (slot-set! x
- 'direct-subclasses
- (cons class (slot-ref x 'direct-subclasses))))
- supers)
+ (let ((dsubs (struct-ref x class-index-direct-subclasses)))
+ (struct-set! x class-index-direct-subclasses
+ (cons class dsubs))))
+ supers)
;; Support for the underlying structs:
-
+
;; Set the layout slot
(%prep-layout! class)
;; Inherit class flags (invisible on scheme level) from supers
@@ -2198,9 +2207,9 @@
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(cond ((not proc))
- ((pair? proc)
- (apply slot-set! object 'procedure proc))
- (else
+ ((pair? proc)
+ (apply slot-set! object 'procedure proc))
+ (else
(slot-set! object 'procedure proc)))))
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
@@ -2214,14 +2223,14 @@
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
- (name (get-keyword #:name initargs #f)))
+ (name (get-keyword #:name initargs #f)))
(next-method)
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
- (list (method args
+ (list (method args
(apply previous-definition args)))
- '()))
+ '()))
(if name
- (set-procedure-property! generic 'name name))
+ (set-procedure-property! generic 'name name))
(invalidate-method-cache! generic)))
(define-method (initialize (eg <extended-generic>) initargs)
@@ -2235,11 +2244,11 @@
(slot-set! method 'generic-function (get-keyword #:generic-function initargs
#f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
- (get-keyword #:procedure initargs #f))
+ (get-keyword #:procedure initargs #f))
(slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'body (get-keyword #:body initargs '()))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs
#f)))
-
+
;;;
;;; {Change-class}
@@ -2249,26 +2258,26 @@
(let ((new-instance (allocate-instance new-class '())))
;; Initialize the slots of the new instance
(for-each (lambda (slot)
- (if (and (slot-exists-using-class? old-class old-instance slot)
- (eq? (slot-definition-allocation
- (class-slot-definition old-class slot))
- #:instance)
- (slot-bound-using-class? old-class old-instance slot))
- ;; Slot was present and allocated in old instance; copy it
- (slot-set-using-class!
- new-class
- new-instance
- slot
- (slot-ref-using-class old-class old-instance slot))
- ;; slot was absent; initialize it with its default value
- (let ((init (slot-init-function new-class slot)))
- (if init
- (slot-set-using-class!
- new-class
- new-instance
- slot
- (apply init '()))))))
- (map slot-definition-name (class-slots new-class)))
+ (if (and (slot-exists-using-class? old-class old-instance slot)
+ (eq? (slot-definition-allocation
+ (class-slot-definition old-class slot))
+ #:instance)
+ (slot-bound-using-class? old-class old-instance slot))
+ ;; Slot was present and allocated in old instance; copy it
+ (slot-set-using-class!
+ new-class
+ new-instance
+ slot
+ (slot-ref-using-class old-class old-instance slot))
+ ;; slot was absent; initialize it with its default value
+ (let ((init (slot-init-function new-class slot)))
+ (if init
+ (slot-set-using-class!
+ new-class
+ new-instance
+ slot
+ (apply init '()))))))
+ (map slot-definition-name (class-slots new-class)))
;; Exchange old and new instance in place to keep pointers valid
(%modify-instance old-instance new-instance)
;; Allow class specific updates of instances (which now are swapped)
@@ -2277,8 +2286,8 @@
(define-method (update-instance-for-different-class (old-instance <object>)
- (new-instance
- <object>))
+ (new-instance
+ <object>))
;;not really important what we do, we just need a default method
new-instance)
@@ -2320,8 +2329,8 @@
(no-method gf args))
(let ((methods (compute-applicable-methods gf args)))
(if methods
- (apply-methods gf (sort-applicable-methods gf methods args) args)
- (no-applicable-method gf args))))
+ (apply-methods gf (sort-applicable-methods gf methods args) args)
+ (no-applicable-method gf args))))
;; compute-applicable-methods is bound to %compute-applicable-methods.
;; *fixme* use let
@@ -2341,27 +2350,27 @@
(define-method (apply-method (gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
- (build-next (cdr methods) args)
- args))
+ (build-next (cdr methods) args)
+ args))
(define-method (apply-methods (gf <generic>) (l <list>) args)
(letrec ((next (lambda (procs args)
- (lambda new-args
- (let ((a (if (null? new-args) args new-args)))
- (if (null? procs)
- (no-next-method gf a)
- (apply-method gf procs next a)))))))
+ (lambda new-args
+ (let ((a (if (null? new-args) args new-args)))
+ (if (null? procs)
+ (no-next-method gf a)
+ (apply-method gf procs next a)))))))
(apply-method gf l next args)))
;; We don't want the following procedure to turn up in backtraces:
(for-each (lambda (proc)
- (set-procedure-property! proc 'system-procedure #t))
- (list slot-unbound
- slot-missing
- no-next-method
- no-applicable-method
- no-method
- ))
+ (set-procedure-property! proc 'system-procedure #t))
+ (list slot-unbound
+ slot-missing
+ no-next-method
+ no-applicable-method
+ no-method
+ ))
;;;
;;; {<composite-metaclass> and <active-metaclass>}
@@ -2380,23 +2389,23 @@
;; duplicate the standard list->set function but using eq instead of
;; eqv which really sucks a lot, uselessly here
;;
-(define (list2set l)
+(define (list2set l)
(let loop ((l l)
- (res '()))
- (cond
+ (res '()))
+ (cond
((null? l) res)
((memq (car l) res) (loop (cdr l) res))
(else (loop (cdr l) (cons (car l) res))))))
(define (class-subclasses c)
(letrec ((allsubs (lambda (c)
- (cons c (mapappend allsubs
- (class-direct-subclasses c))))))
+ (cons c (mapappend allsubs
+ (class-direct-subclasses c))))))
(list2set (cdr (allsubs c)))))
(define (class-methods c)
(list2set (mapappend class-direct-methods
- (cons c (class-subclasses c)))))
+ (cons c (class-subclasses c)))))
;;;
;;; {Final initialization}
- [Guile-commits] 26/88: Deprecate C exports of GOOPS classes., (continued)
- [Guile-commits] 26/88: Deprecate C exports of GOOPS classes., Andy Wingo, 2015/01/23
- [Guile-commits] 41/88: Goops slot-unbound / slot-missing cleanups, Andy Wingo, 2015/01/23
- [Guile-commits] 40/88: Move slot-ref et al to Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 44/88: No more concept of "pure generics", Andy Wingo, 2015/01/23
- [Guile-commits] 45/88: Remove scm_c_extend_primitive_generic, Andy Wingo, 2015/01/23
- [Guile-commits] 47/88: Rewrite %initialize-object in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 48/88: Deprecate scm_get_keyword, Andy Wingo, 2015/01/23
- [Guile-commits] 43/88: Remove TEST_CHANGE_CLASS, Andy Wingo, 2015/01/23
- [Guile-commits] 42/88: Remove pure-generic?, Andy Wingo, 2015/01/23
- [Guile-commits] 46/88: Minor goops.c tidying, Andy Wingo, 2015/01/23
- [Guile-commits] 37/88: goops: use computed class slot offsets; untabify and fix whitepace,
Andy Wingo <=
- [Guile-commits] 50/88: Re-use the vtable "size" field for GOOPS nfields, Andy Wingo, 2015/01/23
- [Guile-commits] 52/88: Reimplement inherit-applicable! in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 54/88: Incorporate %inherit-magic! into %init-layout!, Andy Wingo, 2015/01/23
- [Guile-commits] 49/88: Move <class> initialization to Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 56/88: GOOPS cleanup to use SRFI-1 better, Andy Wingo, 2015/01/23
- [Guile-commits] 57/88: append-map rather than mapappend, Andy Wingo, 2015/01/23
- [Guile-commits] 58/88: GOOPS utils module cleanups, Andy Wingo, 2015/01/23
- [Guile-commits] 55/88: Cosmetic goops refactors., Andy Wingo, 2015/01/23
- [Guile-commits] 53/88: goops.c no longer knows about <class> slot allocation, Andy Wingo, 2015/01/23
- [Guile-commits] 61/88: scm_make cleanup, Andy Wingo, 2015/01/23