diff options
Diffstat (limited to 'modules/oop')
-rw-r--r-- | modules/oop/#a# | 2 | ||||
-rw-r--r-- | modules/oop/pf-objects.go | bin | 594109 -> 0 bytes | |||
-rw-r--r-- | modules/oop/pf-objects.scm.bak | 1072 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm~ | 502 |
4 files changed, 0 insertions, 1576 deletions
diff --git a/modules/oop/#a# b/modules/oop/#a# deleted file mode 100644 index aec1575..0000000 --- a/modules/oop/#a# +++ /dev/null @@ -1,2 +0,0 @@ -#<<applicable-struct-class> type 560f4ada9630> -#<<applicable-struct-class> type 560f4ada9630>
\ No newline at end of file diff --git a/modules/oop/pf-objects.go b/modules/oop/pf-objects.go Binary files differdeleted file mode 100644 index ad26a63..0000000 --- a/modules/oop/pf-objects.go +++ /dev/null diff --git a/modules/oop/pf-objects.scm.bak b/modules/oop/pf-objects.scm.bak deleted file mode 100644 index 8946c59..0000000 --- a/modules/oop/pf-objects.scm.bak +++ /dev/null @@ -1,1072 +0,0 @@ -(define-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (ice-9 vlist) - #:use-module (ice-9 match) -<<<<<<< HEAD - #:use-module (system base message) - #:use-module (language python guilemod) -======= - #:use-module (ice-9 pretty-print) ->>>>>>> d71244f5cb87a4a61a6b341e4838a38e50142815 - #:use-module (logic guile-log persistance) - #:replace (equal?) - #:export (set ref make-p <p> <py> <pf> <pyf> <property> - call with copy fset fcall put put! - pcall pcall! get fset-x pyclass? - def-p-class mk-p-class make-p-class - define-python-class get-type py-class - object-method class-method static-method - py-super-mac py-super py-equal? - *class* *self* pyobject? pytype? - type object pylist-set! pylist-ref tr - resolve-method rawref rawset - )) - -#| -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 fail (cons 'fail '())) - -(define-syntax-rule (kif it p x y) - (let ((it p)) - (if (eq? it fail) - y - x))) - -(define-method (pylist-set! (o <hashtable>) key val) - (hash-set! o key val)) - -(define-method (pylist-ref (o <hashtable>) key) - (kif it (hash-ref o key fail) - it - (error "IndexError"))) - -(define (is-acl? a b) (member a (cons b (class-subclasses b)))) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) -(define-class <p> (<applicable-struct> <object>) 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>)) - -(define-class <property> () get set del) - -(name-object <p>) -(name-object <pf>) -(name-object <py>) -(name-object <pyf>) -(name-object <property>) - -(define (resolve-method-g g pattern) - (define (mmatch p pp) - (if (eq? pp '_) - '() - (match (cons p pp) - (((p . ps) . (pp . pps)) - (if (eq? pp '_) - (mmatch ps pps) - (if (is-a? p pp) - (cons p (mmatch ps pps)) - #f))) - ((() . ()) - '()) - (_ - #f)))) - - (define (q< x y) - (let lp ((x x) (y y)) - (match (cons x y) - (((x . xs) . (y . ys)) - (and (is-a? x y) - (lp xs ys))) - (_ #t)))) - - (let ((l - (let lp ((ms (generic-function-methods g))) - (if (pair? ms) - (let* ((m (car ms)) - (p (method-specializers m)) - (f (method-generic-function m))) - (aif it (mmatch p pattern) - (cons (cons it f) (lp (cdr ms))) - (lp (cdr ms)))) - '())))) - - - (cdr (car (sort l q<))))) - -(define (resolve-method-o o pattern) - (resolve-method-g (class-of o) pattern)) - -(define (get-dict self name parents) - (aif it (ref self '__prepare__) - (it self name parents) - (make-hash-table))) - -(define (hashforeach a b) (values)) - -(define (new-class meta name parents dict kw) - (aif it (ref meta '__new__) - (apply it name parents dict kw) - (let* ((goops (pylist-ref dict '__goops__)) - (p (kwclass->class kw meta)) - (class (make-p p))) - (slot-set! class 'procedure - (lambda x - (create-object class meta goops x))) - (if (hash-table? dict) - (hash-for-each - (lambda (k v) k (set class k v)) - dict) - (hashforeach - (lambda (k v) k (set class k v)) - dict)) - (let((mro (ref class '__mro__))) - (if (pair? mro) - (let ((p (car mro))) - (aif it (ref p '__init_subclass__) - (apply it class #f kw) - #f)))) - (set class '__mro__ (cons class (ref class '__mro__))) - class))) - -(define (type- meta name parents dict keys) - (let ((class (new-class meta name parents dict keys))) - (aif it (ref meta '__init__) - (it name parents dict keys) - #f) - class)) - -(define (create-class meta name parents gen-methods . keys) - (let ((dict (gen-methods (get-dict meta name keys)))) - (aif it (ref meta '__class__) - (aif it (find-in-class (ref meta '__class__) '__call__ #f) - (apply (it meta 'class) name parents dict keys) - (type- meta name parents dict keys)) - (type- meta name parents dict keys)))) - -(define (create-object class meta goops x) - (with-fluids ((*make-class* #t)) - (aif it #f ;(ref meta '__call__) - (apply it x) - (let ((obj (aif it (find-in-class class '__new__ #f) - ((it class 'object)) - (make-object class meta goops)))) - (aif it (ref obj '__init__) - (apply it x) - #f) - (slot-set! obj 'procedure - (lambda x - (aif it (ref obj '__call__) - (apply it x) - (error "not a callable object")))) - obj)))) - -(define (make-object class meta goops) - (let ((obj (make-p goops))) - (set obj '__class__ class) - obj)) - -;; Make an empty pf object -(define (make-p <x>) - (let ((r (make <x>))) - (cond - ((is-a? r <pf>) - (slot-set! r 'h vlist-null) - (slot-set! r 'size 0) - (slot-set! r 'n 0)) - ((is-a? r <p>) - (slot-set! r 'h (make-hash-table))) - (else - (error "make-p in pf-objects need a <p> or <pf> derived class got ~a" - r))) - 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-syntax-rule (mrefx x key l) - (let () - (define (end) - (if (null? l) - #f - (car l))) - - (define (parents li) - (let lp ((li li)) - (if (pair? li) - (let ((p (car li))) - (cif (it h) (key p) - it - (lp (cdr li)))) - fail))) - - (cif (it h) (key x) - it - (hif cl ('__class__ h) - (cif (it h) (key cl) - it - (hif p ('__mro__ h) - (let ((r (parents p))) - (if (eq? r fail) - (end) - r)) - (end))) - (end))))) - -(define *refkind* (make-fluid 'object)) - -(define-method (find-in-class (klass <p>) key fail) - (hash-ref (slot-ref klass 'h) key fail)) - -(define-method (find-in-class (klass <pf>) key fail) - (let ((r (vhash-assoc key (slot-ref klass 'h)))) - (if r - (cdr r) - fail))) - -(define-syntax-rule (find-in-class-and-parents klass key fail) - (kif r (find-in-class klass key fail) - r - (aif parents (find-in-class klass '__mro__ #f) - (let lp ((parents parents)) - (if (pair? parents) - (kif r (find-in-class (car parents) key fail) - r - (lp (cdr parents))) - fail)) - fail))) - -(define-syntax-rule (mrefx klass key l) - (let () - (define (end) (if (pair? l) (car l) #f)) - (fluid-set! *refkind* 'object) - (kif it (find-in-class klass key fail) - it - (begin - (fluid-set! *refkind* 'class) - (aif klass (find-in-class klass '__class__ #f) - (kif it (find-in-class-and-parents klass key fail) - it - (end)) - (end)))))) - -(define not-implemented (cons 'not 'implemeneted)) - -(define-syntax-rule (prop-ref xx x) - (let ((y xx) - (r x)) - (if (and (is-a? r <property>) (not (pyclass? y))) - ((slot-ref r 'get) y) - r))) - -(define-syntax-rule (mrefx-py x key l) - (let ((xx x)) - (prop-ref - xx - (let* ((g (mrefx xx '__fget__ '(#t))) - (f (if g - (if (eq? g #t) - (aif it (mrefx xx '__getattribute__ '()) - (begin - (mset xx '__fget__ it it) - it) - (begin - (if (mc?) - (mset xx '__fget__ it it)) - #f)) - g) - #f))) - (if (or (not f) (eq? f not-implemented)) - (mrefx xx key l) - (catch #t - (lambda () ((f xx (fluid-ref *refkind*)) key)) - (lambda x - (mrefx xx key l)))))))) - - -(define-syntax-rule (mref x key l) - (let ((xx x)) - (let ((res (mrefx xx key l))) - (if (and (not (struct? res)) (procedure? res)) - (res xx (fluid-ref *refkind*)) - res)))) - -(define-syntax-rule (mref-py x key l) - (let ((xx x)) - (let ((res (mrefx-py xx key l))) - (if (and (not (struct? res)) (procedure? res)) - (res xx (fluid-ref *refkind*)) - res)))) - -(define-method (ref x key . l) (if (pair? l) (car l) #f)) -(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)) - -(define-method (rawref (x <pf> ) key . l) (mref x key l)) -(define-method (rawref (x <p> ) key . l) (mref x key l)) - - -(define-method (set (f <procedure>) key val) - (set-procedure-property! f key val)) - -(define-method (ref (f <procedure>) key . l) - (aif it (assoc key (procedure-properties f)) - (cdr it) - (if (pair? l) (car l) #f))) - - -;; 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-method (mset (x <pf>) key rval 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-assoc key h))) - (when (not r) - (slot-set! x 'n (+ n 1))) - (slot-set! x 'h (vhash-cons key val h)) - (when (> s (* 2 n)) - (reshape x)) - (values)))) - -(define (pkh h) (hash-for-each (lambda x (pk x)) h) h) - -(define-method (mset (x <p>) key rval val) - (begin - (hash-set! (slot-ref x 'h) key val) - (values))) - -(define *make-class* (make-fluid #f)) -(define (mc?) (not (fluid-ref *make-class*))) - -(define-syntax-rule (mset-py x key rval val) - (let* ((xx x) - (v (mref xx key (list fail)))) - (if (or (eq? v fail) - (not (and (is-a? v <property>) - (not (pyclass? xx))))) - (let* ((g (mrefx xx '__fset__ '(#t))) - (f (if g - (if (eq? g #t) - (aif it (mrefx xx '__setattr__ '()) - (begin - (mset xx '__fset__ it it) - it) - (begin - (if (mc?) - (mset xx '__fset__ it it)) - #f)) - g) - #f))) - (if (or (eq? f not-implemented) (not f)) - (mset xx key val val) - (catch #t - (lambda () ((f xx (fluid-ref *refkind*)) key rval)) - (lambda x (mset xx key val val))))) - ((slot-ref v 'set) xx val)))) - -(define-syntax-rule (mklam (mset a ...) val) - (if (and (procedure? val) - (not (pyclass? val)) - (not (pytype? val)) - (if (is-a? val <p>) - (ref val '__call__) - #t)) - (if (procedure-property val 'py-special) - (mset a ... val val) - (mset a ... val (object-method val))) - (mset a ... val val))) - -(define-method (set (x <pf>) key val) (mklam (mset x key) val)) -(define-method (set (x <p>) key val) (mklam (mset x key) val)) -(define-method (set (x <pyf>) key val) (mklam (mset-py x key) val)) -(define-method (set (x <py>) key val) (mklam (mset-py x key) val)) - -(define-method (rawset (x <pf>) key val) (mklam (mset x key) val)) -(define-method (rawset (x <p>) key val) (mklam (mset 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-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-p (ref x '__goops__)))) - (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 (ref x '__goops__))) - (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)) - -;; 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 <pf>) (x <pf>)) (mtr r x)) -(define-method (tr (r <p> ) (x <p> )) (mtr- r 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 val) - x)) - -(define-method (fset (x <p>) key val) - (let ((x (mcopy- x))) - (mset x key val 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 -(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 - -;; 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-p <pf>)) - -(define (filter-parents l) - (let lp ((l l)) - (if (pair? l) - (if (is-a? (car l) <p>) - (cons (car l) (lp (cdr l))) - (lp (cdr l))) - '()))) - -(define (kw->class kw meta) - (if (memq #:functional kw) - (if (memq #:fast kw) - <pf> - (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>)) - <pyf> - <pf>)) - (if (memq #:fast kw) - (if (or (is-a? meta <pyf>) (is-a? meta <pf>)) - <pf> - <p>) - (cond - ((is-a? meta <pyf>) - <pyf>) - ((is-a? meta <py>) - <py>) - ((is-a? meta <pf>) - <pf>) - ((is-a? meta <p>) - <p>) - (else - <py>))))) - - -(define (defaulter d) - (if d - (cond - ((is-a? d <pyf>) - <pyf>) - ((is-a? d <py>) - <py>) - ((is-a? d <pf>) - <pf>) - ((is-a? d <p>) - <p>) - (else - d)) - <py>)) - -(define (kwclass->class kw default) - (if (memq #:functionalClass kw) - (if (memq #:fastClass kw) - <pf> - (if (memq #:pyClass kw) - <pyf> - (if (or (is-a? default <py>) (is-a? default <pyf>)) - <pyf> - <pf>))) - (if (memq #:mutatingClass kw) - (if (memq #:fastClass kw) - <p> - (if (memq #:pyClass kw) - <py> - (if (or (is-a? default <py>) (is-a? default <pyf>)) - <py> - <p>))) - (if (memq #:fastClass kw) - (if (or (is-a? default <pf>) (is-a? default <pyf>)) - <pf> - <p>) - (if (memq #:pyClass kw) - (if (or (is-a? default <pf>) (is-a? default <pyf>)) - <pyf> - <py>) - (defaulter default)))))) - -(define object #f) -(define (make-p-class name supers.kw methods) - (define kw (cdr supers.kw)) - (define supers (car supers.kw)) - (define goopses (map (lambda (sups) - (aif it (ref sups '__goops__ #f) - it - sups)) - supers)) - (define parents (let ((p (filter-parents supers))) - (if (null? p) - (if object - (list object) - '()) - p))) - - (define meta (aif it (memq #:metaclass kw) - (car it) - (if (null? parents) - type - (let* ((p (car parents)) - (m (ref p '__class__)) - (mro (reverse (ref m '__mro__)))) - (let lp ((l (cdr parents)) - (max mro) - (min mro)) - (if (pair? l) - (let* ((p (car l)) - (meta (ref p '__class__)) - (mro (ref meta '__mro__))) - (let lp2 ((max max) (mr (reverse mro))) - (if (and (pair? max) (pair? mr)) - (if (eq? (car max) (car mr)) - (lp2 (cdr max) (cdr mr)) - (error - "need a common lead for meta")) - (if (pair? max) - (if (< (length mro) (length min)) - (lp (cdr l) max mro) - (lp (cdr l) max min)) - (lp (cdr l) mro min))))) - (car (reverse min)))))))) - - (define goops (make-class (append goopses (list (kw->class kw meta))) - '() #:name name)) - - (define (gen-methods dict) - (methods dict) - (pylist-set! dict '__goops__ goops) - (pylist-set! dict '__class__ meta) - (pylist-set! dict '__fget__ #t) - (pylist-set! dict '__fset__ #t) - (pylist-set! dict '__name__ name) - (pylist-set! dict '__parents__ parents) - (pylist-set! dict '__class__ meta) - (pylist-set! dict '__mro__ (get-mro parents)) - dict) - - (with-fluids ((*make-class* #t)) - (create-class meta name parents gen-methods kw))) - - -;; Let's make an object essentially just move a reference - -;; the make class and defclass syntactic sugar -(define-syntax mk-p-class - (lambda (x) - (syntax-case x () - ((_ name parents (ddef dname dval) ...) - (with-syntax (((ddname ...) - (map (lambda (dn) - (datum->syntax - #'name - (string->symbol - (string-append - (symbol->string - (syntax->datum #'name)) - "-" - (symbol->string - (syntax->datum dn)))))) - #'(dname ...))) - (nname (datum->syntax - #'name - (string->symbol - (string-append - (symbol->string - (syntax->datum #'name)) - "-goops-class"))))) - (%add-to-warn-list (syntax->datum #'nname)) - (map (lambda (x) (%add-to-warn-list (syntax->datum x))) - #'(ddname ...)) - #'(let () - (define name - (letruc ((dname dval) ...) - (make-p-class 'name - parents - (lambda (dict) - (pylist-set! dict 'dname dname) - ... - (values))))) - - (begin - (module-define! (current-module) 'ddname (ref name 'dname)) - (name-object ddname)) - ... - - (module-define! (current-module) 'nname (ref name '__goops__)) - (name-object nname) - (name-object name) - name)))))) - -(define-syntax-rule (def-p-class name . l) - (define name (mk-p-class name . l))) - -(define (get-class o) - (cond - ((is-a? o <p>) - o) - (else - (error "not a pyclass")))) - -(define (get-type o) - (cond - ((is-a? o <pyf>) - 'pyf) - ((is-a? o <py>) - 'py) - ((is-a? o <pf>) - 'pf) - ((is-a? o <p>) - 'p) - (else - 'none))) - -(define (print o l) - (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T"))) - (define port (if (pair? l) (car l) #t)) - (format port "~a" - (aif it (if (pyclass? o) - #f - (if (pyobject? o) - (ref o '__repr__) - #f)) - (format - #f "~a(~a)<~a>" - p (get-type o) (it)) - (format - #f "~a(~a)<~a>" - p (get-type o) (ref o '__name__ 'Annonymous))))) - -(define-method (write (o <p>) . l) (print o l)) -(define-method (display (o <p>) . l) (print o l)) - -(define (arglist->pkw l) - (let lp ((l l) (r '())) - (if (pair? l) - (let ((x (car l))) - (if (keyword? x) - (cons (reverse r) l) - (lp (cdr l) (cons x r)))) - (cons (reverse r) '())))) - -(define-syntax-rule (define-python-class name (parents ...) code ...) - (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...))) - - -(define-syntax make-python-class - (lambda (x) - (syntax-case x () - ((_ name (parents ...) code ...) - #'(let* ((cl (mk-p-class name - (arglist->pkw (list parents ...)) - code ...))) - cl))))) - - -(define (kind x) - (and (is-a? x <p>) - (aif it (find-in-class x '__goops__ #f) - (if (is-a? (make it) (ref type '__goops__)) - 'type - 'class) - 'object))) - -(define (pyobject? x) (eq? (kind x) 'object)) -(define (pyclass? x) (eq? (kind x) 'class)) -(define (pytype? x) (eq? (kind x) 'type)) - -(define (mark-fkn tag f) - (set-procedure-property! f 'py-special tag) - f) - -(define (object-method f) - (letrec ((self - (mark-fkn 'object - (lambda (x kind) - (if (eq? kind 'object) - f - (lambda z (apply f x z))))))) - self)) - -(define (class-method f) - (letrec ((self - (mark-fkn 'class - (lambda (x kind) - (if (eq? kind 'object) - (let ((klass (ref x '__class__))) - (lambda z (apply f klass z))) - (lambda z (apply f x z))))))) - self)) - -(define (static-method f) - (letrec ((self - (mark-fkn 'static - (lambda (x kind) f)))) - self)) - - -(define-syntax-parameter - *class* (lambda (x) (error "*class* not parameterized"))) -(define-syntax-parameter - *self* (lambda (x) (error "*class* not parameterized"))) - -(define *super* (list 'super)) - -(define (not-a-super) 'not-a-super) -(define (py-super class obj) - (define (make cl parents) - (let ((c (make-p <p>)) - (o (make-p <p>))) - (set c '__super__ #t) - (set c '__mro__ parents) - (set c '__getattribute__ (lambda (self key . l) - (aif it (ref c key) - (if (procedure? it) - (if (eq? (procedure-property - it - 'py-special) - 'class) - (it cl) - (it obj)) - it) - (error "no attribute")))) - (set o '__class__ c) - o)) - - (call-with-values - (lambda () - (let lp ((l (ref (ref obj '__class__) '__mro__ '()))) - (if (pair? l) - (if (eq? class (car l)) - (let ((r (cdr l))) - (if (pair? r) - (values (car r) r) - (values #f #f))) - (lp (cdr l))) - (values #f #f)))) - make)) - - - -(define-syntax py-super-mac - (syntax-rules () - ((_) - (py-super *class* *self*)) - ((_ class self) - (py-super class self)))) - -(define (pp x) - (pretty-print (syntax->datum x)) - x) - -(define-syntax letruc - (lambda (x) - (syntax-case x () - ((_ ((x v) ...) code ...) - (let lp ((a #'(x ...)) (b #'(v ...)) (u '())) - (if (pair? a) - (let* ((x (car a)) - (s (syntax->datum x))) - (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '()) - (r (list (car b)))) - (if (pair? a2) - (if (eq? (syntax->datum a2) s) - (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r)) - (lp2 (cdr a2) (cdr b2) - (cons (car a2) a3) - (cons (car b2) b3) - r)) - (lp (reverse a3) (reverse b3) - (cons - (list x #`(let* #,(map (lambda (v) (list x v)) - (reverse r)) #,x)) - u))))) - #`(letrec #,(reverse u) code ...))))))) - - - - -(define-method (py-init (o <p>) . l) - (apply (ref o '__init__) l)) - -(define mk-tree - (case-lambda - ((root) - (vector root '())) - ((root hist) (vector root hist)))) - -(define (geth t) (vector-ref t 1)) -(define (getr t) (vector-ref t 0)) -(define (tree-ref t) (car (getr t))) - -(define (nxt tree) - (define (dive r h) - (let ((x (car r))) - (if (pair? x) - (dive (car r) (cons (cdr r) h)) - (mk-tree r h)))) - - (define (up r h) - (if (null? r) - (if (pair? h) - (up (car h) (cdr h)) - #f) - (let ((x (car r))) - (if (pair? x) - (dive r h) - (mk-tree r h))))) - - (let ((r (getr tree)) (h (geth tree))) - (cond - ((pair? r) - (let ((r (cdr r))) - (if (pair? r) - (let ((x (car r))) - (if (pair? x) - (dive x (cons (cdr r) h)) - (mk-tree r h))) - (if (pair? h) - (up (car h) (cdr h)) - #f)))) - (else - (if (pair? h) - (up (car h) (cdr h)) - #f))))) - -(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__)))) - -(define (find-tree o tree) - (if tree - (let ((x (tree-ref tree))) - (if (eq? o x) - #t - (find-tree o (nxt tree)))) - #f)) - -(define (get-mro parents) - (if (null? parents) - parents - (get-mro0 parents))) - -(define (get-mro0 parents) - (define tree (mk-tree parents)) - (let lp ((tree tree) (r '())) - (if tree - (let ((x (tree-ref tree)) - (n (nxt tree))) - (if (find-tree x n) - (lp n r) - (lp n (cons x r)))) - (reverse r)))) - -(define-method (py-equal? (x <p>) y) - (aif it (ref x '__eq__) - (it y) - (next-method))) - -(define-method (py-equal? y (x <p>)) - (aif it (ref x '__eq__) - (it y) - (next-method))) - -(define-method (py-equal? x y) ((@ (guile) equal?) x y)) - -(define (equal? x y) (or (eq? x y) (py-equal? x y))) - -(define type #f) -(set! type - (make-python-class type () - (define __call__ - (case-lambda - ((meta obj) - (ref obj '__class__ 'None)) - ((meta name bases dict . keys) - (type- meta name bases dict keys)))))) -(set type '__class__ type) - -(set! object (make-python-class object ())) - -(name-object type) -(name-object object) diff --git a/modules/oop/pf-objects.scm~ b/modules/oop/pf-objects.scm~ deleted file mode 100644 index a8f120e..0000000 --- a/modules/oop/pf-objects.scm~ +++ /dev/null @@ -1,502 +0,0 @@ -(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))) - |