diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/compile.scm | 8 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 116 |
2 files changed, 72 insertions, 52 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 7ffe57a..151e0c2 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -3,6 +3,10 @@ #:use-module (ice-9 pretty-print) #:export (comp)) +(define-syntax call + (syntax-rules () + ((_ (f) . l) (f . l)))) + (define (fold f init l) (if (pair? l) (fold f (f (car l) init) (cdr l)) @@ -543,10 +547,6 @@ #`(let/ec ret #,code) code)))))) -(define-syntax call - (syntax-rules () - ((_ (f) . l) (f . l)))) - (define-syntax-rule (var v) (if (defined? 'v) (values) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 4ff3d23..0c54bd4 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -76,26 +76,46 @@ explicitly tell it to not update etc. (parents)))))) (define-syntax-rule (mrefx- x key l) - (let* ((h (slot-ref x 'h)) - (r (hash-ref x key fail))) - (if (eq? r fail) - (if (pair? l) - (car l) - #f) - r))) + (let () + (define (end) (if (pair? l) (car l) #f)) + (define (ret q) (if (eq? q fail) (end) q)) + + (define (find-in-class h) + (let lp ((class-h h)) + (let ((r (hash-ref class-h key fail))) + (if (eq? r fail) + (aif parents (hash-ref class-h '__parents__ #f) + (let lpp ((parents parents)) + (if (pair? parents) + (let ((parent (car parents))) + (let ((r (lp (slot-ref parent 'h)))) + (if (eq? r fail) + (lp (cdr parents)) + r))) + fail)) + fail) + r)))) + + (let* ((h (slot-ref x 'h)) + (r (hash-ref h key fail))) + (if (eq? r fail) + (aif class (hash-ref h '__class__) + (ret (find-in-class (slot-ref class 'h))) + fail) + r)))) (define not-implemented (cons 'not 'implemeneted)) (define-syntax-rule (mrefx-py- x key l) - (let ((f (mref- x '__ref__ '()))) + (let ((f (mrefx- x '__ref__ '()))) (if (or (not f) (eq? f not-implemented)) - (mref- x key l) + (mrefx- x key l) (apply f x key l)))) (define-syntax-rule (mrefx-py x key l) - (let ((f (mref x '__ref__ '()))) + (let ((f (mrefx x '__ref__ '()))) (if (or (not f) (eq? f not-implemented)) - (mref x key l) + (mrefx x key l) (apply f x key l)))) (define-syntax-rule (unx mrefx- mref-) @@ -159,7 +179,6 @@ explicitly tell it to not update etc. (if (or (eq? f not-implemented) (not f)) (mset x key val) (f key val)))) - (define-syntax-rule (mset- x key val) (let ((h (slot-ref x 'h))) @@ -176,13 +195,11 @@ explicitly tell it to not update etc. (define-method (set (x <pyf>) key val) (mset-py x key val)) (define-method (set (x <py>) key val) (mset-py- x key val)) - ;; mref will reference the value of the key in the object x, an extra default ;; parameter will tell what the fail object is else #f if fail ;; if there is no found binding in the object search the class and ;; the super classes for a binding - ;; call a function as a value of key in x with the object otself as a first ;; parameter, this is pythonic object semantics (define-syntax-rule (mk-call mcall mref) @@ -387,9 +404,10 @@ explicitly tell it to not update etc. (define (union- x y) (define hx (slot-ref x 'h)) (define hy (slot-ref y 'h)) - (define out (make <p>)) - (hash-for-each (lambda (k v) (hash-set! hy k v)) hx) - (slot-set! out 'h hy) + (define out (make-p)) + (define h (slot-ref out 'h)) + (hash-for-each (lambda (k v) (hash-set! h k v)) hy) + (hash-for-each (lambda (k v) (hash-set! h k v)) hx) out) @@ -407,7 +425,8 @@ explicitly tell it to not update etc. #'(supers (... ...))))) #'(let ((sups supers) (... ...)) (define class dynamic) - (define-class name (sups (... ...) <pf>)) + (define name (make-class (list sups (... ...) <p>) '())) + (put! class.__const__ (union const (let lp ((sup (list sups (... ...)))) @@ -425,6 +444,7 @@ explicitly tell it to not update etc. (put! class.__const__.__name__ (cons 'name 'obj)) (put! class.__const__.__class__ class) (put! class.__const__.__parents__ (list sups (... ...))) + (put! class.__const__.__goops__ name) class))))))) (mk-pf make-pf-class <pf>) @@ -439,44 +459,44 @@ explicitly tell it to not update etc. #'(supers (... ...))))) #'(let ((sups supers) (... ...)) (define class dynamic) - (define-class name (sups (... ...) <p>)) - (put! class.__const__ - (union- const - (let lp ((sup (list sups (... ...)))) - (if (pair? sup) - (union- (ref (car sup) '__const__ null) - (lp (cdr sup))) - (make-p))))) - + (define name (make-class (list sups (... ...) <p>) '())) + + (set! class + (union- const + (let lp ((sup (list sups (... ...)))) + (if (pair? sup) + (union- (car sup) + (lp (cdr sup))) + (make-p))))) + - (put! class.__goops__ name) - (put! class.__name__ 'name) - (put! class.__parents__ (list sups (... ...))) + (set class '__goops__ name) + (set class '__name__ 'name) + (set class '__parents__ (list sups (... ...))) + + class))))))) - (put! class.__const__.__name__ (cons 'name 'obj)) - (put! class.__const__.__class__ class) - (put! class.__const__.__parents__ (list sups (... ...))) - - (union- class (get class.__const__))))))))) - (mk-p make-p-class <p>) (mk-p make-py-class <py>) ;; Let's make an object essentially just move a reference (define-method (mk (x <pf>) . l) - (let ((r (get x.__const__)) - (k (make (get x.__goops__)))) - (slot-set! k 'h (slot-ref r 'h)) - (slot-set! k 'size (slot-ref r 'size)) - (slot-set! k 'n (slot-ref r 'n)) - (apply (ref k '__init__ (lambda x (values))) k l) - k)) + (let ((r (ref x '__const__)) + (o (make (ref x '__goops__)))) + (slot-set! o 'h (slot-ref r 'h)) + (slot-set! o 'size (slot-ref r 'size)) + (slot-set! o 'n (slot-ref r 'n)) + (apply (ref o '__init__ (lambda x (error "no init fkn"))) o l) + o)) + (define-method (mk (x <p>) . l) - (let ((k (make (get x.__goops__)))) - (put! k.__class__ x) - (apply (ref k '__init__ (lambda x (values))) k l) - k)) + (let ((o (make (ref x '__goops__))) + (h (make-hash-table))) + (slot-set! o 'h h) + (hash-set! h '__class__ x) + (apply (ref o '__init__ (lambda x (error "no init fkn"))) l) + o)) ;; the make class and defclass syntactic sugar (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class) @@ -517,7 +537,7 @@ explicitly tell it to not update etc. (define-syntax-rule (wrap class) (let* ((c class) (ret (lambda x (apply mk c x)))) - (set-procedure-property! ret 'pyclass class) + (set-procedure-property! ret 'pyclass c) ret)) (define (get-class x) |