mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

goops: use computed class slot offsets; untabify and fix whitepace

Browse source 
* module/oop/goops.scm: Untabify and remove trailing whitespace.  Change
  slot-ref on classes to struct-ref of fixed offsets.
This commit is contained in:
Andy Wingo 2015-01-09 20:07:06 +01:00
parent ebca094b50
commit 8dfc0ba573
1 changed files with 438 additions and 429 deletions
Download patch file Download diff file Expand all files Collapse all files

125
module/oop/goops.scm
View file

@ -279,7 +279,8 @@
(lp (cdr slots) res seen)) (lp (cdr slots) res seen))
(else (else
(lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen)))))) (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 (when class-slots
(check-cpl dslots class-slots)) (check-cpl dslots class-slots))
(let lp ((cpl (cdr cpl)) (res dslots) (class-slots '())) (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
@ -287,7 +288,7 @@
(remove-duplicate-slots (append class-slots res)) (remove-duplicate-slots (append class-slots res))
(let* ((head (car cpl)) (let* ((head (car cpl))
(cpl (cdr cpl)) (cpl (cdr cpl))
(new-slots (slot-ref head 'direct-slots))) (new-slots (struct-ref head class-index-direct-slots)))
(cond (cond
((not class-slots) ((not class-slots)
(lp cpl (append new-slots res) class-slots)) (lp cpl (append new-slots res) class-slots))
@ -351,8 +352,8 @@
(unless (= n nfields) (error "bad nfields")) (unless (= n nfields) (error "bad nfields"))
(unless (null? slots) (error "inconsistent g-n-s/slots")) (unless (null? slots) (error "inconsistent g-n-s/slots"))
(when is-class? (when is-class?
(let ((class-layout (symbol->string (slot-ref <class> 'layout)))) (let ((class-layout (struct-ref <class> class-index-layout)))
(unless (string-prefix? class-layout layout) (unless (string-prefix? (symbol->string class-layout) layout)
(error "bad layout for class")))) (error "bad layout for class"))))
layout) layout)
((g-n-s . getters-n-setters) ((g-n-s . getters-n-setters)
@ -375,16 +376,17 @@
(lp n slots getters-n-setters)))))))))) (lp n slots getters-n-setters))))))))))
(define (%prep-layout! class) (define (%prep-layout! class)
(let* ((is-class? (and (memq <class> (slot-ref class 'cpl)) #t)) (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
(layout (%compute-layout (slot-ref class 'slots) (layout (%compute-layout
(slot-ref class 'getters-n-setters) (struct-ref class class-index-slots)
(slot-ref class 'nfields) (struct-ref class class-index-getters-n-setters)
(struct-ref class class-index-nfields)
is-class?))) is-class?)))
(%init-layout! class layout))) (%init-layout! class layout)))
(define (make-standard-class class name dsupers dslots) (define (make-standard-class class name dsupers dslots)
(let ((z (make-struct/no-tail class))) (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)) (let* ((cpl (compute-cpl z))
(dslots (map (lambda (slot) (dslots (map (lambda (slot)
(if (pair? slot) slot (list slot))) (if (pair? slot) slot (list slot)))
@ -392,18 +394,20 @@
(slots (build-slots-list dslots cpl)) (slots (build-slots-list dslots cpl))
(nfields (length slots)) (nfields (length slots))
(g-n-s (%compute-getters-n-setters slots))) (g-n-s (%compute-getters-n-setters slots)))
(slot-set! z 'name name) (struct-set! z class-index-name name)
(slot-set! z 'direct-slots dslots) (struct-set! z class-index-direct-slots dslots)
(slot-set! z 'direct-subclasses '()) (struct-set! z class-index-direct-subclasses '())
(slot-set! z 'direct-methods '()) (struct-set! z class-index-direct-methods '())
(slot-set! z 'cpl cpl) (struct-set! z class-index-cpl cpl)
(slot-set! z 'slots slots) (struct-set! z class-index-slots slots)
(slot-set! z 'nfields nfields) (struct-set! z class-index-nfields nfields)
(slot-set! z 'getters-n-setters g-n-s) (struct-set! z class-index-getters-n-setters g-n-s)
(slot-set! z 'redefined #f) (struct-set! z class-index-redefined #f)
(for-each (lambda (super) (for-each (lambda (super)
(let ((subclasses (slot-ref super 'direct-subclasses))) (let ((subclasses
(slot-set! super 'direct-subclasses (cons z subclasses)))) (struct-ref super class-index-direct-subclasses)))
(struct-set! super class-index-direct-subclasses
(cons z subclasses))))
dsupers) dsupers)
(%prep-layout! z) (%prep-layout! z)
(%inherit-magic! z dsupers) (%inherit-magic! z dsupers)
@ -432,9 +436,9 @@
;; <top>, <object>, and <class> were partially initialized. Correct ;; <top>, <object>, and <class> were partially initialized. Correct
;; them here. ;; them here.
(slot-set! <object> 'direct-subclasses (list <class>)) (struct-set! <object> class-index-direct-subclasses (list <class>))
(slot-set! <class> 'direct-supers (list <object>)) (struct-set! <class> class-index-direct-supers (list <object>))
(slot-set! <class> 'cpl (list <class> <object> <top>)) (struct-set! <class> class-index-cpl (list <class> <object> <top>))
(define-standard-class <foreign-slot> (<top>)) (define-standard-class <foreign-slot> (<top>))
(define-standard-class <protected-slot> (<foreign-slot>)) (define-standard-class <protected-slot> (<foreign-slot>))
@ -460,10 +464,11 @@
(cons (list 'name) tail)) (cons (list 'name) tail))
((_ (name class) tail) ((_ (name class) tail)
(cons (list 'name #:class class) tail))))) (cons (list 'name #:class class) tail)))))
(let ((dslots (fold-<class>-slots macro-fold-right visit '()))) (let* ((dslots (fold-<class>-slots macro-fold-right visit '()))
(slot-set! <class> 'direct-slots dslots) (g-n-s (%compute-getters-n-setters dslots)))
(slot-set! <class> 'slots dslots) (struct-set! <class> class-index-direct-slots dslots)
(slot-set! <class> 'getters-n-setters (%compute-getters-n-setters dslots)))) (struct-set! <class> class-index-slots dslots)
(struct-set! <class> class-index-getters-n-setters g-n-s)))
;; Applicables and their classes. ;; Applicables and their classes.
(define-standard-class <procedure-class> (<class>)) (define-standard-class <procedure-class> (<class>))
@ -1440,15 +1445,15 @@
;; Add method in all the classes which appears in its specializers list ;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x) (for-each* (lambda (x)
(let ((dm (class-direct-methods x))) (let ((dm (class-direct-methods x)))
(if (not (memq m dm)) (unless (memq m dm)
(slot-set! x 'direct-methods (cons m dm))))) (struct-set! x class-index-direct-methods (cons m dm)))))
(method-specializers m))) (method-specializers m)))
(define (remove-method-in-classes! m) (define (remove-method-in-classes! m)
;; Remove method in all the classes which appears in its specializers list ;; Remove method in all the classes which appears in its specializers list
(for-each* (lambda (x) (for-each* (lambda (x)
(slot-set! x (struct-set! x
'direct-methods class-index-direct-methods
(delv! m (class-direct-methods x)))) (delv! m (class-direct-methods x))))
(method-specializers m))) (method-specializers m)))
@ -1561,7 +1566,7 @@
(assq slot-name (class-slots class))) (assq slot-name (class-slots class)))
(define (slot-init-function class slot-name) (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) (define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}." "Return the slot definition of the accessor @var{obj}."
@ -1756,8 +1761,9 @@
;;; ;;;
(define (class-slot-g-n-s class slot-name) (define (class-slot-g-n-s class slot-name)
(let* ((this-slot (assq slot-name (slot-ref class 'slots))) (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
(g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters)) (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))))) (slot-missing class slot-name)))))
(if (not (memq (slot-definition-allocation this-slot) (if (not (memq (slot-definition-allocation this-slot)
'(#:class #:each-subclass))) '(#:class #:each-subclass)))
@ -1861,21 +1867,21 @@
(for-each (lambda (m) (for-each (lambda (m)
(update-direct-method! m new old)) ;; -2- (update-direct-method! m new old)) ;; -2-
methods) methods)
(slot-set! new (struct-set! new
'direct-methods class-index-direct-methods
(append methods (class-direct-methods old)))) (append methods (class-direct-methods old))))
;; Substitute old for new in new cpl ;; 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 ;; Remove the old class from the direct-subclasses list of its super classes
(for-each (lambda (c) (slot-set! c 'direct-subclasses (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
(delv! old (class-direct-subclasses c)))) (delv! old (class-direct-subclasses c))))
(class-direct-supers old)) (class-direct-supers old))
;; Replace the new class with the old in the direct-subclasses of the supers ;; Replace the new class with the old in the direct-subclasses of the supers
(for-each (lambda (c) (for-each (lambda (c)
(slot-set! c 'direct-subclasses (struct-set! c class-index-direct-subclasses
(cons old (delv! new (class-direct-subclasses c))))) (cons old (delv! new (class-direct-subclasses c)))))
(class-direct-supers new)) (class-direct-supers new))
@ -1892,7 +1898,7 @@
;; Invalidate class so that subsequent instances slot accesses invoke ;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class ;; change-object-class
(slot-set! new 'redefined old) (struct-set! new class-index-redefined old)
(%invalidate-class new) ;must come after slot-set! (%invalidate-class new) ;must come after slot-set!
old) old)
@ -1966,7 +1972,7 @@
(compute-getter-method class g-n-s)) (compute-getter-method class g-n-s))
(add-method! (setter accessor) (add-method! (setter accessor)
(compute-setter-method class g-n-s)))))) (compute-setter-method class g-n-s))))))
slots (slot-ref class 'getters-n-setters))) slots (struct-ref class class-index-getters-n-setters)))
(define-method (compute-getter-method (class <class>) slotdef) (define-method (compute-getter-method (class <class>) slotdef)
(let ((init-thunk (cadr slotdef)) (let ((init-thunk (cadr slotdef))
@ -2111,8 +2117,8 @@
(case (slot-definition-allocation s) (case (slot-definition-allocation s)
((#:instance) ;; Instance slot ((#:instance) ;; Instance slot
;; get-n-set is just its offset ;; get-n-set is just its offset
(let ((already-allocated (slot-ref class 'nfields))) (let ((already-allocated (struct-ref class class-index-nfields)))
(slot-set! class 'nfields (+ already-allocated 1)) (struct-set! class class-index-nfields (+ already-allocated 1))
already-allocated)) already-allocated))
((#:class) ;; Class slot ((#:class) ;; Class slot
@ -2125,7 +2131,9 @@
(make-closure-variable class (class-slot-init-value)) (make-closure-variable class (class-slot-init-value))
;; Slot is inherited. Find its definition in superclass ;; Slot is inherited. Find its definition in superclass
(let loop ((l (cdr (class-precedence-list class)))) (let loop ((l (cdr (class-precedence-list class))))
(let ((r (assoc name (slot-ref (car l) 'getters-n-setters)))) (let ((r (assoc name
(struct-ref (car l)
class-index-getters-n-setters))))
(if r (if r
(cddr r) (cddr r)
(loop (cdr l)))))))) (loop (cdr l))))))))
@ -2166,26 +2174,27 @@
(next-method) (next-method)
(let ((dslots (get-keyword #:slots initargs '())) (let ((dslots (get-keyword #:slots initargs '()))
(supers (get-keyword #:dsupers initargs '()))) (supers (get-keyword #:dsupers initargs '())))
(slot-set! class 'name (get-keyword #:name initargs '???)) (let ((name (get-keyword #:name initargs '???)))
(slot-set! class 'direct-supers supers) (struct-set! class class-index-name name))
(slot-set! class 'direct-slots dslots) (struct-set! class class-index-direct-supers supers)
(slot-set! class 'direct-subclasses '()) (struct-set! class class-index-direct-slots dslots)
(slot-set! class 'direct-methods '()) (struct-set! class class-index-direct-subclasses '())
(slot-set! class 'cpl (compute-cpl class)) (struct-set! class class-index-direct-methods '())
(slot-set! class 'redefined #f) (struct-set! class class-index-cpl (compute-cpl class))
(struct-set! class class-index-redefined #f)
(let ((slots (compute-slots class))) (let ((slots (compute-slots class)))
(slot-set! class 'slots slots) (struct-set! class class-index-slots slots)
(slot-set! class 'nfields 0) (struct-set! class class-index-nfields 0)
(slot-set! class 'getters-n-setters (compute-getters-n-setters class (let ((getters-n-setters (compute-getters-n-setters class slots)))
slots)) (struct-set! class class-index-getters-n-setters getters-n-setters))
;; Build getters - setters - accessors ;; Build getters - setters - accessors
(compute-slot-accessors class slots)) (compute-slot-accessors class slots))
;; Update the "direct-subclasses" of each inherited classes ;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x) (for-each (lambda (x)
(slot-set! x (let ((dsubs (struct-ref x class-index-direct-subclasses)))
'direct-subclasses (struct-set! x class-index-direct-subclasses
(cons class (slot-ref x 'direct-subclasses)))) (cons class dsubs))))
supers) supers)
;; Support for the underlying structs: ;; Support for the underlying structs: