From 0e6cb5e8b165925597fe5f3d01867d873c16aa9d Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Wed, 6 Sep 2017 23:10:26 +0200 Subject: improved class handling --- modules/oop/pf-objects.scm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'modules/oop/pf-objects.scm') diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 0c54bd4..ecb94f6 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -90,7 +90,7 @@ explicitly tell it to not update etc. (let ((parent (car parents))) (let ((r (lp (slot-ref parent 'h)))) (if (eq? r fail) - (lp (cdr parents)) + (lpp (cdr parents)) r))) fail)) fail) @@ -136,7 +136,14 @@ explicitly tell it to not update etc. (define-method (ref (x

) key . l) (mref- x key l)) (define-method (ref (x ) key . l) (mref-py x key l)) (define-method (ref (x ) key . l) (mref-py- x key l)) - +(define-method (ref x key . l) + (define (end) (if (pair? l) (car l) #f)) + (if (procedure? x) + (aif it (procedure-property x 'pyclass) + (apply ref it key l) + (end)) + (end))) + ;; the reshape function that will create a fresh new pf object with less size @@ -459,7 +466,8 @@ explicitly tell it to not update etc. #'(supers (... ...))))) #'(let ((sups supers) (... ...)) (define class dynamic) - (define name (make-class (list sups (... ...)

) '())) + (define name (make-class (list (ref sups '__goops__ #f) + (... ...)

) '())) (set! class (union- const -- cgit v1.2.3