diff options
| -rw-r--r-- | modules/language/python/compile.scm | 333 | ||||
| -rw-r--r-- | modules/language/python/parser.scm | 20 | ||||
| -rw-r--r-- | modules/language/python/spec.scm | 12 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 528 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm~ | 502 |
5 files changed, 1300 insertions, 95 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index d634d1b..7ffe57a 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -3,15 +3,28 @@ #:use-module (ice-9 pretty-print) #:export (comp)) -(define (p x) (pretty-print (syntax->datum x)) x) +(define (fold f init l) + (if (pair? l) + (fold f (f (car l) init) (cdr l)) + init)) + +(define (pr . x) + (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) + (with-output-to-port port + (lambda () + (pretty-print x))) + (close port) + (car (reverse x))) + (define (pf x) - (define port (open-file "compile.log" "a")) + (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a")) (with-output-to-port port (lambda () (pretty-print (syntax->datum x)) x)) (close port) x) (define (C x) `(@@ (language python compile) ,x)) +(define (O x) `(@@ (oop pf-objects) ,x)) (define (G x) `(@ (guile) ,x)) (define (union as vs) @@ -49,7 +62,7 @@ ((#:global . l) (let lp ((l l) (vs vs)) (match l - (((#:identifier v) . l) + (((#:identifier v . _) . l) (let ((s (string->symbol v))) (if (member s vs) (lp l vs) @@ -62,15 +75,15 @@ (define (scope x vs) (match x - ((#:def (#:identifier f) . _) + ((#:def (#:identifier f . _) . _) (union (list (string->symbol f)) vs)) ((#:lambdef . _) vs) - ((#:class . _) + ((#:classdef . _) vs) ((#:global . _) vs) - ((#:identifier v) + ((#:identifier v . _) (let ((s (string->symbol v))) (if (member s vs) vs @@ -81,7 +94,7 @@ (define (defs x vs) (match x - ((#:def (#:identifier f) . _) + ((#:def (#:identifier f . _) . _) (union (list (string->symbol f)) vs)) ((#:lambdef . _) vs) @@ -98,12 +111,50 @@ (define return (make-fluid 'error-return)) +(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))))))) + + + (define (exp vs x) - (match (p x) - ((#:power (#:identifier x) () . #f) + (match (pr x) + ((#:power x () . #f) + (exp vs x)) + + ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls + ((#:power vf ((and trailer (#:identifier _ . _)) ... + (#:arglist (args ...) #f #f)) . #f) + (let ((args (map (g vs exp) args))) + (match vf + ((#:f (#:identifier f . _) e) + (let ((obj (gensym "obj")) + (l (gensym "l"))) + '(call-with-values (lambda () (fcall (,(exp vs e) + ,@(map (g vd exp) trailer)) + ,@args)) + (lambda (,obj . ,l) + `(set! ,(string->symbol f) ,obj) + (apply 'values ,l))))) + (x + `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args))))) + + ((#:identifier x . _) (string->symbol x)) - ((#:power x () . #f) + ((#:string x) x) (((and x (or #:+ #:- #:* #:/)) . l) @@ -129,12 +180,18 @@ ((#:and . x) (cons 'and (map (g vs exp) x))) - + ((#:test e1 #f) (exp vs e1)) ((#:test e1 e2 e3) (list 'if (exp vs e2) (exp vs e1) (exp vs e3))) + + ((#:if test a ((tests . as) ...) . else) + `(,(G 'cond) + (,(exp vs test) ,(exp vs a)) + ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as) + ,@(if else `((else ,(exp vs else))) '()))) ((#:suite . l) (cons 'begin (map (g vs exp) l))) @@ -152,47 +209,119 @@ ,(exp vs code) (,lp)))))) - ((#:for exp in code #f) - (match (cons exp in) - ((((#:power (#:identifier x) #f . #f)) . - ((#:power (#:identifier 'range) ((arg) #f #f) . #f))) - (let ((v (gensym "v")) - (lp (gensym "lp"))) - `(let ((,v ,(exp arg))) - (let ,lp ((,x 0)) - (if (< ,x ,v) - (begin - ,(exp vs code) - (,lp (+ ,x 1)))))))) - - ((((#:power (#:identifier x) #f . #f)) . - ((#:power (#:identifier 'range) ((arg1 arg2) #f #f) . #f))) - (let ((v1 (gensym "va")) - (v2 (gensym "vb")) - (lp (gensym "lp"))) - `(let ((,v1 ,(exp arg1)) - (,v2 ,(exp arg2))) - (let ,lp ((,x ,v1)) - (if (< ,x ,v2) - (begin - ,(exp vs code) - (,lp (+ ,x 1)))))))) - - ((((#:power (#:identifier x) #f . #f)) . - ((#:power (#:identifier 'range) ((arg1 arg2 arg3) #f #f) . #f))) - (let ((v1 (gensym "va")) - (v2 (gensym "vb")) - (st (gensym "vs")) - (lp (gensym "lp"))) - `(let ((,v1 ,(exp arg1)) - (,st ,(exp arg2)) - (,v2 ,(exp arg3))) - (let ,lp ((,x ,v1)) - (if (< ,x ,v2) - (begin - ,(exp vs code) - (,lp (+ ,x ,st)))))))))) - + ((#:classdef (#:identifier class . _) parents defs) + (let () + (define (filt l) + (reverse + (fold (lambda (x s) + (match x + (((or 'fast 'functional)) s) + (x (cons x s)))) + '() l))) + (define (is-functional l) + (fold (lambda (x pred) + (if pred + pred + (match x + (('functional) #t) + (_ #f)))) #f l)) + (define (is-fast l) + (fold (lambda (x pred) + (if pred + pred + (match x + (('fast) #t) + (_ #f)))) #f l)) + + + (let* ((class (string->symbol class)) + (parents (match parents + (#f + '()) + ((#:arglist args . _) + (map (g vs exp) args)))) + (is-func (is-functional parents)) + (is-fast (is-fast parents)) + (kind (if is-func + (if is-fast + 'mk-pf-class + 'mk-pyf-class) + (if is-fast + 'mk-p-class + 'mk-py-class))) + (parents (filt parents))) + `(define ,class (,(O 'wrap) + (,(O kind) + ,class + ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) + #:const + ,(match (exp vs defs) + ((begin . l) + l) + (l l)) + #:dynamic + ())))))) + + + + ((#:for e in code . #f) + (=> next) + (match e + (((#:power (#:identifier x . _) () . #f)) + (match in + (((#:test power . _)) + (match power + ((#:power + (#:identifier "range" . _) + ((#:arglist arglist . _)) + . _) + (match arglist + ((arg) + (let ((v (gensym "v")) + (x (string->symbol x)) + (lp (gensym "lp"))) + `(let ((,v ,(exp vs arg))) + (let ,lp ((,x 0)) + (if (< ,x ,v) + (begin + ,(exp vs code) + (,lp (+ ,x 1)))))))) + ((arg1 arg2) + (let ((v1 (gensym "va")) + (v2 (gensym "vb")) + (lp (gensym "lp"))) + `(let ((,v1 ,(exp vs arg1)) + (,v2 ,(exp vs arg2))) + (let ,lp ((,x ,v1)) + (if (< ,x ,v2) + (begin + ,(exp vs code) + (,lp (+ ,x 1)))))))) + ((arg1 arg2 arg3) + (let ((v1 (gensym "va")) + (v2 (gensym "vb")) + (st (gensym "vs")) + (lp (gensym "lp"))) + `(let ((,v1 ,(exp vs arg1)) + (,st ,(exp vs arg2)) + (,v2 ,(exp vs arg3))) + (if (> st 0) + (let ,lp ((,x ,v1)) + (if (< ,x ,v2) + (begin + ,(exp vs code) + (,lp (+ ,x ,st))))) + (if (< st 0) + (let ,lp ((,x ,v1)) + (if (> ,x ,v2) + (begin + ,(exp vs code) + (,lp (+ ,x ,st))))) + (error "range with step 0 not allowed")))))) + (_ (next)))) + (_ (next)))) + (_ (next)))) + (_ (next)))) ((#:while test code else) (let ((lp (gensym "lp"))) @@ -201,7 +330,7 @@ (begin ,(exp vs code) (,lp)) - ,(exp else))))) + ,(exp vs else))))) ((#:try x exc else fin) (define (f x) @@ -221,27 +350,27 @@ (lp `(catch ,(exp vs e) (lambda () ,code) (lambda ,(gensym "x") - ,(exp c))) l)) + ,(exp vs c))) l)) ((((e . as) c) . l) (lp `(let ((,as ,(exp vs e))) (catch ,as (lambda () ,code) (lambda ,(gensym "x") - ,(exp vs c))) l))) + ,(exp vs c)))) l)) (() code)))) (lambda () ,(exp vs fin))))) - ((#:def (#:identifier f) + ((#:def (#:identifier f . _) (#:types-args-list args - #f) + #f #f) #f code) (let* ((f (string->symbol f)) (r (gensym "return")) (as (map (lambda (x) (match x - ((((#:identifier x) . #f) #f) + ((((#:identifier x . _) . #f) #f) (string->symbol x)))) args)) (vs (union as vs)) @@ -249,11 +378,12 @@ (df (defs code '())) (ls (diff (diff ns vs) df))) - `(define (,f ,@as) (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code))))))) - + `(define ,f (lambda (,@as) + (,(C 'with-return) ,r + (let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code)))))))) + ((#:global . _) '(values)) @@ -269,21 +399,35 @@ ((#:expr-stmt (l) (#:assign)) (exp vs l)) + ((#:expr-stmt l (#:assign u)) + (cond + ((= (length l) (length u)) + (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u)))) + ((= (length u) 1) + (let ((vars (map (lambda (x) (gensym "v")) l))) + `(call-with-values (lambda () (exp vs (car u))) + (lambda vars + ,@(map make-set l vars))))))) + + + ((#:return . x) `(,(fluid-ref return) ,@(map (g vs exp) x))) ((#:expr-stmt - ((#:test (#:power (#:identifier v) () . #f) #f)) + ((#:test (#:power (#:identifier v . _) () . #f) #f)) (#:assign (l))) (let ((s (string->symbol v))) `(set! ,s ,(exp vs l)))) - - ((#:comp . l) + ((#:comp x #f) + (exp vs x)) + + ((#:comp x (op . y)) (define (tr op x y) (match op ((or "<" ">" "<=" ">=") - (list (string->symbol op) x y)) + (list (G (string->symbol op)) x y)) ("!=" (list 'not (list 'equal? x y))) ("==" (list 'equal? x y)) ("is" (list 'eq? x y)) @@ -291,19 +435,37 @@ ("in" (list 'member x y)) ("notin" (list 'not (list 'member x y))) ("<>" (list 'not (list 'equal? x y))))) - (let lp ((l l)) - (match l - (() - '()) - ((x op y) - (tr op (exp vs x) (exp vs y))) - ((x op . l) - (tr op (exp vs x) (lp vs l)))))))) + (tr op (exp vs x) (exp vs y))) + + (x x))) (define (comp x) + (define start + (match (pr 'start x) + (((#:stmt + ((#:expr-stmt + ((#:test + (#:power + (#:identifier "module" . _) + ((#:arglist arglist #f #f)) + . #f) #f)) + (#:assign)))) . _) + (let () + (define args + (map (lambda (x) + (exp '() x)) + arglist)) + + `((,(G 'define-module) (language python module ,@args))))) + (x '()))) + + (if (pair? start) + (set! x (cdr x))) + (let ((globs (get-globals x))) `(begin - ,@(map (lambda (s) `(define ,s (values))) globs) + ,@start + ,@(map (lambda (s) `(,(C 'var) ,s)) globs) ,@(map (g globs exp) x)))) (define-syntax with-return @@ -376,10 +538,17 @@ (syntax-case x () ((_ ret l) - (pf (let ((code (analyze #'ret #'l))) - (if (is-ec #'ret #'l #t) - #`(let/ec ret #,code) - code))))))) + (let ((code (analyze #'ret #'l))) + (if (is-ec #'ret #'l #t) + #`(let/ec ret #,code) + code)))))) + +(define-syntax call + (syntax-rules () + ((_ (f) . l) (f . l)))) + +(define-syntax-rule (var v) + (if (defined? 'v) + (values) + (define! 'v #f))) - - diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm index 55c0d2d..55fc02e 100644 --- a/modules/language/python/parser.scm +++ b/modules/language/python/parser.scm @@ -590,12 +590,12 @@ (set! test (f-or! 'test - (f-list #:test - (Ds or_test) - (ff? (f-list - (f-seq "if" (Ds or_test)) - (f-seq "else" test)))) - (Ds lambdef))) + (f-list #:test + (Ds or_test) + (ff? (f-list + (f-seq "if" (Ds or_test)) + (f-seq "else" test)))) + (Ds lambdef))) (define test_nocond (f-or 'nocond (Ds or_test) (Ds lambdef_nocond))) @@ -709,9 +709,9 @@ mk-id)) (set! power - (p-freeze 'power - (f-cons 'power #:power - (f-cons (Ds atom) + (p-freeze 'power + (f-cons 'power #:power + (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom)) (f-cons (ff* (Ds trailer)) (f-or! (f-seq "**" factor) FALSE)))) @@ -721,7 +721,7 @@ (f-or! 'trailer (f-seq "(" (ff? (Ds arglist)) ")") (f-seq "[" (Ds subscriptlist) "]") - (f-seq "." identifier))) + (f-seq (f-list #:dot (ff+ "." identifier)))) (set! atom (p-freeze 'atom diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm index 1389165..c22c0b4 100644 --- a/modules/language/python/spec.scm +++ b/modules/language/python/spec.scm @@ -1,5 +1,5 @@ (define-module (language python spec) - #:use-module (language python parser) + #:use-module (parser stis-parser lang python3-parser) #:use-module (language python compile) #:use-module (rnrs io ports) #:use-module (ice-9 pretty-print) @@ -14,7 +14,13 @@ ;;; Language definition ;;; -(define (pr . x) (pretty-print x) (car (reverse x))) +(define (pr . x) + (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) + (with-output-to-port port + (lambda () + (pretty-print x) (car (reverse x)))) + (close port) + (car (reverse x))) (define (c x) (pr (comp (pr (p (pr x)))))) (define (cc port x) @@ -33,7 +39,7 @@ (lambda () ;; Ideally we'd duplicate the whole module hierarchy so that `set!', ;; `fluid-set!', etc. don't have any effect in the current environment. - (let ((m (make-fresh-user-module))) + (let ((m (make-fresh-user-module))) ;; Provide a separate `current-reader' fluid so that ;; compile-time changes to `current-reader' are ;; limited to the current compilation unit. diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm new file mode 100644 index 0000000..4ff3d23 --- /dev/null +++ b/modules/oop/pf-objects.scm @@ -0,0 +1,528 @@ +(define-module (oop pf-objects) + #:use-module (oop goops) + #:use-module (ice-9 vlist) + #:export (set ref make-pf <pf> call with copy fset fcall make-p put put! + pcall pcall! get + mk + def-pf-class mk-pf-class make-pf-class + def-p-class mk-p-class make-p-class + def-pyf-class mk-pyf-class make-pyf-class + def-py-class mk-py-class make-py-class)) + +#| +Python object system is basically syntactic suger otop of a hashmap and one +this project is inspired by the python object system and what it measn when +one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work +with assocs or tree like functional hashmaps in stead. + +The hashmap works like an assoc e.g. we will define new values by 'consing' a +new binding on the list and when the assoc take up too much space it will be +reshaped and all extra bindings will be removed. + +The datastructure is functional but the objects mutate. So one need to +explicitly tell it to not update etc. +|# + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + +(define-class <p> () h) +(define-class <pf> (<p>) size n) ; the pf object consist of a functional + ; hashmap it's size and number of live + ; object +(define-class <py> (<p>)) +(define-class <pyf> (<pf>)) + +;; Make an empty pf object +(define (make-pf) + (define r (make <pf>)) + (slot-set! r 'h vlist-null) + (slot-set! r 'size 0) + (slot-set! r 'n 0) + r) + +(define (make-p) + (define r (make <p>)) + (slot-set! r 'h (make-hash-table)) + r) + +(define fail (cons 'fail '())) +(define-syntax-rule (mrefx x key l) + (let ((h (slot-ref x 'h))) + (define pair (vhash-assq key h)) + (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-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))) + +(define not-implemented (cons 'not 'implemeneted)) + +(define-syntax-rule (mrefx-py- x key l) + (let ((f (mref- x '__ref__ '()))) + (if (or (not f) (eq? f not-implemented)) + (mref- x key l) + (apply f x key l)))) + +(define-syntax-rule (mrefx-py x key l) + (let ((f (mref x '__ref__ '()))) + (if (or (not f) (eq? f not-implemented)) + (mref x key l) + (apply f x key l)))) + +(define-syntax-rule (unx mrefx- mref-) + (define-syntax-rule (mref- x key l) + (let ((xx x)) + (let ((res (mrefx- xx key l))) + (if (procedure? res) + (lambda z + (apply res xx z)) + res))))) + +(unx mrefx- mref-) +(unx mrefx mref) +(unx mrefx-py mref-py) +(unx mrefx-py- mref-py-) + +(define-method (ref (x <pf> ) key . l) (mref x key l)) +(define-method (ref (x <p> ) key . l) (mref- x key l)) +(define-method (ref (x <pyf>) key . l) (mref-py x key l)) +(define-method (ref (x <py> ) key . l) (mref-py- x key l)) + + + +;; the reshape function that will create a fresh new pf object with less size +;; this is an expensive operation and will only be done when we now there is +;; a lot to gain essentially tho complexity is as in the number of set +(define (reshape x) + (let ((h (slot-ref x 'h)) + (m (make-hash-table)) + (n 0)) + (define h2 (vhash-fold (lambda (k v s) + (if (hash-ref m k #f) + s + (begin + (hash-set! m k #t) + (set! n (+ n 1)) + (vhash-consq k v s)))) + vlist-null + h)) + (slot-set! x 'h h2) + (slot-set! x 'size n) + (slot-set! x 'n n) + (values))) + +;; on object x add a binding that key -> val +(define-syntax-rule (mset x key val) + (let ((h (slot-ref x 'h)) + (s (slot-ref x 'size)) + (n (slot-ref x 'n))) + (slot-set! x 'size (+ 1 s)) + (let ((r (vhash-assq key h))) + (when (not r) + (slot-set! x 'n (+ n 1))) + (slot-set! x 'h (vhash-consq key val h)) + (when (> s (* 2 n)) + (reshape x)) + (values)))) + +(define-syntax-rule (mset-py x key val) + (let ((f (mref-py x '__set__ '()))) + (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))) + (hash-set! h key val))) + +(define-syntax-rule (mset-py- x key val) + (let ((f (mref-py- x '__set__ '()))) + (if (or (eq? f not-implemented) (not f)) + (mset- x key val) + (f key val)))) + +(define-method (set (x <pf>) key val) (mset x key val)) +(define-method (set (x <p>) key val) (mset- x key val)) +(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) + (define-syntax-rule (mcall x key l) + (apply (mref x key '()) l))) + +(mk-call mcall mref) +(mk-call mcall- mref-) +(mk-call mcall-py mref-py) +(mk-call mcall-py- mref-py-) + +(define-method (call (x <pf>) key . l) (mcall x key l)) +(define-method (call (x <p>) key . l) (mcall- x key l)) +(define-method (call (x <pyf>) key . l) (mcall-py x key l)) +(define-method (call (x <py>) key . l) (mcall-py- x key l)) + + +;; make a copy of a pf object +(define-syntax-rule (mcopy x) + (let ((r (make <pf>))) + (slot-set! r 'h (slot-ref x 'h)) + (slot-set! r 'size (slot-ref x 'size)) + (slot-set! r 'n (slot-ref x 'n)) + r)) + +(define-syntax-rule (mcopy- x) + (let* ((r (make-p)) + (h (slot-ref r 'h))) + (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h)) + r)) + +(define-method (copy (x <pf>)) (mcopy x)) +(define-method (copy (x <p> )) (mcopy- x)) + + +;; with will execute thunk and restor x to it's initial state after it has +;; finished note that this is a cheap operatoin because we use a functional +;; datastructure +(define-syntax-rule (mwith x thunk) + (let ((old (mcopy x))) + (let ((r (thunk))) + (slot-set! x 'h (slot-ref old 'h)) + (slot-set! x 'size (slot-ref old 'size)) + (slot-set! x 'n (slot-ref old 'n)) + r))) + +(define-syntax-rule (mwith- x thunk) + (let ((old (mcopy- x))) + (let ((r (thunk))) + (slot-set! x 'h (slot-ref old 'h)) + r))) + + + +;; a functional set will return a new object with the added binding and keep +;; x untouched +(define-method (fset (x <pf>) key val) + (let ((x (mcopy x))) + (mset x key val) + x)) + +(define-method (fset (x <p>) key val) + (let ((x (mcopy- x))) + (mset x key val) + x)) + +;; 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 +(define-method (fcall (x <pf>) key . l) + (let* ((y (mcopy x)) + (r (mcall y key l))) + (if (eq? (slot-ref x 'h) (slot-ref y 'h)) + (values r x) + (values r y)))) + +(define-method (fcall (x <p>) key . l) + (let ((x (mcopy x))) + (values (mcall- x key l) + x))) + +;; this shows how we can override addition in a pythonic way +(define-syntax-rule (mk-arith + +x __add__ __radd__) + (begin + (define-method (+ (x <p>) y) + (call x '__add__ y)) + + (define-method (+ x (y <p>)) + (call y '__radd__ x)) + + (define-method (+ (x <py>) y) + (let ((f (mref-py- x '__add__ '()))) + (if f + (f y) + (+x y x)))) + + (define-method (+ (x <pyf>) y) + (let ((f (mref-py x '__add__ '()))) + (if f + (let ((res (f y))) + (if (eq? res not-implemented) + (+x y x) + res)) + (+x y x)))) + + (define-method (+ (x <py>) y) + (let ((f (mref-py- x '__add__ '()))) + (if f + (let ((res (f y))) + (if (eq? res not-implemented) + (+x y x) + res)) + (+x y x)))) + + (define-method (+ x (y <py>)) + (call y '__radd__ x)) + + (define-method (+ x (y <pyf>)) + (call y '__radd__ x)) + + (define-method (+x (x <p>) y) + (call x '__radd__ y)))) + +;; A few arithmetic operations at service +(mk-arith + +x __add__ __radd__) +(mk-arith - -x __sub__ __rsub__) +(mk-arith * *x __mul__ __rmul__) + +;; lets define get put pcall etc so that we can refer to an object like +;; e.g. (put x.y.z 1) (pcall x.y 1) + +(define-syntax-rule (cross x k f set) + (call-with-values (lambda () f) + (lambda (r y) + (if (eq? x y) + (values r x) + (values r (set x k y)))))) + +(define-syntax-rule (cross! x k f _) f) + +(define-syntax mku + (syntax-rules () + ((_ cross set setx f (key) (val ...)) + (setx f key val ...)) + ((_ cross set setx f (k . l) val) + (cross f k (mku cross set setx (ref f k) l val) set)))) + +(define-syntax-rule (mkk pset setx set cross) + (define-syntax pset + (lambda (x) + (syntax-case x () + ((_ f val (... ...)) + (let* ((to (lambda (x) + (datum->syntax #'f (string->symbol x)))) + (l (string-split (symbol->string (syntax->datum #'f)) #\.))) + (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x)) + (cdr l))) + (h (to (car l)))) + #'(mku cross setx set h (a (... ...)) (val (... ...)))))))))) + +(mkk put fset fset cross) +(mkk put! set set cross!) +(mkk pcall! call fset cross!) +(mkk pcall fcall fset cross) +(mkk get ref fset cross!) + +;; it's good to have a null object so we don't need to construct it all the +;; time because it is functional we can get away with this. +(define null (make-pf)) + +;; append the bindings in x in front of y + some optimizations +(define (union x y) + (define hx (slot-ref x 'h)) + (define hy (slot-ref y 'h)) + (define n (slot-ref x 'n)) + (define s (slot-ref x 'size)) + (define m (make-hash-table)) + + (define h + (vhash-fold + (lambda (k v st) + (if (vhash-assq k hy) + (begin + (set! s (+ s 1)) + (vhash-consq k v st)) + (if (hash-ref m k) + s + (begin + (set! n (+ n 1)) + (set! s (+ s 1)) + (hash-set! m k #t) + (vhash-consq k v st))))) + hy + hx)) + + (define out (make <pf>)) + (slot-set! out 'h h) + (slot-set! out 'n n) + (slot-set! out 'size s) + out) + +(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) + out) + + +;; make a class. A class add some meta information to allow for multiple +;; inherritance and add effectively static data to the object the functional +;; datastructure show it's effeciency now const is data that will not change +;; and bindings that are added to all objects. Dynamic is the mutating class +;; information. supers is a list of priorities +(define-syntax-rule (mk-pf make-pf-class <pf>) + (define-syntax make-pf-class + (lambda (x) + (syntax-case x () + ((_ name const dynamic (supers (... ...))) + (with-syntax (((sups (... ...)) (generate-temporaries + #'(supers (... ...))))) + #'(let ((sups supers) (... ...)) + (define class dynamic) + (define-class name (sups (... ...) <pf>)) + (put! class.__const__ + (union const + (let lp ((sup (list sups (... ...)))) + (if (pair? sup) + (union (ref (car sup) '__const__ null) + (lp (cdr sup))) + null)))) + + (reshape (get class.__const__ null)) + + (put! class.__goops__ name) + (put! class.__name__ 'name) + (put! class.__parents__ (list sups (... ...))) + + (put! class.__const__.__name__ (cons 'name 'obj)) + (put! class.__const__.__class__ class) + (put! class.__const__.__parents__ (list sups (... ...))) + class))))))) + +(mk-pf make-pf-class <pf>) +(mk-pf make-pyf-class <pyf>) + +(define-syntax-rule (mk-p make-p-class <p>) + (define-syntax make-p-class + (lambda (x) + (syntax-case x () + ((_ name const dynamic (supers (... ...))) + (with-syntax (((sups (... ...)) (generate-temporaries + #'(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))))) + + + (put! class.__goops__ name) + (put! class.__name__ 'name) + (put! class.__parents__ (list sups (... ...))) + + (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)) + +(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)) + +;; the make class and defclass syntactic sugar +(define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class) + (define-syntax-rule (mk-pf-class name (parents (... ...)) + #:const + ((sdef mname sval) (... ...)) + #:dynamic + ((ddef dname dval) (... ...))) + (let () + (define name + (make-pf-class name + (let ((s (make-pf))) + (set s 'mname sval) (... ...) + s) + (let ((d (make-pf))) + (set d 'dname dval) (... ...) + d) + (parents (... ...)))) + name))) + +(mk-p/f make-pf mk-pf-class make-pf-class) +(mk-p/f make-p mk-p-class make-p-class) +(mk-p/f make-pf mk-pyf-class make-pyf-class) +(mk-p/f make-p mk-py-class make-py-class) + +(define-syntax-rule (def-pf-class name . l) + (define name (mk-pf-class name . l))) + +(define-syntax-rule (def-p-class name . l) + (define name (mk-p-class name . l))) + +(define-syntax-rule (def-pyf-class name . l) + (define name (mk-pyf-class name . l))) + +(define-syntax-rule (def-py-class name . l) + (define name (mk-py-class name . l))) + +(define-syntax-rule (wrap class) + (let* ((c class) + (ret (lambda x (apply mk c x)))) + (set-procedure-property! ret 'pyclass class) + ret)) + +(define (get-class x) + (aif it (procedure-property x 'pyclass) + it + (error "not a class"))) + + diff --git a/modules/oop/pf-objects.scm~ b/modules/oop/pf-objects.scm~ new file mode 100644 index 0000000..a8f120e --- /dev/null +++ b/modules/oop/pf-objects.scm~ @@ -0,0 +1,502 @@ +(define-module (oop pf-objects) + #:use-module (oop goops) + #:use-module (ice-9 vlist) + #:export (set ref make-pf <pf> call with copy fset fcall make-p put put! + pcall pcall! get + mk + def-pf-class mk-pf-class make-pf-class + def-p-class mk-p-class make-p-class + def-pyf-class mk-pyf-class make-pyf-class + def-py-class mk-py-class make-py-class + +#| +Python object system is basically syntactic suger otop of a hashmap and one +this project is inspired by the python object system and what it measn when +one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work +with assocs or tree like functional hashmaps in stead. + +The hashmap works like an assoc e.g. we will define new values by 'consing' a +new binding on the list and when the assoc take up too much space it will be +reshaped and all extra bindings will be removed. + +The datastructure is functional but the objects mutate. So one need to +explicitly tell it to not update etc. +|# + +(define-class <p> () h) +(define-class <pf> (<p>) size n) ; the pf object consist of a functional + ; hashmap it's size and number of live + ; object +(define-class <py> (<p>)) +(define-class <pyf> (<pf>)) + +;; Make an empty pf object +(define (make-pf) + (define r (make <pf>)) + (slot-set! r 'h vlist-null) + (slot-set! r 'size 0) + (slot-set! r 'n 0) + r) + +(define (make-p) + (define r (make <p>)) + (slot-set! r 'h make-hash-table) + r) + +(define fail (cons 'fail '())) +(define-syntax-rule (mrefx x key l) + (let ((h (slot-ref x 'h))) + (define pair (vhash-assq key h)) + (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-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)))) + +(define not-implemented (cons 'not 'implemeneted)) + +(define-syntax-rule (mrefx-py- x key l) + (let ((f (mref- x '__ref__))) + (if (or (not f) (eq? f not-implemented)) + (mref- x key l) + (apply f x key l)))) + +(define-syntax-rule (mrefx-py x key l) + (let ((f (mref x '__ref__))) + (if (or (not f) (eq? f not-implemented)) + (mref x key l) + (apply f x key l)))) + +(define-syntax-rule (unx mrefx- mref-) + (define-syntax-rule (mref- x key l) + (let ((xx x)) + (let ((res (mrefx- xx key l))) + (if (procedure? res) + (lambda z + (apply res xx z)) + res))))) + +(unx mrefx- mref-) +(unx mrefx mref) +(unx mrefx-py mref-py) +(unx mrefx-py- mref-py-) + +(define-method (ref (x <pf> ) key . l) (mref x key l)) +(define-method (ref (x <p> ) key . l) (mref- x key l)) +(define-method (ref (x <pyf>) key . l) (mref-py x key l)) +(define-method (ref (x <py> ) key . l) (mref-py- x key l)) + + + +;; the reshape function that will create a fresh new pf object with less size +;; this is an expensive operation and will only be done when we now there is +;; a lot to gain essentially tho complexity is as in the number of set +(define (reshape x) + (let ((h (slot-ref x 'h)) + (m (make-hash-table)) + (n 0)) + (define h2 (vhash-fold (lambda (k v s) + (if (hash-ref m k #f) + s + (begin + (hash-set! m k #t) + (set! n (+ n 1)) + (vhash-consq k v s)))) + vlist-null + h)) + (slot-set! x 'h h2) + (slot-set! x 'size n) + (slot-set! x 'n n) + (values))) + +;; on object x add a binding that key -> val +(define-syntax-rule (mset x key val) + (let ((h (slot-ref x 'h)) + (s (slot-ref x 'size)) + (n (slot-ref x 'n))) + (slot-set! x 'size (+ 1 s)) + (let ((r (vhash-assq key h))) + (when (not r) + (slot-set! x 'n (+ n 1))) + (slot-set! x 'h (vhash-consq key val h)) + (when (> s (* 2 n)) + (reshape x)) + (values)))) + +(define-syntax-rule (mset-py x key val) + (let ((f (mref-py x '__set__))) + (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))) + (hash-set! h key val))) + +(define-syntax-rule (mset-py- x key val) + (let ((f (mref-py- x '__set__))) + (if (or (eq? f not-implemented) (not f)) + (mset- x key val) + (f key val)))) + +(define-method (set (x <pf>) key val) (mset x key val)) +(define-method (set (x <p>) key val) (mset- x key val)) +(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) + (define-syntax-rule (mcall x key l) + (apply (mref y key '()) l))) + +(mk-call mcall mref) +(mk-call mcall- mref-) +(mk-call mcall-py mref-py) +(mk-call mcall-py- mref-py-) + +(define-method (call (x <pf>) key . l) (mcall x key l)) +(define-method (call (x <p>) key . l) (mcall- x key l)) +(define-method (call (x <pyf>) key . l) (mcall-py x key l)) +(define-method (call (x <py>) key . l) (mcall-py- x key l)) + + +;; make a copy of a pf object +(define-syntax-rule (mcopy x) + (let ((r (make <pf>))) + (slot-set! r 'h (slot-ref x 'h)) + (slot-set! r 'size (slot-ref x 'size)) + (slot-set! r 'n (slot-ref x 'n)) + r)) + +(define-syntax-rule (mcopy- x) + (let ((r (make-p)) + (h (slot-ref r 'h))) + (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h)) + r)) + +(define-method (copy (x <pf>)) (mcopy x)) +(define-method (copy (x <p> )) (mcopy- x)) + + +;; with will execute thunk and restor x to it's initial state after it has +;; finished note that this is a cheap operatoin because we use a functional +;; datastructure +(define-syntax-rule (mwith x thunk) + (let ((old (mcopy x))) + (let ((r (thunk))) + (slot-set! x 'h (slot-ref old 'h)) + (slot-set! x 'size (slot-ref old 'size)) + (slot-set! x 'n (slot-ref old 'n)) + r))) + +(define-syntax-rule (mwith- x thunk) + (let ((old (mcopy- x))) + (let ((r (thunk))) + (slot-set! x 'h (slot-ref old 'h)) + r))) + + + +;; a functional set will return a new object with the added binding and keep +;; x untouched +(define-method (fset (x <pf>) key val) + (let ((x (mcopy x))) + (mset x key val) + x)) + +(define-method (fset (x <p>) key val) + (let ((x (mcopy- x))) + (mset x key val) + x)) + +;; 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 +(define-method (fcall (x <pf>) key . l) + (let* ((y (mcopy x)) + (r (mcall y key l))) + (if (eq? (slot-ref x 'h) (slot-ref y 'h)) + (values r x) + (values r y)))) + +(define-method (fcall (x <p>) key . l) + (let ((x (mcopy x))) + (values (mcall- x key l) + x))) + +;; this shows how we can override addition in a pythonic way +(define-syntax-rule (mk-arith + +x __add__ __radd__) + (begin + (define-method (+ (x <p>) y) + (call x '__add__ y)) + + (define-method (+ x (y <p>)) + (call y '__radd__ x)) + + (define-method (+ (x <py>) y) + (let ((f (mref-py- x '__add__))) + (if f + (f y) + (+x y x)))) + + (define-method (+ (x <pyf>) y) + (let ((f (mref-py x '__add__))) + (if f + (let ((res (f y))) + (if (eq? res not-implemented) + (+x y x) + res)) + (+x y x)))) + + (define-method (+ (x <py>) y) + (let ((f (mref-py- x '__add__))) + (if f + (let ((res (f y))) + (if (eq? res not-implemented) + (+x y x) + res)) + (+x y x)))) + + (define-method (+ x (y <py>)) + (call y '__radd__ x)) + + (define-method (+ x (y <pyf>)) + (call y '__radd__ x)) + + (define-method (+x (x <p>) y) + (call x '__radd__ y)))) + +;; A few arithmetic operations at service +(mk-arith + +x __add__ __radd__) +(mk-arith - -x __sub__ __rsub__) +(mk-arith * *x __mul__ __rmul__) + +;; lets define get put pcall etc so that we can refer to an object like +;; e.g. (put x.y.z 1) (pcall x.y 1) + +(define-syntax-rule (cross x k f set) + (call-with-values (lambda () f) + (lambda (r y) + (if (eq? x y) + (values r x) + (values r (set x k y)))))) + +(define-syntax-rule (cross! x k f _) f) + +(define-syntax mku + (syntax-rules () + ((_ cross set setx f (key) (val ...)) + (setx f key val ...)) + ((_ cross setx f (k . l) val) + (cross f k (mku cross set setx (ref f k) l val) set)))) + +(define-syntax-rule (mkk pset setx set cross) + (define-syntax pset + (lambda (x) + (syntax-case x () + ((_ f val (... ...)) + (let* ((to (lambda (x) + (datum->syntax #'f (string->symbol x)))) + (l (string-split (symbol->string (syntax->datum #'f)) #\.))) + (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x)) + (cdr l))) + (h (to (car l)))) + #'(mku cross set h (a (... ...)) (val (... ...)))))))))) + +(mkk put fset fset cross) +(mkk put! set set cross!) +(mkk pcall! call fset cross!) +(mkk pcall fcall fset cross) +(mkk get ref fset cross!) + +;; it's good to have a null object so we don't need to construct it all the +;; time because it is functional we can get away with this. +(define null (make-pf)) + +;; append the bindings in x in front of y + some optimizations +(define (union x y) + (define hx (slot-ref x 'h)) + (define hy (slot-ref y 'h)) + (define n (slot-ref x 'n)) + (define s (slot-ref x 'size)) + (define m (make-hash-table)) + + (define h + (vhash-fold + (lambda (k v st) + (if (vhash-assq k hy) + (begin + (set! s (+ s 1)) + (vhash-consq k v st)) + (if (hash-ref m k) + s + (begin + (set! n (+ n 1)) + (set! s (+ s 1)) + (hash-set! m k #t) + (vhash-consq k v st))))) + hy + hx)) + + (define out (make <pf>)) + (slot-set! out 'h h) + (slot-set! out 'n n) + (slot-set! out 'size s) + out) + +(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) + out) + + +;; make a class. A class add some meta information to allow for multiple +;; inherritance and add effectively static data to the object the functional +;; datastructure show it's effeciency now const is data that will not change +;; and bindings that are added to all objects. Dynamic is the mutating class +;; information. supers is a list of priorities +(define-syntax-rule (mk-pf make-pf-class <pf>) + (define (make-pf-class name const dynamic supers) + (define class dynamic) + (define-class <pf> (<pf>)) + (put! class.__const__ + (union const + (let lp ((sup supers)) + (if (pair? sup) + (union (ref (car sup) '__const__ null) + (lp (cdr supers))) + null)))) + + (reshape (get class.__const__ null)) + + (put! class.__goops__ <pf>) + (put! class.__name__ name) + (put! class.__parents__ supers) + + (put! class.__const__.__name__ (cons name 'obj)) + (put! class.__const__.__class__ class) + (put! class.__const__.__parents__ supers) + class)) + +(mk-pf make-pf-class <pf>) +(mk-pf make-pf-class <pyf>) + +(define-syntax-rule (mk-p make-p-class <p>) + (define (make-p-class name const dynamic supers) + (define class dynamic) + (define-class <p> (<p>)) + (put! class.__const__ + (union- const + (let lp ((sup supers)) + (if (pair? sup) + (union- (ref (car sup) '__const__ null) + (lp (cdr supers))) + (make-p))))) + + + (put! class.__goops__ <p>) + (put! class.__name__ name) + (put! class.__parents__ supers) + + (put! class.__const__.__name__ (cons name 'obj)) + (put! class.__const__.__class__ class) + (put! class.__const__.__parents__ supers) + + (union- class (get class.__const__)))) + +(mk-p make-p-class <p>) +(mk-py 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 class.__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)) + +(define-method (mk (x <p>) . l) + (let ((k (make (get x.__goops__)))) + (put! r.__class__ x) + (apply (ref r '__init__ (lambda x (values))) r l) + r)) + +;; the make class and defclass syntactic sugar +(define-syntax-rule (mk-p/f mk-pf-class make-pf-class) + (define-syntax-rule (mk-pf-class name (parents (... ...)) + #:const + ((sdef mname sval) (... ...)) + #:dynamic + ((ddef dname dval) (... ...))) + (let () + (define name + (make-pf-class 'name + (let ((s (make-pf))) + (set s 'mname sval) (... ...) + s) + (let ((d (make-pf))) + (set d 'dname dval) (... ...) + d) + (list parents (... ...)))) + name))) + +(mk-p/f mk-pf-class make-pf-class) +(mk-p/f mk-p-class make-p-class) +(mk-p/f mk-pyf-class make-pyf-class) +(mk-p/f mk-py-class make-py-class) + +(define-syntax-rule (def-pf-class name . l) + (define name (mk-pf-class name . l))) + +(define-syntax-rule (def-p-class name . l) + (define name (mk-p-class name . l))) + +(define-syntax-rule (def-pyf-class name . l) + (define name (mk-pyf-class name . l))) + +(define-syntax-rule (def-py-class name . l) + (define name (mk-py-class name . l))) + |