diff options
Diffstat (limited to 'modules/oop/pf-objects.scm.bak')
| -rw-r--r-- | modules/oop/pf-objects.scm.bak | 1072 |
1 files changed, 1072 insertions, 0 deletions
diff --git a/modules/oop/pf-objects.scm.bak b/modules/oop/pf-objects.scm.bak new file mode 100644 index 0000000..8946c59 --- /dev/null +++ b/modules/oop/pf-objects.scm.bak @@ -0,0 +1,1072 @@ +(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) |