1 (define-module (oop pf-objects
)
2 #:use-module
(oop goops
)
3 #:use-module
(ice-9 vlist
)
4 #:use-module
(ice-9 match
)
5 #:use-module
(system base message
)
6 #:use-module
(language python guilemod
)
7 #:use-module
(ice-9 pretty-print
)
8 #:use-module
(logic guile-log persistance
)
10 #:export
(set ref make-p
<p
> <py
> <pf
> <pyf
> <property
>
11 call with copy fset fcall put put
!
12 pcall pcall
! get fset-x pyclass?
13 def-p-class mk-p-class make-p-class
14 define-python-class define-python-class-noname
16 object-method class-method static-method
17 py-super-mac py-super py-equal?
18 *class
* *self
* pyobject? pytype?
19 type object pylist-set
! pylist-ref tr
20 resolve-method-g rawref rawset
24 Python object system is basically syntactic suger otop of a hashmap and one
25 this project is inspired by the python object system and what it measn when
26 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
27 with assocs or tree like functional hashmaps in stead.
29 The hashmap works like an assoc e.g. we will define new values by
'consing
' a
30 new binding on the list and when the assoc take up too much space it will be
31 reshaped and all extra bindings will be removed.
33 The datastructure is functional but the objects mutate. So one need to
34 explicitly tell it to not update etc.
37 (define fail
(cons 'fail
'()))
39 (define-syntax-rule (kif it p x y
)
45 (define-method (pylist-set! (o <hashtable
>) key val
)
46 (hash-set! o key val
))
48 (define-method (pylist-ref (o <hashtable
>) key
)
49 (kif it
(hash-ref o key fail
)
51 (error "IndexError")))
53 (define (is-acl? a b
) (member a
(cons b
(class-subclasses b
))))
55 (define-syntax-rule (aif it p x y
) (let ((it p
)) (if it x y
)))
56 (define-class <p
> (<applicable-struct
> <object
>) h
)
57 (define-class <pf
> (<p
>) size n
) ; the pf object consist of a functional
58 ; hashmap it's size and number of live
60 (define-class <py
> (<p
>))
61 (define-class <pyf
> (<pf
>))
63 (define-class <property
> () get set del
)
69 (name-object <property
>)
71 (define-method (ref (o <procedure
>) key . l
)
72 (aif it
(procedure-property o key
)
78 (define-method (rawref (o <procedure
>) key . l
)
79 (aif it
(procedure-property o key
)
85 (define-method (set (o <procedure
>) key val
)
86 (set-procedure-property! o key val
))
88 (define-method (rawset (o <procedure
>) key val
)
89 (set-procedure-property! o key val
))
91 (define (mk-getter-object f
)
94 (lambda x
(apply f x
))
95 (lambda x
(apply f obj x
)))))
97 (define (mk-getter-class f
)
100 (lambda x
(apply f x
))
101 (lambda x
(apply f cls x
)))))
103 (define (class-method f
)
104 (set f
'__get__
(mk-getter-class f
)))
106 (define (object-method f
)
107 (set f
'__get__
(mk-getter-object f
)))
109 (define (static-method f
)
113 (define (resolve-method-g g pattern
)
114 (define (mmatch p pp
)
118 (((p . ps
) .
(pp . pps
))
121 (if (or (eq? p pp
) (is-a? p pp
))
122 (cons p
(mmatch ps pps
))
130 (let lp
((x x
) (y y
))
132 (((x . xs
) .
(y . ys
))
138 (let lp
((ms (generic-function-methods g
)))
141 (p (method-specializers m
))
142 (f (method-generic-function m
)))
143 (aif it
(mmatch p pattern
)
144 (cons (cons it f
) (lp (cdr ms
)))
149 (cdr (car (sort l q
<)))))
151 (define (resolve-method-o o pattern
)
152 (resolve-method-g (class-of o
) pattern
))
154 (define (get-dict self name parents
)
155 (aif it
(ref self
'__prepare__
)
156 (it self name parents
)
159 (define (hashforeach a b
) (values))
161 (define (new-class meta name parents dict kw
)
162 (aif it
(ref meta
'__new__
)
163 (apply it name parents dict kw
)
164 (let* ((goops (pylist-ref dict
'__goops__
))
165 (p (kwclass->class kw meta
))
167 (slot-set! class
'procedure
169 (create-object class meta goops x
)))
170 (if (hash-table? dict
)
172 (lambda (k v
) k
(set class k v
))
175 (lambda (k v
) k
(set class k v
))
177 (let((mro (ref class
'__mro__
)))
180 (aif it
(ref p
'__init_subclass__
)
181 (apply it class
#f kw
)
183 (set class
'__mro__
(cons class
(ref class
'__mro__
)))
186 (define (type- meta name parents dict keys
)
187 (let ((class (new-class meta name parents dict keys
)))
188 (aif it
(ref meta
'__init__
)
189 (it name parents dict keys
)
193 (define (create-class meta name parents gen-methods . keys
)
194 (let ((dict (gen-methods (get-dict meta name keys
))))
195 (aif it
(ref meta
'__class__
)
196 (aif it
(find-in-class (ref meta
'__class__
) '__call__
#f
)
197 (apply (it meta
'class
) name parents dict keys
)
198 (type- meta name parents dict keys
))
199 (type- meta name parents dict keys
))))
201 (define (create-object class meta goops x
)
202 (with-fluids ((*make-class
* #t
))
203 (aif it
#f
;(ref meta '__call__)
205 (let ((obj (aif it
(find-in-class class
'__new__
#f
)
207 (make-object class meta goops
))))
208 (aif it
(ref obj
'__init__
)
211 (slot-set! obj
'procedure
213 (aif it
(ref obj
'__call__
)
215 (error "not a callable object"))))
218 (define (make-object class meta goops
)
219 (let ((obj (make-p goops
)))
220 (set obj
'__class__ class
)
223 ;; Make an empty pf object
225 (let ((r (make <x
>)))
228 (slot-set! r
'h vlist-null
)
229 (slot-set! r
'size
0)
232 (slot-set! r
'h
(make-hash-table)))
234 (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
239 (define-syntax-rule (hif it
(k h
) x y
)
240 (let ((a (vhash-assq k h
)))
246 (define-syntax-rule (cif (it h
) (k cl
) x y
)
247 (let* ((h (slot-ref cl
'h
))
248 (a (vhash-assq k h
)))
254 (define-inlinable (gox obj it
)
255 (let ((class (fluid-ref *location
*)))
256 (aif it
(rawref it
'__get__
)
260 (define *location
* (make-fluid #f
))
261 (define-syntax-rule (mrefx x key l
)
273 (begin (fluid-set! *location
* p
) it
)
278 (begin (fluid-set! *location
* x
) it
)
279 (hif cl
('__class__ h
)
281 (begin (fluid-set! *location
* cl
) it
)
283 (let ((r (parents p
)))
290 (define-method (find-in-class (klass <p
>) key fail
)
291 (hash-ref (slot-ref klass
'h
) key fail
))
293 (define-method (find-in-class (klass <pf
>) key fail
)
294 (let ((r (vhash-assoc key
(slot-ref klass
'h
))))
299 (define-syntax-rule (find-in-class-and-parents klass key fail
)
300 (kif r
(find-in-class klass key fail
)
301 (begin (fluid-set! *location
* klass
) r
)
302 (aif parents
(find-in-class klass
'__mro__
#f
)
303 (let lp
((parents parents
))
305 (kif r
(find-in-class (car parents
) key fail
)
306 (begin (fluid-set! *location
* (car parents
)) r
)
311 (define-syntax-rule (mrefx klass key l
)
313 (define (end) (if (pair? l
) (car l
) #f
))
314 (fluid-set! *location
* klass
)
315 (kif it
(find-in-class klass key fail
)
318 (aif klass
(find-in-class klass
'__class__
#f
)
319 (kif it
(find-in-class-and-parents klass key fail
)
324 (define not-implemented
(cons 'not
'implemeneted
))
326 (define-syntax-rule (prop-ref xx x
)
329 (if (and (is-a? r
<property
>) (not (pyclass? y
)))
330 ((slot-ref r
'get
) y
)
333 (define-syntax-rule (mrefx-py x key l
)
337 (let* ((g (mrefx xx
'__fget__
'(#t
)))
340 (aif it
(mrefx xx
'__getattribute__
'())
341 (let ((f (gox xx it
)))
342 (rawset xx
'__fget__ it
)
346 (rawset xx
'__fget__
#f
))
350 (if (or (not f
) (eq? f not-implemented
))
351 (gox xx
(mrefx xx key l
))
356 (gox xx
(mrefx xx key l
)))))))))
359 (define-syntax-rule (mref x key l
)
363 (define-syntax-rule (mref-py x key l
)
365 (let ((res (mrefx-py xx key l
)))
368 (define-method (ref x key . l
) (if (pair? l
) (car l
) #f
))
369 (define-method (ref (x <pf
> ) key . l
) (mref x key l
))
370 (define-method (ref (x <p
> ) key . l
) (mref x key l
))
371 (define-method (ref (x <pyf
>) key . l
) (mref-py x key l
))
372 (define-method (ref (x <py
> ) key . l
) (mref-py x key l
))
374 (define-method (rawref x key . l
) (if (pair? l
) (car l
) #f
))
375 (define-method (rawref (x <pf
> ) key . l
) (mref x key l
))
376 (define-method (rawref (x <p
> ) key . l
) (mref x key l
))
379 (define-method (set (f <procedure
>) key val
)
380 (set-procedure-property! f key val
))
382 (define-method (ref (f <procedure
>) key . l
)
383 (aif it
(assoc key
(procedure-properties f
))
385 (if (pair? l
) (car l
) #f
)))
388 ;; the reshape function that will create a fresh new pf object with less size
389 ;; this is an expensive operation and will only be done when we now there is
390 ;; a lot to gain essentially tho complexity is as in the number of set
392 (let ((h (slot-ref x
'h
))
393 (m (make-hash-table))
395 (define h2
(vhash-fold (lambda (k v s
)
396 (if (hash-ref m k
#f
)
401 (vhash-consq k v s
))))
405 (slot-set! x
'size n
)
409 ;; on object x add a binding that key -> val
410 (define-method (mset (x <pf
>) key val
)
411 (let ((h (slot-ref x
'h
))
412 (s (slot-ref x
'size
))
414 (slot-set! x
'size
(+ 1 s
))
415 (let ((r (vhash-assoc key h
)))
417 (slot-set! x
'n
(+ n
1)))
418 (slot-set! x
'h
(vhash-cons key val h
))
423 (define (pkh h
) (hash-for-each (lambda x
(pk x
)) h
) h
)
425 (define-method (mset (x <p
>) key val
)
427 (hash-set! (slot-ref x
'h
) key val
)
430 (define *make-class
* (make-fluid #f
))
431 (define (mc?
) (not (fluid-ref *make-class
*)))
433 (define-syntax-rule (mset-py x key val
)
435 (v (mref xx key
(list fail
))))
437 (not (and (is-a? v
<property
>)
438 (not (pyclass? xx
)))))
439 (let* ((g (mrefx xx
'__fset__
'(#t
)))
442 (aif it
(rawref xx
'__setattr__
)
444 (rawset xx
'__fset__ it
)
448 (rawset xx
'__fset__ it
))
452 (if (or (eq? f not-implemented
) (not f
))
455 (lambda () (f key val
))
456 (lambda q
(mset xx key val
)))))
457 ((slot-ref v
'set
) xx val
))))
459 (define-syntax-rule (mklam (mset a ...
) val
)
462 (define-method (set (x <pf
>) key val
) (mklam (mset x key
) val
))
463 (define-method (set (x <p
>) key val
) (mklam (mset x key
) val
))
464 (define-method (set (x <pyf
>) key val
) (mklam (mset-py x key
) val
))
465 (define-method (set (x <py
>) key val
) (mklam (mset-py x key
) val
))
467 (define-method (rawset (x <pf
>) key val
) (mklam (mset x key
) val
))
468 (define-method (rawset (x <p
>) key val
) (mklam (mset x key
) val
))
470 ;; mref will reference the value of the key in the object x, an extra default
471 ;; parameter will tell what the fail object is else #f if fail
472 ;; if there is no found binding in the object search the class and
473 ;; the super classes for a binding
475 ;; call a function as a value of key in x with the object otself as a first
476 ;; parameter, this is pythonic object semantics
477 (define-syntax-rule (mk-call mcall mref
)
478 (define-syntax-rule (mcall x key l
)
479 (apply (mref x key
'()) l
)))
482 (mk-call mcall-py mref-py
)
484 (define-method (call (x <pf
>) key . l
) (mcall x key l
))
485 (define-method (call (x <p
>) key . l
) (mcall x key l
))
486 (define-method (call (x <pyf
>) key . l
) (mcall-py x key l
))
487 (define-method (call (x <py
>) key . l
) (mcall-py x key l
))
490 ;; make a copy of a pf object
491 (define-syntax-rule (mcopy x
)
492 (let ((r (make-p (ref x
'__goops__
))))
493 (slot-set! r
'h
(slot-ref x
'h
))
494 (slot-set! r
'size
(slot-ref x
'size
))
495 (slot-set! r
'n
(slot-ref x
'n
))
498 (define-syntax-rule (mcopy- x
)
499 (let* ((r (make-p (ref x
'__goops__
)))
501 (hash-for-each (lambda (k v
) (hash-set! h k v
)) (slot-ref x
'h
))
504 (define-method (copy (x <pf
>)) (mcopy x
))
505 (define-method (copy (x <p
> )) (mcopy- x
))
507 ;; make a copy of a pf object
508 (define-syntax-rule (mtr r x
)
510 (slot-set! r
'h
(slot-ref x
'h
))
511 (slot-set! r
'size
(slot-ref x
'size
))
512 (slot-set! r
'n
(slot-ref x
'n
))
515 (define-syntax-rule (mtr- r x
)
517 (slot-set! r
'h
(slot-ref x
'h
))
521 (define-method (tr (r <pf
>) (x <pf
>)) (mtr r x
))
522 (define-method (tr (r <p
> ) (x <p
> )) (mtr- r x
))
525 ;; with will execute thunk and restor x to it's initial state after it has
526 ;; finished note that this is a cheap operatoin because we use a functional
528 (define-syntax-rule (mwith x thunk
)
529 (let ((old (mcopy x
)))
531 (slot-set! x
'h
(slot-ref old
'h
))
532 (slot-set! x
'size
(slot-ref old
'size
))
533 (slot-set! x
'n
(slot-ref old
'n
))
536 (define-syntax-rule (mwith- x thunk
)
537 (let ((old (mcopy- x
)))
539 (slot-set! x
'h
(slot-ref old
'h
))
544 ;; a functional set will return a new object with the added binding and keep
546 (define-method (fset (x <pf
>) key val
)
551 (define-method (fset (x <p
>) key val
)
552 (let ((x (mcopy- x
)))
556 (define (fset-x obj l val
)
557 (let lp
((obj obj
) (l l
) (r '()))
560 (let lp
((v val
) (r r
))
562 (lp (fset (caar r
) (cdar r
) v
) (cdr r
))
565 (lp (ref obj k
#f
) l
(cons (cons obj k
) r
))))))
571 ;; a functional call will keep x untouched and return (values fknval newx)
572 ;; e.g. we get both the value of the call and the new version of x with
573 ;; perhaps new bindings added
574 (define-method (fcall (x <pf
>) key . l
)
577 (if (eq?
(slot-ref x
'h
) (slot-ref y
'h
))
581 (define-method (fcall (x <p
>) key . l
)
583 (values (mcall x key l
)
586 ;; this shows how we can override addition in a pythonic way
588 ;; lets define get put pcall etc so that we can refer to an object like
589 ;; e.g. (put x.y.z 1) (pcall x.y 1)
591 (define-syntax-rule (cross x k f set
)
592 (call-with-values (lambda () f
)
596 (values r
(set x k y
))))))
598 (define-syntax-rule (cross! x k f _
) f
)
602 ((_ cross set setx f
(key) (val ...
))
603 (setx f key val ...
))
604 ((_ cross set setx f
(k . l
) val
)
605 (cross f k
(mku cross set setx
(ref f k
) l val
) set
))))
607 (define-syntax-rule (mkk pset setx set cross
)
612 (let* ((to (lambda (x)
613 (datum->syntax
#'f
(string->symbol x
))))
614 (l (string-split (symbol->string
(syntax->datum
#'f
)) #\.
)))
615 (with-syntax (((a (... ...
)) (map (lambda (x) #`'#,(to x
))
618 #'(mku cross setx set h
(a (... ...
)) (val (... ...
))))))))))
620 (mkk put fset fset cross
)
621 (mkk put
! set set cross
!)
622 (mkk pcall
! call fset cross
!)
623 (mkk pcall fcall fset cross
)
624 (mkk get ref fset cross
!)
626 ;; it's good to have a null object so we don't need to construct it all the
627 ;; time because it is functional we can get away with this.
628 (define null
(make-p <pf
>))
630 (define (filter-parents l
)
633 (if (is-a?
(car l
) <p
>)
634 (cons (car l
) (lp (cdr l
)))
638 (define (kw->class kw meta
)
639 (if (memq #:functional kw
)
642 (if (or (not meta
) (is-a? meta
<pyf
>) (is-a? meta
<py
>))
646 (if (or (is-a? meta
<pyf
>) (is-a? meta
<pf
>))
662 (define (defaulter d
)
677 (define (kwclass->class kw default
)
678 (if (memq #:functionalClass kw
)
679 (if (memq #:fastClass kw
)
681 (if (memq #:pyClass kw
)
683 (if (or (is-a? default
<py
>) (is-a? default
<pyf
>))
686 (if (memq #:mutatingClass kw
)
687 (if (memq #:fastClass kw
)
689 (if (memq #:pyClass kw
)
691 (if (or (is-a? default
<py
>) (is-a? default
<pyf
>))
694 (if (memq #:fastClass kw
)
695 (if (or (is-a? default
<pf
>) (is-a? default
<pyf
>))
698 (if (memq #:pyClass kw
)
699 (if (or (is-a? default
<pf
>) (is-a? default
<pyf
>))
702 (defaulter default
))))))
705 (define (make-p-class name supers.kw methods
)
706 (define kw
(cdr supers.kw
))
707 (define supers
(car supers.kw
))
708 (define goopses
(map (lambda (sups)
709 (aif it
(ref sups
'__goops__
#f
)
713 (define parents
(let ((p (filter-parents supers
)))
720 (define meta
(aif it
(memq #:metaclass kw
)
724 (let* ((p (car parents
))
725 (m (ref p
'__class__
))
726 (mro (reverse (ref m
'__mro__
))))
727 (let lp
((l (cdr parents
))
732 (meta (ref p
'__class__
))
733 (mro (ref meta
'__mro__
)))
734 (let lp2
((max max
) (mr (reverse mro
)))
735 (if (and (pair? max
) (pair? mr
))
736 (if (eq?
(car max
) (car mr
))
737 (lp2 (cdr max
) (cdr mr
))
739 "need a common lead for meta"))
741 (if (< (length mro
) (length min
))
743 (lp (cdr l
) max min
))
744 (lp (cdr l
) mro min
)))))
745 (car (reverse min
))))))))
747 (define goops
(make-class (append goopses
(list (kw->class kw meta
)))
750 (define (gen-methods dict
)
752 (pylist-set! dict
'__goops__ goops
)
753 (pylist-set! dict
'__class__ meta
)
754 (pylist-set! dict
'__fget__
#t
)
755 (pylist-set! dict
'__fset__
#t
)
756 (pylist-set! dict
'__name__ name
)
757 (pylist-set! dict
'__parents__ parents
)
758 (pylist-set! dict
'__class__ meta
)
759 (pylist-set! dict
'__mro__
(get-mro parents
))
762 (with-fluids ((*make-class
* #t
))
763 (create-class meta name parents gen-methods kw
)))
766 ;; Let's make an object essentially just move a reference
768 ;; the make class and defclass syntactic sugar
769 (define-syntax mk-p-class
772 ((_ name parents
(ddef dname dval
) ...
)
773 (with-syntax (((ddname ...
)
780 (syntax->datum
#'name
))
783 (syntax->datum dn
))))))
785 (nname (datum->syntax
790 (syntax->datum
#'name
))
792 (%add-to-warn-list
(syntax->datum
#'nname
))
793 (map (lambda (x) (%add-to-warn-list
(syntax->datum x
)))
797 (letruc ((dname dval
) ...
)
801 (pylist-set! dict
'dname dname
)
806 (module-define! (current-module) 'ddname
(ref name
'dname
))
807 (name-object ddname
))
810 (module-define! (current-module) 'nname
(ref name
'__goops__
))
815 (define-syntax mk-p-class-noname
818 ((_ name parents
(ddef dname dval
) ...
)
821 (letruc ((dname dval
) ...
)
825 (pylist-set! dict
'dname dname
)
830 (define-syntax-rule (def-p-class name . l
)
831 (define name
(mk-p-class name . l
)))
833 (define (get-class o
)
838 (error "not a pyclass"))))
854 (define p
(if (pyclass? o
) "C" (if (pyobject? o
) "O" "T")))
855 (define port
(if (pair? l
) (car l
) #t
))
857 (aif it
(if (pyclass? o
)
867 p
(get-type o
) (ref o
'__name__
'Annonymous
)))))
869 (define-method (write (o <p
>) . l
) (print o l
))
870 (define-method (display (o <p
>) . l
) (print o l
))
872 (define (arglist->pkw l
)
873 (let lp
((l l
) (r '()))
878 (lp (cdr l
) (cons x r
))))
879 (cons (reverse r
) '()))))
881 (define-syntax-rule (define-python-class name
(parents ...
) code ...
)
882 (define name
(mk-p-class name
(arglist->pkw
(list parents ...
)) code ...
)))
884 (define-syntax-rule (define-pythonc-lass-noname name
(parents ...
) code ...
)
885 (define name
(mk-p-class-noname name
(arglist->pkw
(list parents ...
))
889 (define-syntax make-python-class
892 ((_ name
(parents ...
) code ...
)
893 #'(let* ((cl (mk-p-class name
894 (arglist->pkw
(list parents ...
))
901 (aif it
(find-in-class x
'__goops__
#f
)
902 (if (is-a?
(make it
) (ref type
'__goops__
))
907 (define (pyobject? x
) (eq?
(kind x
) 'object
))
908 (define (pyclass? x
) (eq?
(kind x
) 'class
))
909 (define (pytype? x
) (eq?
(kind x
) 'type
))
911 (define (mark-fkn tag f
)
912 (set-procedure-property! f
'py-special tag
)
915 (define-syntax-parameter
916 *class
* (lambda (x) (error "*class* not parameterized")))
917 (define-syntax-parameter
918 *self
* (lambda (x) (error "*class* not parameterized")))
920 (define *super
* (list 'super
))
922 (define (not-a-super) 'not-a-super
)
923 (define (py-super class obj
)
924 (define (make cl parents
)
925 (let ((c (make-p <p
>))
927 (set c
'__super__
#t
)
928 (set c
'__mro__ parents
)
929 (set c
'__getattribute__
(lambda (self key . l
)
932 (if (eq?
(procedure-property
939 (error "no attribute"))))
945 (let lp
((l (ref (ref obj
'__class__
) '__mro__
'())))
947 (if (eq? class
(car l
))
958 (define-syntax py-super-mac
961 (py-super *class
* *self
*))
963 (py-super class self
))))
966 (pretty-print (syntax->datum x
))
969 (define-syntax letruc
972 ((_ ((x v
) ...
) code ...
)
973 (let lp
((a #'(x ...
)) (b #'(v ...
)) (u '()))
976 (s (syntax->datum x
)))
977 (let lp2
((a2 (cdr a
)) (b2 (cdr b
)) (a3 '()) (b3 '())
980 (if (eq?
(syntax->datum a2
) s
)
981 (lp2 (cdr a2
) (cdr b2
) a3 b3
(cons (car b2
) r
))
982 (lp2 (cdr a2
) (cdr b2
)
986 (lp (reverse a3
) (reverse b3
)
988 (list x
#`(let* #,(map (lambda (v) (list x v
))
991 #`(letrec #,(reverse u
) code ...
)))))))
996 (define-method (py-init (o <p
>) . l
)
997 (apply (ref o
'__init__
) l
))
1003 ((root hist
) (vector root hist
))))
1005 (define (geth t
) (vector-ref t
1))
1006 (define (getr t
) (vector-ref t
0))
1007 (define (tree-ref t
) (car (getr t
)))
1013 (dive (car r
) (cons (cdr r
) h
))
1019 (up (car h
) (cdr h
))
1026 (let ((r (getr tree
)) (h (geth tree
)))
1033 (dive x
(cons (cdr r
) h
))
1036 (up (car h
) (cdr h
))
1040 (up (car h
) (cdr h
))
1043 (define (class-to-tree cl
) (cons cl
(map class-to-tree
(ref cl
'__parents__
))))
1045 (define (find-tree o tree
)
1047 (let ((x (tree-ref tree
)))
1050 (find-tree o
(nxt tree
))))
1053 (define (get-mro parents
)
1056 (get-mro0 parents
)))
1058 (define (get-mro0 parents
)
1059 (define tree
(mk-tree parents
))
1060 (let lp
((tree tree
) (r '()))
1062 (let ((x (tree-ref tree
))
1069 (define-method (py-equal?
(x <p
>) y
)
1070 (aif it
(ref x
'__eq__
)
1074 (define-method (py-equal? y
(x <p
>))
1075 (aif it
(ref x
'__eq__
)
1079 (define-method (py-equal? x y
) ((@ (guile) equal?
) x y
))
1081 (define (equal? x y
) (or (eq? x y
) (py-equal? x y
)))
1085 (make-python-class type
()
1089 (ref obj
'__class__
'None
))
1090 ((meta name bases dict . keys
)
1091 (type- meta name bases dict keys
))))))
1092 (set type
'__class__ type
)
1094 (set! object
(make-python-class object
()))
1097 (name-object object
)