summaryrefslogtreecommitdiff
path: root/modules
diff options
context:
space:
mode:
Diffstat (limited to 'modules')
-rw-r--r--modules/language/python/compile.scm62
-rw-r--r--modules/oop/pf-objects.scm86
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
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 04:39:36 +0000