From 79f06168aa626017b56c67f7ea8f101f3d15e5d2 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Sat, 21 Oct 2017 16:16:02 +0200 Subject: refactoring functional objects --- modules/language/python/compile.scm | 38 +-- modules/language/python/dir.scm | 73 +++--- modules/language/python/eval.scm | 1 - modules/language/python/list.scm | 12 +- modules/language/python/module/python.scm | 18 +- modules/language/python/set.scm | 4 +- modules/oop/pf-objects.scm | 403 +++++++++++++++++------------- 7 files changed, 293 insertions(+), 256 deletions(-) (limited to 'modules') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index a040c7d..10320f5 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -407,7 +407,7 @@ '())))) (define (kw->li dict) - (for ((k v : dict) (l '())) + (for ((k v : dict)) ((l '())) (cons* v (symbol->keyword (string->symbol k)) l) #:final (reverse l))) @@ -528,12 +528,12 @@ `(,s/d ,v (,(C 'setwrap) ,u))) (if op `(,s/d ,(exp vs kind) - (,(O 'fset-x) ,v (list ,@(map q addings)) + (,(C 'fset-x) ,v ,addings (,(C 'setwrap) (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))) `(,s/d ,(exp vs kind) - (,(O 'fset-x) ,v (list ,@(map q addings)) + (,(C 'fset-x) ,v ,addings (,(C 'setwrap) ,u))))) (if (null? addings) @@ -757,26 +757,24 @@ r)) (class (exp vs class)) (parents (match parents - (() - (cons '() '())) - (#f - (cons '() '())) + (() #f) + (#f #f) ((#:arglist . _) - (get-addings vs (list parents))))) - (is-func (is-functional parents)) - (parents (filt parents))) + (get-addings vs (list parents)))))) `(define ,class (,(C 'class-decor) ,decor (,(C 'with-class) ,class - (,(mk-p-class - ,class - (,(C 'ref-x) ,(C 'arglist->pkw) ,@parents) + (,(C 'mk-p-class) + ,class + ,(if parents + `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents) + `(,(G 'cons) '() '())) ,@(match (filter-defs (exp vs defs)) (('begin . l) l) ((('begin . l)) l) - (l l)))))))))))) + (l l))))))))))) (#:scm ((_ (#:string _ s)) (with-input-from-string s read))) @@ -1702,9 +1700,9 @@ ((_ v (#:fast-id f _) . l) (ref-x (f v) . l)) ((_ v (#:identifier x) . l) - (ref-x (refq v x) . l)) + (ref-x (ref v x) . l)) ((_ v (#:identifier x) . l) - (ref-x (refq v x) . l)) + (ref-x (ref v x) . l)) ((_ v (#:call-obj x) . l) (ref-x (x v) . l)) ((_ v (#:call x ...) . l) @@ -1721,7 +1719,7 @@ (define-syntax del-x (syntax-rules () ((_ v (#:identifier x)) - (ref-x (refq v 'x))) + (ref-x (ref v 'x))) ((_ v (#:call-obj x)) (values)) ((_ v (#:call x ...)) @@ -1738,6 +1736,11 @@ ((_ v (a ... b) val) (set-x-2 (ref-x v a ...) b val)))) +(define-syntax fset-x + (syntax-rules () + ((_ v ((#:identifier x) ...) val) + ((@ (oop pf-objects) fset-x) v (list x ...) val)))) + (define-syntax set-x-2 (syntax-rules () ((_ v (#:fastfkn-ref f id) val) @@ -1775,3 +1778,4 @@ (syntax-rules () ((_ s c) (syntax-parameterize ((*class* (lambda (x) #'s))) c)))) + diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm index 30e47ac..da07642 100644 --- a/modules/language/python/dir.scm +++ b/modules/language/python/dir.scm @@ -15,23 +15,24 @@ (define-method (dir) (pylist)) -(define (get-from-class c f) - (let lp ((c c)) - (hash-for-each f (slot-ref c 'h)) - (let lpp ((pl (ref c '__parents__))) - (if (pair? pl) - (begin - (lp (car pl)) - (lpp (cdr pl))))))) +(define (chash-for-each f c) + (let ((h (slot-ref c 'h))) + (if (is-a? c ) + (let ((hh (make-hash-table))) + (vhash-fold + (lambda (k v s) + (when (not (hash-ref hh k)) + (hash-set! hh k #t) + (f k v)) + s) #f h)) + (hash-for-each f h)))) -(define (get-from-class-f c f) - (let lp ((c c)) - (vhash-fold f 0 (slot-ref c 'h)) - (let lpp ((pl (ref c '__parents__))) - (if (pair? pl) - (begin - (lp (car pl)) - (lpp (cdr pl))))))) +(define (get-from-class c f) + (let lp ((pl (ref c '__mro__))) + (if (pair? pl) + (begin + (chash-for-each f (car pl)) + (lp (cdr pl)))))) (define-method (dir (o

)) (if (not (pyclass? o)) @@ -47,7 +48,7 @@ (c (ref o '__class__)) (l '()) (f (lambda (k v) (set! l (cons k l))))) - (hash-for-each f (slot-ref o 'h)) + (chash-for-each f o) (get-from-class c f) (hash-for-each (lambda (k v) (pylist-append! l k)) h) (to-pylist (map symbol->string (sort l <)))))) @@ -59,32 +60,6 @@ (hash-for-each (lambda (k v) (set! l (cons k l))) h) (to-pylist (map symbol->string (sort l <)))))) -(define-method (dir (o )) - (if (not (pyclass? o)) - (aif it (ref o '__dir__) - (it) - (aif it (ref o '__dict__) - (let ((l (pylist))) - (for ((k v : it)) () - (pylist-append! l k)) - (pylist-sort! l) - l) - (let* ((h (make-hash-table)) - (c (ref o '__class__)) - (l '()) - (f (lambda (k v s) (set! l (cons k l))))) - (vhash-fold f 0 (slot-ref o 'h)) - (get-from-class-f c f) - (hash-for-each (lambda (k v) (pylist-append! l k)) h) - (to-pylist (map symbol->string (sort l <)))))) - (let* ((h (make-hash-table)) - (c o) - (l '()) - (f (lambda (k v s) (pylist-append! h k #t)))) - (get-from-class-f c f) - (hash-for-each (lambda (k v) (set! l (cons k l))) h) - (to-pylist (map symbol->string (sort l <)))))) - (define-method (dir (o )) (let ((l1 (pk (pylist-listing)))) (if (is-a? o

) @@ -172,6 +147,16 @@ (let ((ret (to-pylist l))) (pylist-sort! ret) ret))) - + +(define-method (dir (o )) + (let ((ret (to-pylist (map (lambda (x) + (let ((x (car x))) + (if (symbol? x) + (symbol->string x) + x))) + (procedure-properties o))))) + (pylist-sort! ret) + ret)) + diff --git a/modules/language/python/eval.scm b/modules/language/python/eval.scm index 999acc0..53b4bce 100644 --- a/modules/language/python/eval.scm +++ b/modules/language/python/eval.scm @@ -1,5 +1,4 @@ (define-module (language python eval) - #:use-module #:use-module (parser stis-parser lang python3-parser) #:use-module (language python exceptions) #:use-module ((ice-9 local-eval) #:select ((the-environment . locals))) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index ded6b15..34c9ba0 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -11,7 +11,7 @@ #:use-module (language python try) #:use-module (language python exceptions) #:export (to-list to-pylist - pylist-ref pylist-set! pylist-append! + pylist-append! pylist-slice pylist-subset! pylist-reverse! pylist-pop! pylist-count pylist-extend! len in pylist-insert! pylist-remove! pylist-sort! @@ -822,11 +822,11 @@ (let ((n1 (len o1)) (n2 (len o2))) (for ((x1 : o1) (x2 : o2)) () - (if (> x1 x2) - (break #t)) - #:final - (>= n1 n2)))) - + (if (> x1 x2) + (break #t)) + #:final + (>= n1 n2)))) + (define-python-class list () (define __init__ (letrec ((__init__ diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index bd68841..02f4e5e 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -3,8 +3,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 readline) #:use-module ((oop pf-objects) #:select - (

class-method static-method refq - py-super-mac)) + (

class-method static-method ref + py-super-mac type object pylist-ref)) #:use-module (language python exceptions ) #:use-module (language python def ) #:use-module (language python for ) @@ -35,7 +35,7 @@ SyntaxError len dir next dict None property range tuple bytes bytearray eval locals globals - compile exec type + compile exec type object ) #:export (print repr complex float int @@ -76,7 +76,7 @@ (define-method (callable (x )) #t) (define-method (callable (x )) #t) (define-method (callable (x

)) - (refq x '__call__)) + (ref x '__call__)) (define chr integer->char) @@ -100,17 +100,17 @@ (define miss ((@ (guile) list) 'miss)) (define* (getattr a b #:optional (k miss)) - (let ((r (refq a (symbol->string b) k))) + (let ((r (ref a (symbol->string b) k))) (if (eq? r miss) (raise AttributeError "object/class ~a is missing attribute ~a" a b) r))) (define (hasattr a b) - (let ((r (refq a (symbol->string b) miss))) + (let ((r (ref a (symbol->string b) miss))) (not (eq? r miss)))) (define-method (issubclass (sub

) (cls

)) - (aif it (ref cl '__subclasscheck__) + (aif it (ref cls '__subclasscheck__) (it sub) (is-a? (ref sub '__goops__) (ref cls '__goops__)))) @@ -121,13 +121,13 @@ (or (isinstance o (car cl)) (isinstance o (cdr cl))) - (is-a? (ref (ref o '__class__) '__goops__) cl))) + (is-a? (ref (ref o '__class__) '__goops__) cl)))) (define iter (case-lambda ((o) (aif it (wrap-in o) it - (aif get (refq o '__getitem__) + (aif get (ref o '__getitem__) (make-generator iter (lambda (yield) (for () ((i 0)) diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm index ef4abe7..e9d7c63 100644 --- a/modules/language/python/set.scm +++ b/modules/language/python/set.scm @@ -23,7 +23,7 @@ (slot-set! self 'dict d) (for ((y : x)) () (pylist-set! d y #t)))))) - + (define pop (lambda (self) (call-with-values (lambda () (pylist-pop! (slot-ref self 'dict))) @@ -32,7 +32,7 @@ (define add (lambda (self k) (pylist-set! (slot-ref self 'dict) k #t))) - + (define copy (lambda (self) (let ((dict (py-copy (slot-ref self 'dict)))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index d5e9e5f..86ffd20 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -3,15 +3,15 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:replace (equal?) - #:export (set ref make-pf

- call with copy fset fcall make-p put put! - pcall pcall! get fset-x pyclass? refq + #:export (set ref make-p

+ 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* type pyobject? pytype? - type object + *class* *self* pyobject? pytype? + type object pylist-set! pylist-ref )) #| Python object system is basically syntactic suger otop of a hashmap and one @@ -27,8 +27,26 @@ 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 ) key val) + (hash-set! o key val)) + +(define-method (pylist-ref (o ) 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

() h) +(define-class

( ) h) (define-class (

) size n) ; the pf object consist of a functional ; hashmap it's size and number of live ; object @@ -37,23 +55,6 @@ explicitly tell it to not update etc. (define-class () get set del) -(define (mk-p/pf o) - (cond - ((is-a? x ) - (let ((r (ref x '__const__))) - (slot-set! o 'h (slot-ref r 'h)) - (slot-set! o 'size (slot-ref r 'size)) - (slot-set! o 'n (slot-ref r 'n)) - o)) - - ((is-a? x

) - (let ((r (ref x '__const__)) - (h (make-hash-table))) - (hash-set! h '__class__ x) - (slot-set! o 'h h))) - (else #f)) - (values)) - (define (get-dict self name parents) (aif it (ref self '__prepare__) (it self name parents) @@ -61,17 +62,16 @@ explicitly tell it to not update etc. (define (hashforeach a b) (values)) -(define (new-class meta name parents dict keys) - (aif it (ref self '__new__) - (apply it name parents dict keys) - (let* ((goops (ref dict '__goops__)) - (p (kwclass->class kw meta)) - (class (make p))) +(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))) - (set class '__class__ meta) - (if (hashtable? dict) + (if (hash-table? dict) (hash-for-each (lambda (k v) (set class k v)) dict) @@ -82,8 +82,9 @@ explicitly tell it to not update etc. (if (pair? mro) (let ((p (car mro))) (aif it (ref p '__init_subclass__) - (apply it class #f keys) + (apply it class #f kw) #f)))) + (set class '__mro__ (cons class (ref class '__mro__))) class))) (define (type- meta name parents dict keys) @@ -95,20 +96,22 @@ explicitly tell it to not update etc. (define (create-class meta name parents gen-methods . keys) (let ((dict (gen-methods (get-dict meta name keys)))) - (aif it (find-in-class (ref meta '__class__) '__call__ #f) - (apply (it meta 'object) name parents dict keys) + (aif it (ref meta '__class__) + (aif it (find-in-class (ref meta '__class__) '__call__ #f) + (apply (it meta 'object) name parents dict keys) + (type- meta name parents dict keys)) (type- meta name parents dict keys)))) (define (create-object class meta goops x) - (aif it (ref meta '__call__) + (aif it #f ;(ref meta '__call__) (apply it x) - (let ((obj (aif it (ref class __new__) - (it) + (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! 'procedure + (slot-set! obj 'procedure (lambda x (aif it (ref obj '__call__) (apply it x) @@ -116,26 +119,25 @@ explicitly tell it to not update etc. obj))) (define (make-object class meta goops) - (let ((obj (make goops))) - (mk-p/pf obj) + (let ((obj (make-p goops))) (set obj '__class__ class) obj)) - - - ;; Make an empty pf object -(define* (make-pf #:optional (class )) - (define r (make-pyclass class)) - (slot-set! r 'h vlist-null) - (slot-set! r 'size 0) - (slot-set! r 'n 0) - r) - -(define* (make-p #:optional (class

)) - (define r (make-pyclass class)) - (slot-set! r 'h (make-hash-table)) - r) +(define (make-p ) + (let ((r (make ))) + (cond + ((is-a? r ) + (slot-set! r 'h vlist-null) + (slot-set! r 'size 0) + (slot-set! r 'n 0)) + ((is-a? r

) + (slot-set! r 'h (make-hash-table))) + (else + (error "make-p in pf-objects need a

or derived class got ~a" + r))) + r)) + (define-syntax-rule (hif it (k h) x y) (let ((a (vhash-assq k h))) @@ -152,7 +154,6 @@ explicitly tell it to not update etc. x) y))) -(define fail (cons 'fail '())) (define-syntax-rule (mrefx x key l) (let () (define (end) @@ -184,25 +185,19 @@ explicitly tell it to not update etc. (define *refkind* (make-fluid 'object)) - (define-method (find-in-class (klass

) key fail) (hash-ref (slot-ref klass 'h) key fail)) + (define-method (find-in-class (klass ) key fail) (let ((r (vhash-assoc key (slot-ref klass 'h)))) (if r (cdr r) fail))) -(define-syntax-rule (kif it p x y) - (let ((it p)) - (if (eq? it fail) - y - x))) - (define-syntax-rule (find-in-class-and-parents klass key fail) (kif r (find-in-class klass key fail) r - (aif parents (hash-ref class-h '__mro__ #f) + (aif parents (find-in-class klass '__mro__ #f) (let lp ((parents parents)) (if (pair? parents) (kif r (find-in-class (car parents) key fail) @@ -219,7 +214,7 @@ explicitly tell it to not update etc. it (begin (fluid-set! *refkind* 'class) - (aif klass (hash-ref h '__class__) + (aif klass (find-in-class klass '__class__ #f) (kif it (find-in-class-and-parents klass key fail) it (end)) @@ -241,7 +236,7 @@ explicitly tell it to not update etc. (let* ((g (mrefx xx '__fget__ '(#t))) (f (if g (if (eq? g #t) - (aif it (mrefx- xx '__getattribute__ '()) + (aif it (mrefx xx '__getattribute__ '()) (begin (set xx '__fget__ it) it) @@ -260,14 +255,14 @@ explicitly tell it to not update etc. (let ((res (mrefx xx key l))) (if (and (not (struct? res)) (procedure? res)) (res xx) - res))))) + 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) - res))))) + res)))) (define-method (ref x key . l) (if (pair? l) (car l) #f)) (define-method (ref (x ) key . l) (mref x key l)) @@ -275,11 +270,15 @@ explicitly tell it to not update etc. (define-method (ref (x ) key . l) (mref-py x key l)) (define-method (ref (x ) key . l) (mref-py x key l)) -(define-method (refq (x ) key . l) (mref x key l)) -(define-method (refq (x

) key . l) (mref x key l)) -(define-method (refq (x ) key . l) (mref-py x key l)) -(define-method (refq (x ) key . l) (mref-py x key l)) - +(define-method (set (f ) key val) + (set-procedure-property! f key val)) + +(define-method (ref (f ) 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 @@ -302,15 +301,15 @@ explicitly tell it to not update etc. (values))) ;; on object x add a binding that key -> val -(define--method (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))) + (let ((r (vhash-assoc key h))) (when (not r) (slot-set! x 'n (+ n 1))) - (slot-set! x 'h (vhash-consq key val h)) + (slot-set! x 'h (vhash-cons key val h)) (when (> s (* 2 n)) (reshape x)) (values)))) @@ -322,19 +321,13 @@ explicitly tell it to not update etc. (hash-set! (slot-ref x 'h) key val) (values))) -(define-method (mset (x ) key val) - (begin - (hash-set! (slot-ref x 'h) key val) - (values))) - (define-syntax-rule (mset-py x key val) - (let* ((h (slot-ref x 'h)) - (v (hash-ref h key fail))) + (let* ((v (mref x key (list fail)))) (if (or (eq? v fail) (not (and (is-a? v ) (not (pyclass? x))))) (let* ((g (mrefx x '__fset__ '(#t))) (f (if g (if (eq? g #t) - (let ((class (aif it (mref- x '__class__ '()) + (let ((class (aif it (mref x '__class__ '()) it x))) (aif it (mrefx x '__setattr__ '()) @@ -389,14 +382,14 @@ explicitly tell it to not update etc. ;; make a copy of a pf object (define-syntax-rule (mcopy x) - (let ((r (make-pyclass ))) + (let ((r (make-p (pk (ref (pk 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)) + (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)) @@ -508,7 +501,7 @@ explicitly tell it to not update etc. ;; 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)) +(define null (make-p )) (define (filter-parents l) (let lp ((l l)) @@ -518,14 +511,44 @@ explicitly tell it to not update etc. (lp (cdr l))) '()))) -(define (kw->class kw) +(define (kw->class kw meta) (if (memq #:functional kw) (if (memq #:fast kw) - ) + (if (or (not meta) (is-a? meta ) (is-a? meta )) + + )) (if (memq #:fast kw) -

- ))) + (if (or (is-a? meta ) (is-a? meta )) + +

) + (cond + ((is-a? meta ) + ) + ((is-a? meta ) + ) + ((is-a? meta ) + ) + ((is-a? meta

) +

) + (else + ))))) + + +(define (defaulter d) + (if d + (cond + ((is-a? d ) + ) + ((is-a? d ) + ) + ((is-a? d ) + ) + ((is-a? d

) +

) + (else + d)) + )) (define (kwclass->class kw default) (if (memq #:functionalClass kw) @@ -533,7 +556,7 @@ explicitly tell it to not update etc. (if (memq #:pyClass kw) - (if (or (is-a default ) (is-a default )) + (if (or (is-a? default ) (is-a? default )) ))) (if (memq #:mutatingClass kw) @@ -541,42 +564,77 @@ explicitly tell it to not update etc.

(if (memq #:pyClass kw) - (if (or (is-a default ) (is-a default )) + (if (or (is-a? default ) (is-a? default ))

))) (if (memq #:fastClass kw) - (if (or (is-a default ) (is-a default )) + (if (or (is-a? default ) (is-a? default ))

) (if (memq #:pyClass kw) - (if (or (is-a default ) (is-a default )) + (if (or (is-a? default ) (is-a? default )) ) - default))))) - -(define (make-p-class name supers methods kw) + (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) sups) supers)) + (define parents (let ((p (filter-parents supers))) + (if (null? p) + (if object + (list object) + '()) + p))) - (define goops (make-class - (append goopses - (list (kw->class kw))))) + (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 parents (filter-parents supers)) - (define meta (aif it (memqq #:metaclass kw) (car it) type)) - (define (gen-methods dict) - (dynamic dict) - (set dict '__goops__ goops) - (set dict '__class__ meta) - (set dict '__fget__ #t) - (set dict '__fset__ #t) - (set dict '__name__ name) - (set dict '__parents__ parents) - (set dict '__mro__ (get-mro class))) + (define (gen-methods dict) + (method 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) (create-class meta name parents gen-methods kw)) @@ -585,19 +643,20 @@ explicitly tell it to not update etc. ;; the make class and defclass syntactic sugar (define-syntax-rule (mk-p-class name parents - (kw ...) - (ddef dname dval) + (ddef dname dval) ...) (let () (define name - (letruc ((dname dval) (... ...)) - (make-p-class name - parents - (lambda (dict) - (hash-set! d 'dname dname) (... ...))))) + (letruc ((dname dval) ...) + (make-p-class 'name + parents + (lambda (dict) + (pylist-set! dict 'dname dname) + ... + (values))))) - name))) + name)) (define-syntax-rule (def-p-class name . l) (define name (mk-p-class name . l))) @@ -623,15 +682,20 @@ explicitly tell it to not update etc. 'none))) (define (print o l) - (define p1 (if (pyclass? o) "C" "O")) - (define p2 (if (pyclass? o) "C" "O")) + (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 (ref o '__repr__ #f)) + (aif it (if (pyclass? o) + #f + (if (pyobject? o) + (ref o '__repr__) + #f)) (format - #f "~a(~a)<~a>" p1 (get-type o) (it)) + #f "~a(~a)<~a>" + p (get-type o) (it)) (format - #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None))))) + #f "~a(~a)<~a>" + p (get-type o) (ref o '__name__ 'Annonymous))))) (define-method (write (o

) . l) (print o l)) (define-method (display (o

) . l) (print o l)) @@ -646,37 +710,22 @@ explicitly tell it to not update etc. (cons (reverse l) '())))) (define-syntax-rule (define-python-class name (parents ...) code ...) - (define name (mk-py-class name (arglist->pkw (list parents ...)) code ...))) + (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...))) -(define (pyclass? x) - (and (is-a? x

) - (if (is-a? x type) - #f - (if it (ref x '__class__) - (if (is-a? it type) - #t - #f))) - #f)) - -(define (pyobject? x) - (and (is-a? x

) - (if (is-a? x type) - #f - (if it (ref x '__class__) - (if (is-a? it type) - #f - #t))) - #f)) - -(define (pytype? x) +(define-syntax-rule (make-python-class name (parents ...) code ...) + (mk-p-class name (arglist->pkw (list parents ...)) code ...)) + +(define (kind x) (and (is-a? x

) - (if (is-a? x type) - #t - #f) - #f)) + (aif it (find-in-class x '__goops__ #f) + (if (is-a? (make it) (ref type '__goops__)) + 'type + 'class) + 'object))) -(define-method (py-class (o

)) - (ref o '__class__ type)) +(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) @@ -718,8 +767,8 @@ explicitly tell it to not update etc. (define (not-a-super) 'not-a-super) (define (py-super class obj) (define (make cl parents) - (let ((c (make-p)) - (o (make-p))) + (let ((c (make-p

)) + (o (make-p

))) (set c '__super__ #t) (set c '__mro__ parents) (set c '__getattribute__ (lambda (self key . l) @@ -842,16 +891,21 @@ explicitly tell it to not update etc. (find-tree o (nxt tree)))) #f)) -(define (get-mro class) - (define tree (mk-tree (class-to-tree class))) +(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)))) + (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

) y) (aif it (ref x '__eq__) @@ -867,20 +921,15 @@ explicitly tell it to not update etc. (define (equal? x y) (or (eq? x y) (py-equal? x y))) -(define type 'type) -(define-python-class type () - (define __call__ - (case-lambda - ((self obj) - (if (is-a? obj type) - obj - (let ((r (ref obj '__class__))) - (if (is-a? r type) - r - (ref r '__class__))))) - ((self name bases dict . keys) - (type- meta name parents dict keys))))) - +(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) -(define-python-class object ()) +(set! object (make-python-class object ())) -- cgit v1.2.3