diff options
-rw-r--r-- | modules/language/python/compile.scm | 62 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 86 |
2 files changed, 97 insertions, 51 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index e515ded..c11bd76 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -145,20 +145,28 @@ (define (make-set vs x u) (match x - ((#:test (#:power (#:identifier v . _) addings . _) . _) - (let ((v (string->symbol v))) - (if (null? addings) - `(set! ,v ,u) - (let* ((rev (reverse addings)) - (las (car rev)) - (new (reverse (cdr rev)))) - `(,(O 'set) ,(let lp ((v v) (new new)) - (match new - ((x . new) - (lp `(,(O 'ref) ,v ,(exp vs x)) ',new)) - (() v))) - ',(exp vs las) ,u))))))) - + ((#:test (#:power kind (#:identifier v . _) addings . _) . _) + (if kind + (let ((v (string->symbol v))) + (if (null? addings) + `(set! ,v ,u) + (let ((addings (map (lambda (x) `',(exp vs x)) addings))) + `(set! ,(exp vs kind) + (,(O 'fset-x) ,v (list ,@addings) ,u))))) + + (let ((v (string->symbol v))) + (if (null? addings) + `(set! ,v ,u) + (let* ((rev (reverse addings)) + (las (car rev)) + (new (reverse (cdr rev)))) + `(,(O 'set) ,(let lp ((v v) (new new)) + (match new + ((x . new) + (lp `(,(O 'ref) ,v ,(exp vs x)) ',new)) + (() v))) + ',(exp vs las) ,u)))))))) + (define is-class? (make-fluid #f)) (define (gen-yargs vs x) (match (pr 'yarg x) ((#:list args) @@ -166,14 +174,14 @@ (define (exp vs x) (match (pr x) - ((#:power (x) () . #f) + ((#:power _ (x) () . #f) (exp vs x)) - ((#:power x () . #f) + ((#:power _ x () . #f) (exp vs x)) ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls - ((#:power vf trailer . #f) + ((#:power #f vf trailer . #f) (let lp ((e (exp vs vf)) (trailer trailer)) (match trailer (() @@ -254,7 +262,7 @@ (reverse (fold (lambda (x s) (match x - (((or 'fast 'functional)) s) + ((or 'fast 'functional) s) (x (cons x s)))) '() l))) (define (is-functional l) @@ -262,15 +270,17 @@ (if pred pred (match x - (('functional) #t) - (_ #f)))) #f l)) + ('functional #t) + (_ #f)))) + #f l)) (define (is-fast l) (fold (lambda (x pred) (if pred pred (match x - (('fast) #t) - (_ #f)))) #f l)) + ('fast #t) + (_ #f)))) + #f l)) (let* ((class (string->symbol class)) @@ -313,11 +323,11 @@ ((#:for e in code . #f) (=> next) (match e - (((#:power (#:identifier x . _) () . #f)) + (((#:power #f (#:identifier x . _) () . #f)) (match in (((#:test power . _)) (match power - ((#:power + ((#:power #f (#:identifier "range" . _) ((#:arglist arglist . _)) . _) @@ -517,7 +527,7 @@ `(,(fluid-ref return) ,@(map (g vs exp) x))) ((#:expr-stmt - ((#:test (#:power (#:identifier v . _) () . #f) #f)) + ((#:test (#:power #f (#:identifier v . _) () . #f) #f)) (#:assign (l))) (let ((s (string->symbol v))) `(set! ,s ,(exp vs l)))) @@ -547,7 +557,7 @@ (((#:stmt ((#:expr-stmt ((#:test - (#:power + (#:power #f (#:identifier "module" . _) ((#:arglist arglist #f #f)) . #f) #f)) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 9101415..761d44c 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -1,9 +1,10 @@ (define-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 vlist) + #:use-module (ice-9 match) #:export (set ref make-pf <p> <py> <pf> <pyf> call with copy fset fcall make-p put put! - pcall pcall! get next + pcall pcall! get next fset-x mk def-pf-class mk-pf-class make-pf-class def-p-class mk-p-class make-p-class @@ -47,35 +48,55 @@ explicitly tell it to not update etc. (slot-set! r 'h (make-hash-table)) r) +(define-syntax-rule (hif it (k h) x y) + (let ((a (vhash-assq k h))) + (if (pair? a) + (let ((it (cdr a))) + x) + y))) + +(define-syntax-rule (cif (it h) (k cl) x y) + (let* ((h (slot-ref cl 'h)) + (a (vhash-assq k h))) + (if (pair? a) + (let ((it (cdr a))) + x) + y))) + (define fail (cons 'fail '())) (define-syntax-rule (mrefx x key l) - (let ((h (slot-ref x 'h))) - (define pair (vhash-assq key h)) + (let () (define (end) (if (null? l) #f (car l))) - (define (parents) - (let ((pair (vhash-assq '__parents__ h))) - (if (pair? pair) - (let lp ((li (cdr pair))) - (if (pair? li) - (let ((r (ref (car li) key fail))) - (if (eq? r fail) - (lp (cdr li)) - r)) - (end))) - (end)))) - - (if pair - (cdr pair) - (let ((cl (ref x '__class__))) - (if cl - (let ((r (ref cl key fail))) - (if (eq? r fail) - (parents) - r)) - (parents)))))) + + (define (parents li) + (let lp ((li li)) + (if (pair? li) + (let ((p (car li))) + (cif (it h) (key p) + it + (hif it ('__parents__ h) + (let ((r (parents it))) + (if (eq? r fail) + (lp (cdr li)) + r)) + (lp (cdr li))))) + fail))) + + (cif (it h) (key x) + it + (hif cl ('__class__ h) + (cif (it h) (key cl) + it + (hif p ('__parents__ h) + (let ((r (parents p))) + (if (eq? r fail) + (end) + r)) + (end))) + (end))))) (define-syntax-rule (mrefx- x key l) (let () @@ -275,6 +296,21 @@ explicitly tell it to not update etc. (mset x key val) x)) +(define (fset-x obj l val) + (let lp ((obj obj) (l l) (r '())) + (match l + (() + (let lp ((v val) (r r)) + (if (pair? r) + (lp (fset (caar r) (cdar r) v) (cdr r)) + v))) + ((k . l) + (lp (ref obj k #f) l (cons (cons obj k) r)))))) + + + + + ;; a functional call will keep x untouched and return (values fknval newx) ;; e.g. we get both the value of the call and the new version of x with ;; perhaps new bindings added @@ -434,7 +470,7 @@ explicitly tell it to not update etc. #'(supers (... ...))))) #'(let ((sups supers) (... ...)) (define class dynamic) - (define name (make-class (list sups (... ...) <p>) '())) + (define name (make-class (list sups (... ...) <pf>) '())) (put! class.__const__ (union const |