From c183579b8d49863da4d80faac32fd2aa620d7549 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Sat, 21 Oct 2017 20:24:55 +0200 Subject: improved functional suger notation --- modules/language/python/compile.scm | 78 ++++++++++++++++++++++++++++++------- modules/oop/pf-objects.scm | 19 ++++++++- 2 files changed, 82 insertions(+), 15 deletions(-) (limited to 'modules') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 10320f5..75ceba1 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -519,23 +519,58 @@ (cons v addings))) (v (car v.add)) (addings (cdr v.add)) - (addings (get-addings vs addings))) + (addings (get-addings vs addings)) + (p.a (match kind + (#f (cons #f '())) + ((v add) + (if (is-prefix? v) + (let ((w (symbol->string (exp vs (car add))))) + (cons (string-append (symbol->string v) "." w) + (cdr add))) + (cons (exp vs v) add))))) + (p (car p.a)) + (pa (cdr p.a)) + (pa (get-addings vs pa))) (define q (lambda (x) `',x)) (if kind - (if (null? addings) - (if op - `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u))) - `(,s/d ,v (,(C 'setwrap) ,u))) - (if op - `(,s/d ,(exp vs kind) - (,(C 'fset-x) ,v ,addings - (,(C 'setwrap) - (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))) + (if (not p) + (if (null? addings) + (if op + `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u))) + `(,s/d ,v (,(C 'setwrap) ,u))) + (if op + `(,s/d ,(exp vs kind) + (,(C 'fset-x) ,v ,addings + (,(C 'setwrap) + (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))) - `(,s/d ,(exp vs kind) - (,(C 'fset-x) ,v ,addings - (,(C 'setwrap) ,u))))) - + `(,s/d ,(exp vs kind) + (,(C 'fset-x) ,v ,addings + (,(C 'setwrap) ,u))))) + + (let ((pre (if (equal? p v) + (let lp ((pa pa) (ad addings) (r '())) + (if (and (pair? pa) (pair? ad)) + (let ((px (car pa)) (ax (car ad))) + (if (equal? px ax) + (lp (cdr pa) (cdr ad) (cons px r)) + #f)) + (if (pair? pa) + #f + (reverse r)))) + #f))) + (if (null? addings) + (if op + `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u))) + `(,s/d ,v (,(C 'setwrap) ,u))) + (if op + `(,(C 'set-x) ,v ,pre ,p ,pa ,addings + (,(C 'setwrap) + (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))) + + `(,(C 'set-x) ,v ,pre ,p ,pa ,addings + (,(C 'setwrap) ,u)))))) + (if (null? addings) (if op `(,s/d ,v (,(C 'setwrap) @@ -1733,9 +1768,24 @@ (define-syntax set-x (syntax-rules () + ((_ v (a ... b) val) + (set-x-2 (ref-x v a ...) b val)) + ((_ v #f p pa a val) + (set-x p pa (fset-x v a val))) + ((_ v pre p pa a val) + (set-c v pre a val)) ((_ v (a ... b) val) (set-x-2 (ref-x v a ...) b val)))) +(define-syntax set-c + (syntax-rules () + ((_ v (a) (b) val) + (set v a val)) + ((_ v () as val) + (tr v (fset-x v as val))) + ((_ v ((#:identifier a) . as) (b . bs) val) + (set-c (ref v a) as bs val)))) + (define-syntax fset-x (syntax-rules () ((_ v ((#:identifier x) ...) val) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index cf990af..10016c7 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -11,7 +11,7 @@ object-method class-method static-method py-super-mac py-super py-equal? *class* *self* pyobject? pytype? - type object pylist-set! pylist-ref + type object pylist-set! pylist-ref tr )) #| Python object system is basically syntactic suger otop of a hashmap and one @@ -396,6 +396,23 @@ explicitly tell it to not update etc. (define-method (copy (x )) (mcopy x)) (define-method (copy (x

)) (mcopy- x)) + +;; make a copy of a pf object +(define-syntax-rule (mtr r x) + (begin + (slot-set! r 'h (slot-ref x 'h )) + (slot-set! r 'size (slot-ref x 'size)) + (slot-set! r 'n (slot-ref x 'n )) + (values))) + +(define-syntax-rule (mtr- r x) + (begin + (slot-set! r 'h (slot-ref x 'h)) + (values))) + + +(define-method (tr (r ) (x )) (mtr r x)) +(define-method (tr (r

) (x

)) (mtr- r x)) ;; with will execute thunk and restor x to it's initial state after it has -- cgit v1.2.3