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
! py-get
12 pcall pcall
! get fset-x pyclass?
13 def-p-class mk-p-class make-p-class mk-p-class2
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 py-dict
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.
39 (let* ((r (reverse l
))
48 (define-syntax-rule (aif it p x y
) (let ((it p
)) (if it x y
)))
52 (let ((h (slot-ref o
'h
)))
53 (hash-for-each (lambda (k v
)
54 (if (member k
'(__name__ __qualname__ __class__
))
60 (let lp
((l (pk 'mro
(ref o
'__mro__
'()))))
64 (if (hash-table?
(slot-ref cl
'h
))
65 (hash-for-each (lambda (k v
)
66 (if (member k
'(__name__ __qualname__
))
76 (define fail
(cons 'fail
'()))
78 (define-syntax-rule (kif it p x y
)
84 (define-method (pylist-set! (o <hashtable
>) key val
)
85 (hash-set! o key val
))
87 (define-method (pylist-ref (o <hashtable
>) key
)
88 (kif it
(hash-ref o key fail
)
90 (error "IndexError")))
92 (define-method (py-get x key . l
)
93 (if (pair? l
) (car l
) #f
))
95 (define-method (py-get (o <hashtable
>) key . l
)
96 (define -fail
(if (pair? l
) (car l
) #f
))
97 (kif it
(hash-ref o key fail
)
101 (define (is-acl? a b
) (member a
(cons b
(class-subclasses b
))))
103 (define-class <p
> (<applicable-struct
> <object
>) h
)
104 (define-class <pf
> (<p
>) size n
) ; the pf object consist of a functional
105 ; hashmap it's size and number of live
107 (define-class <py
> (<p
>))
108 (define-class <pyf
> (<pf
>))
110 (define-class <property
> () get set del
)
116 (name-object <property
>)
118 (define-method (ref (o <procedure
>) key . l
)
119 (aif it
(procedure-property o key
)
125 (define-method (rawref (o <procedure
>) key . l
)
126 (aif it
(procedure-property o key
)
132 (define-method (set (o <procedure
>) key val
)
133 (set-procedure-property! o key val
))
135 (define-method (rawset (o <procedure
>) key val
)
136 (set-procedure-property! o key val
))
138 (define-method (find-in-class x key fail
) fail
)
139 (define-method (find-in-class (klass <pf
>) key fail
)
140 (let ((r (vhash-assoc key
(slot-ref klass
'h
))))
145 (define-method (find-in-class (klass <p
>) key -fail
)
146 (let ((h (slot-ref klass
'h
)))
147 (aif dict
(hash-ref h
'__dict__
)
148 (kif it
(py-get dict key fail
)
150 (hash-ref h key -fail
))
151 (hash-ref h key -fail
))))
153 (define-syntax-rule (find-in-class-and-parents klass key fail-
)
154 (aif parents
(find-in-class klass
'__mro__
#f
)
155 (let lp
((parents parents
))
157 (kif r
(find-in-class (car parents
) key fail
)
161 (kif r
(find-in-class klass key fail
)
166 (ficap klass key fail
) (find-in-class-and-parents klass key fail
))
168 (define (mk-getter-object f
)
170 (pkk 'obj-name
(find-in-class obj
'__name__
#f
))
171 (pkk 'cls-name
(find-in-class cls
'__name__
#f
))
172 (if (pkk 'type-obj
(pytype? obj
))
174 (if (pkk 'class-obj
(pyclass? obj
))
175 (if (pkk 'type-cls
(pytype? cls
))
176 (lambda x
(apply f obj x
))
178 (if (pkk 'class-cls
(pyclass? cls
))
179 (lambda x
(apply f obj x
))
182 (define (mk-getter-class f
)
184 (lambda x
(apply f cls x
))))
186 (define (class-method f
)
187 (set f
'__get__
(mk-getter-class f
))
190 (define (object-method f
)
191 (set f
'__get__
(mk-getter-object f
))
194 (define (static-method f
)
199 (define (resolve-method-g g pattern
)
200 (define (mmatch p pp
)
204 (((p . ps
) .
(pp . pps
))
207 (if (or (eq? p pp
) (is-a? p pp
))
208 (cons p
(mmatch ps pps
))
216 (let lp
((x x
) (y y
))
218 (((x . xs
) .
(y . ys
))
224 (let lp
((ms (generic-function-methods g
)))
227 (p (method-specializers m
))
228 (f (method-generic-function m
)))
229 (aif it
(mmatch p pattern
)
230 (cons (cons it f
) (lp (cdr ms
)))
235 (cdr (car (sort l q
<)))))
237 (define (resolve-method-o o pattern
)
238 (resolve-method-g (class-of o
) pattern
))
240 (define (hashforeach a b
) (values))
242 (define (add-default c l
)
244 (let ((l (let ((y (car l
))) (if (eq? y c
) l
(cons c l
)))))
245 (let* ((r (reverse l
))
248 (if (or (not type
) (pytype? x
))
249 (if (or (not type
) (eq? x type
))
251 (reverse (cons type r
)))
252 (if (or (not object
) (eq? x object
))
254 (reverse (cons object r
))))
262 (define (new-class0 meta name parents dict . kw
)
263 (let* ((goops (pkk 'new-class0 name
(pylist-ref dict
'__goops__
)))
264 (p (kwclass->class kw meta
))
267 (slot-set! class
'procedure
269 (create-object class x
)))
271 (if (hash-table? dict
)
273 (lambda (k v
) k
(set class k v
))
275 (begin (set class
'__dict__ dict
)))
277 (let lp
((mro (find-in-class class
'__mro__
#f
)))
280 (aif it
(find-in-class p
'__zub_classes__
#f
)
281 (hash-set! it class
#t
)
284 (aif it
(find-in-class p
'__init_subclass__
#f
)
285 (apply it class p
#f kw
)
291 (rawset class
'__class__ meta
)
292 (rawset class
'__goops__ goops
)
293 (rawset class
'__name__
(pylist-ref dict
'__name__
))
294 (rawset class
'__bases__
(pylist-ref dict
'__bases__
))
296 (rawset class
'__mro__
299 (find-in-class-and-parents
300 class
'__mro__
'())))
302 (if (not (ficap class
'__getattribute__
#f
))
303 (rawset class
'__getattribute__ attr
))
305 (aif it
(py-get dict
'__getattribute__
#f
)
306 (rawset class
'__getattribute__ it
)
309 (aif it
(py-get dict
'__getattr__
)
310 (rawset class
'__getattr__ it
)
313 (aif it
(py-get dict
'__setattr__
#f
)
314 (rawset class
'__setattr__ it
)
317 (aif it
(py-get dict
'__delattr__
#f
)
318 (rawset class
'__delattr__ it
)
323 (define (new-class meta name parents dict kw
)
324 (aif it
(and meta
(ficap meta
'__new__
#f
))
325 (apply it meta name parents dict kw
)
326 (apply new-class0 meta name parents dict kw
)))
328 (define (type- meta name parents dict keys
)
329 (let ((class (new-class meta name parents dict keys
)))
330 (aif it
(and meta
(find-in-class-and-parents meta
'__init__
#f
))
331 (it class name parents dict keys
)
336 (define (the-create-object class x
)
337 (let* ((meta (and class
(find-in-class class
'__class__
#f
)))
338 (goops (find-in-class class
'__goops__
#f
))
339 (obj (aif it
(ficap class
'__new__
#f
)
341 (make-object class meta goops
))))
343 (aif it
(ficap class
'__init__
#f
)
347 (slot-set! obj
'procedure
349 (aif it
(ref obj
'__call__
)
351 (error "not a callable object"))))
355 (define (create-object class x
)
357 (apply type-call class x
)
358 (let ((meta (and class
(find-in-class class
'__class__
#f
))))
359 (with-fluids ((*make-class
* #t
))
360 (aif it
(ficap meta
'__call__
#f
)
362 (the-create-object class x
))))))
369 (and obj
(find-in-class obj
'__class__
'None
)))
370 ((meta name bases dict . keys
)
371 (type- meta name bases dict keys
)))
373 (the-create-object class l
))))
375 (define (get-dict self name parents
)
376 (aif it
(and self
(ficap self
'__prepare__
#f
))
377 (it self name parents
)
380 (define (create-class meta name parents gen-methods keys
)
381 (let ((dict (gen-methods (get-dict meta name parents
))))
382 (aif it
(and meta
(find-in-class meta
'__class__
#f
))
383 (aif it
(find-in-class it
'__call__
#f
)
384 (apply it meta name parents dict keys
)
385 (type- meta name parents dict keys
))
386 (type- meta name parents dict keys
))))
388 (define (make-object class meta goops
)
389 (let ((obj (make-p goops
)))
390 (rawset obj
'__class__ class
)
393 ;; Make an empty pf object
395 (let ((r (make <x
>)))
398 (slot-set! r
'h vlist-null
)
399 (slot-set! r
'size
0)
402 (slot-set! r
'h
(make-hash-table)))
404 (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
409 (define-syntax-rule (hif it
(k h
) x y
)
410 (let ((a (vhash-assq k h
)))
416 (define-syntax-rule (cif (it h
) (k cl
) x y
)
417 (let* ((h (slot-ref cl
'h
))
418 (a (vhash-assq k h
)))
424 (define-inlinable (gox obj it
)
425 (let ((class (fluid-ref *location
*)))
426 (aif f
(rawref it
'__get__
)
430 (define-inlinable (gokx obj class it
)
431 (aif f
(rawref it
'__get__
)
435 (define *location
* (make-fluid #f
))
436 (define-syntax-rule (mrefx x key l
)
448 (begin (fluid-set! *location
* p
) it
)
453 (begin (fluid-set! *location
* x
) it
)
454 (hif cl
('__class__ h
)
456 (begin (fluid-set! *location
* cl
) it
)
458 (let ((r (parents p
)))
465 (define-syntax-rule (mrefx klass key l
)
467 (define (end) (if (pair? l
) (car l
) #f
))
468 (fluid-set! *location
* klass
)
469 (kif it
(find-in-class-and-parents klass key fail
)
471 (aif klass
(and klass
(find-in-class klass
'__class__
#f
))
473 (fluid-set! *location
* klass
)
474 (kif it
(find-in-class-and-parents klass key fail
)
479 (define not-implemented
(cons 'not
'implemeneted
))
481 (define (mrefx-py x key l
)
483 (define (exit) (if (pair? l
) (car l
) #f
))
484 (aif class
(find-in-class xx
'__class__
#f
)
485 (aif f
(find-in-class-and-parents class
'__getattribute__
#f
)
486 (kif it
(if (eq? f __getattribute__
)
490 (f xx
(symbol->string key
)))
495 (kif it
(__getattribute__ xx key
)
500 (define-syntax-rule (mref x key l
)
504 (define-syntax-rule (mref-py x key l
)
506 (let ((res (mrefx-py xx key l
)))
509 (define-method (ref x key . l
)
512 (apply ref NoneObj key l
))
518 (define-method (ref (x <pf
> ) key . l
) (mref x key l
))
519 (define-method (ref (x <p
> ) key . l
) (mref x key l
))
520 (define-method (ref (x <pyf
>) key . l
) (mref-py x key l
))
521 (define-method (ref (x <py
> ) key . l
) (mref-py x key l
))
523 (define-method (rawref x key . l
) (if (pair? l
) (car l
) #f
))
524 (define-method (rawref (x <pf
> ) key . l
) (mref x key l
))
525 (define-method (rawref (x <p
> ) key . l
) (mref x key l
))
528 (define-method (set (f <procedure
>) key val
)
529 (set-procedure-property! f key val
))
531 (define-method (ref (f <procedure
>) key . l
)
532 (aif it
(assoc key
(procedure-properties f
))
534 (if (pair? l
) (car l
) #f
)))
537 ;; the reshape function that will create a fresh new pf object with less size
538 ;; this is an expensive operation and will only be done when we now there is
539 ;; a lot to gain essentially tho complexity is as in the number of set
541 (let ((h (slot-ref x
'h
))
542 (m (make-hash-table))
544 (define h2
(vhash-fold (lambda (k v s
)
545 (if (hash-ref m k
#f
)
550 (vhash-consq k v s
))))
554 (slot-set! x
'size n
)
558 ;; on object x add a binding that key -> val
559 (define-method (mset (x <pf
>) key val
)
560 (let ((h (slot-ref x
'h
))
561 (s (slot-ref x
'size
))
563 (slot-set! x
'size
(+ 1 s
))
564 (let ((r (vhash-assoc key h
)))
566 (slot-set! x
'n
(+ n
1)))
567 (slot-set! x
'h
(vhash-cons key val h
))
572 (define (pkh h
) (hash-for-each (lambda x
(pk x
)) h
) h
)
574 (define-method (mset (x <p
>) key val
)
576 (hash-set! (slot-ref x
'h
) key val
)
579 (define *make-class
* (make-fluid #f
))
580 (define (mc?
) (not (fluid-ref *make-class
*)))
583 (lambda (self key val
)
584 (kif desc
(ref self key fail
)
585 (aif it
(ref desc
'__set__
)
588 (mset self key val
))))
590 (define (mset-py x key val
)
592 (aif class
(find-in-class xx
'__class__
#f
)
593 (aif f
(find-in-class-and-parents class
'__setattr__
#f
)
594 (if (eq? f __setattr__
)
596 (f xx
(symbol->string key
) val
))
597 (__setattr__ xx key val
))
600 (define-syntax-rule (mklam (mset a ...
) val
)
603 (define-method (set (x <pf
>) key val
) (mklam (mset x key
) val
))
604 (define-method (set (x <p
>) key val
) (mklam (mset x key
) val
))
605 (define-method (set (x <pyf
>) key val
) (mklam (mset-py x key
) val
))
606 (define-method (set (x <py
>) key val
) (mklam (mset-py x key
) val
))
608 (define-method (rawset (x <pf
>) key val
) (mklam (mset x key
) val
))
609 (define-method (rawset (x <p
>) key val
) (mklam (mset x key
) val
))
611 ;; mref will reference the value of the key in the object x, an extra default
612 ;; parameter will tell what the fail object is else #f if fail
613 ;; if there is no found binding in the object search the class and
614 ;; the super classes for a binding
616 ;; call a function as a value of key in x with the object otself as a first
617 ;; parameter, this is pythonic object semantics
618 (define-syntax-rule (mk-call mcall mref
)
619 (define-syntax-rule (mcall x key l
)
620 (apply (mref x key
'()) l
)))
623 (mk-call mcall-py mref-py
)
625 (define-method (call (x <pf
>) key . l
) (mcall x key l
))
626 (define-method (call (x <p
>) key . l
) (mcall x key l
))
627 (define-method (call (x <pyf
>) key . l
) (mcall-py x key l
))
628 (define-method (call (x <py
>) key . l
) (mcall-py x key l
))
631 ;; make a copy of a pf object
632 (define-syntax-rule (mcopy x
)
633 (let ((r (make-p (ref x
'__goops__
))))
634 (slot-set! r
'h
(slot-ref x
'h
))
635 (slot-set! r
'size
(slot-ref x
'size
))
636 (slot-set! r
'n
(slot-ref x
'n
))
639 (define-syntax-rule (mcopy- x
)
640 (let* ((r (make-p (ref x
'__goops__
)))
642 (hash-for-each (lambda (k v
) (hash-set! h k v
)) (slot-ref x
'h
))
645 (define-method (copy (x <pf
>)) (mcopy x
))
646 (define-method (copy (x <p
> )) (mcopy- x
))
648 ;; make a copy of a pf object
649 (define-syntax-rule (mtr r x
)
651 (slot-set! r
'h
(slot-ref x
'h
))
652 (slot-set! r
'size
(slot-ref x
'size
))
653 (slot-set! r
'n
(slot-ref x
'n
))
656 (define-syntax-rule (mtr- r x
)
658 (slot-set! r
'h
(slot-ref x
'h
))
662 (define-method (tr (r <pf
>) (x <pf
>)) (mtr r x
))
663 (define-method (tr (r <p
> ) (x <p
> )) (mtr- r x
))
666 ;; with will execute thunk and restor x to it's initial state after it has
667 ;; finished note that this is a cheap operatoin because we use a functional
669 (define-syntax-rule (mwith x thunk
)
670 (let ((old (mcopy x
)))
672 (slot-set! x
'h
(slot-ref old
'h
))
673 (slot-set! x
'size
(slot-ref old
'size
))
674 (slot-set! x
'n
(slot-ref old
'n
))
677 (define-syntax-rule (mwith- x thunk
)
678 (let ((old (mcopy- x
)))
680 (slot-set! x
'h
(slot-ref old
'h
))
685 ;; a functional set will return a new object with the added binding and keep
687 (define-method (fset (x <pf
>) key val
)
692 (define-method (fset (x <p
>) key val
)
693 (let ((x (mcopy- x
)))
697 (define (fset-x obj l val
)
698 (let lp
((obj obj
) (l l
) (r '()))
701 (let lp
((v val
) (r r
))
703 (lp (fset (caar r
) (cdar r
) v
) (cdr r
))
706 (lp (ref obj k
#f
) l
(cons (cons obj k
) r
))))))
712 ;; a functional call will keep x untouched and return (values fknval newx)
713 ;; e.g. we get both the value of the call and the new version of x with
714 ;; perhaps new bindings added
715 (define-method (fcall (x <pf
>) key . l
)
718 (if (eq?
(slot-ref x
'h
) (slot-ref y
'h
))
722 (define-method (fcall (x <p
>) key . l
)
724 (values (mcall x key l
)
727 ;; this shows how we can override addition in a pythonic way
729 ;; lets define get put pcall etc so that we can refer to an object like
730 ;; e.g. (put x.y.z 1) (pcall x.y 1)
732 (define-syntax-rule (cross x k f set
)
733 (call-with-values (lambda () f
)
737 (values r
(set x k y
))))))
739 (define-syntax-rule (cross! x k f _
) f
)
743 ((_ cross set setx f
(key) (val ...
))
744 (setx f key val ...
))
745 ((_ cross set setx f
(k . l
) val
)
746 (cross f k
(mku cross set setx
(ref f k
) l val
) set
))))
748 (define-syntax-rule (mkk pset setx set cross
)
753 (let* ((to (lambda (x)
754 (datum->syntax
#'f
(string->symbol x
))))
755 (l (string-split (symbol->string
(syntax->datum
#'f
)) #\.
)))
756 (with-syntax (((a (... ...
)) (map (lambda (x) #`'#,(to x
))
759 #'(mku cross setx set h
(a (... ...
)) (val (... ...
))))))))))
761 (mkk put fset fset cross
)
762 (mkk put
! set set cross
!)
763 (mkk pcall
! call fset cross
!)
764 (mkk pcall fcall fset cross
)
765 (mkk get ref fset cross
!)
767 ;; it's good to have a null object so we don't need to construct it all the
768 ;; time because it is functional we can get away with this.
769 (define null
(make-p <pf
>))
771 (define (filter-parents l
)
774 (if (is-a?
(car l
) <p
>)
775 (cons (car l
) (lp (cdr l
)))
779 (define (kw->class kw meta
)
780 (if (memq #:functional kw
)
783 (if (or (not meta
) (is-a? meta
<pyf
>) (is-a? meta
<py
>))
787 (if (or (is-a? meta
<pyf
>) (is-a? meta
<pf
>))
803 (define (defaulter d
)
805 (aif it
(ref d
'__goops__
)
812 (define (kwclass->class kw default
)
813 (if (memq #:functionalClass kw
)
814 (if (memq #:fastClass kw
)
816 (if (memq #:pyClass kw
)
818 (if (or (is-a? default
<py
>) (is-a? default
<pyf
>))
821 (if (memq #:mutatingClass kw
)
822 (if (memq #:fastClass kw
)
824 (if (memq #:pyClass kw
)
826 (if (or (is-a? default
<py
>) (is-a? default
<pyf
>))
829 (if (memq #:fastClass kw
)
830 (if (or (is-a? default
<pf
>) (is-a? default
<pyf
>))
833 (if (memq #:pyClass kw
)
834 (if (or (is-a? default
<pf
>) (is-a? default
<pyf
>))
837 (defaulter default
))))))
843 ((name supers.kw methods
)
844 (make-p-class name
"" supers.kw methods
))
845 ((name doc supers.kw methods
)
846 (define s.kw supers.kw
)
847 (define kw
(cdr s.kw
))
848 (define supers
(car s.kw
))
849 (define goopses
(map (lambda (sups)
850 (aif it
(find-in-class sups
'__goops__
#f
)
855 (define parents
(let ((p (filter-parents supers
)))
858 (define cparents
(if (null? parents
)
864 (define meta
(aif it
(memq #:metaclass kw
)
868 (let* ((p (car cparents
))
869 (m (ref p
'__class__
))
870 (mro (reverse (ref m
'__mro__
'()))))
871 (let lp
((l (cdr cparents
))
876 (meta (ref p
'__class__
))
877 (mro (ref meta
'__mro__
'())))
878 (let lp2
((max max
) (mr (reverse mro
)))
879 (if (and (pair? max
) (pair? mr
))
880 (if (eq?
(car max
) (car mr
))
881 (lp2 (cdr max
) (cdr mr
))
883 "need a common lead for meta"))
885 (if (< (length mro
) (length min
))
887 (lp (cdr l
) max min
))
888 (lp (cdr l
) mro min
)))))
889 (car (reverse min
))))))))
891 (define goops
(make-class (append goopses
892 (list (kw->class kw meta
)))
895 (define (make-module)
896 (let ((l (module-name (current-module))))
897 (if (and (>= (length l
) 3)
898 (equal?
(list-ref l
0) 'language
)
899 (equal?
(list-ref l
1) 'python
)
900 (equal?
(list-ref l
2) 'module
))
902 (map symbol-
>string
(cdddr l
))
906 (define (gen-methods dict
)
907 (define (filt-bases x
)
912 (cons y
(lp (cdr x
)))
918 (pylist-set! dict
'__goops__ goops
)
919 (pylist-set! dict
'__class__ meta
)
920 (pylist-set! dict
'__zub_classes__
(make-weak-key-hash-table))
921 (pylist-set! dict
'__module__
(make-module))
922 (pylist-set! dict
'__bases__
(filt-bases parents
))
923 (pylist-set! dict
'__fget__
#t
)
924 (pylist-set! dict
'__fset__
#t
)
925 (pylist-set! dict
'__name__ name
)
926 (pylist-set! dict
'__qualname__ name
)
927 (pylist-set! dict
'__class__ meta
)
928 (pylist-set! dict
'__mro__
(get-mro cparents
))
929 (pylist-set! dict
'__doc__ doc
)
932 (let ((cl (with-fluids ((*make-class
* #t
))
933 (create-class meta name parents gen-methods kw
))))
934 (aif it
(ref meta
'__init_subclass__
)
935 (let lp
((ps cparents
))
937 (let ((super (car ps
)))
945 ;; Let's make an object essentially just move a reference
947 ;; the make class and defclass syntactic sugar
949 (define-syntax make-up
950 (syntax-rules (lambda case-lambda lambda
* letrec letrec
*)
952 (object-method (lambda . l
)))
953 ((_ (case-lambda . l
))
954 (object-method (case-lambda . l
)))
956 (object-method (lambda* . l
)))
958 (object-method (letrec . l
)))
960 (object-method (letrec* . l
)))
963 (define-syntax mk-p-class
966 ((_ name parents
(ddef dname dval
) ...
)
967 #'(mk-p-class name parents
"" (ddef dname dval
) ...
))
968 ((_ name parents doc
(ddef dname dval
) ...
)
969 (with-syntax (((ddname ...
)
976 (syntax->datum
#'name
))
979 (syntax->datum dn
))))))
981 (nname (datum->syntax
986 (syntax->datum
#'name
))
988 (%add-to-warn-list
(syntax->datum
#'nname
))
989 (map (lambda (x) (%add-to-warn-list
(syntax->datum x
)))
993 (letruc ((dname (make-up dval
)) ...
)
995 (make-p-class 'name doc
998 (pylist-set! dict
'dname dname
)
1002 (module-define! (current-module) 'ddname dname
)
1003 (name-object ddname
))
1007 (module-define! (current-module) 'nname
(rawref name
'__goops__
))
1012 (define-syntax mk-p-class2
1015 ((_ name parents
((ddef dname dval
) ...
) body
)
1016 #'(mk-p-class2 name parents
"" ((ddef dname dval
) ...
) body
))
1017 ((_ name parents doc
((ddef dname dval
) ...
) body
)
1018 (with-syntax (((ddname ...
)
1025 (syntax->datum
#'name
))
1028 (syntax->datum dn
))))))
1030 (nname (datum->syntax
1035 (syntax->datum
#'name
))
1038 (%add-to-warn-list
(syntax->datum
#'nname
))
1039 (map (lambda (x) (%add-to-warn-list
(syntax->datum x
)))
1044 (letruc ((dname (make-up dval
)) ...
)
1047 (make-p-class 'name doc
1051 (pylist-set! dict
'dname dname
))
1055 (module-define! (current-module) 'ddname dname
)
1056 (name-object ddname
))
1059 (module-define! (current-module) 'nname
(rawref name
'__goops__
))
1064 (define-syntax mk-p-class-noname
1067 ((_ name parents
(ddef dname dval
) ...
)
1068 #'(mk-p-class-noname name parents
"" (ddef dname dval
) ...
))
1069 ((_ name parents doc
(ddef dname dval
) ...
)
1072 (letruc ((dname dval
) ...
)
1073 (make-p-class 'name doc
1076 (pylist-set! dict
'dname dname
)
1081 (define-syntax-rule (def-p-class name . l
)
1082 (define name
(mk-p-class name . l
)))
1084 (define (get-class o
)
1089 (error "not a pyclass"))))
1091 (define (get-type o
)
1105 (define p
(if (pyclass? o
) "C" (if (pyobject? o
) "O" "T")))
1106 (define port
(if (pair? l
) (car l
) #t
))
1108 (aif it
(if (pyclass? o
)
1115 p
(get-type o
) (it))
1118 p
(get-type o
) (ref o
'__name__
'Annonymous
)))))
1120 (define-method (write (o <p
>) . l
) (print o l
))
1121 (define-method (display (o <p
>) . l
) (print o l
))
1123 (define (arglist->pkw l
)
1124 (let lp
((l l
) (r '()))
1128 (cons (reverse r
) l
)
1129 (lp (cdr l
) (cons x r
))))
1130 (cons (reverse r
) '()))))
1132 (define-syntax-rule (define-python-class name
(parents ...
) code ...
)
1134 (syntax-parameterize ((*class
* (lambda (x) #'name
)))
1135 (mk-p-class name
(arglist->pkw
(list parents ...
)) code ...
))))
1137 (define-syntax-rule (define-python-class-noname name
(parents ...
) code ...
)
1139 (syntax-parameterize ((*class
* (lambda (x) #'name
)))
1140 (mk-p-class-noname name
(arglist->pkw
(list parents ...
))
1144 (define-syntax make-python-class
1147 ((_ name
(parents ...
) code ...
)
1148 #'(let* ((cl (mk-p-class name
1149 (arglist->pkw
(list parents ...
))
1153 (define type-goops
#f
)
1155 (if (not type-goops
) (set! type-goops
(ref type
'__goops__
)))
1157 (aif it
(find-in-class x
'__goops__
#f
)
1161 (member it
(class-subclasses type-goops
)))
1166 (define (pyobject? x
) (eq?
(kind x
) 'object
))
1167 (define (pyclass? x
) (eq?
(kind x
) 'class
))
1168 (define (pytype? x
) (eq?
(kind x
) 'type
))
1170 (define (mark-fkn tag f
)
1171 (set-procedure-property! f
'py-special tag
)
1174 (define-syntax-parameter
1175 *class
* (lambda (x) (error "*class* not parameterized")))
1176 (define-syntax-parameter
1177 *self
* (lambda (x) (error "*class* not parameterized")))
1179 (define *super
* (list 'super
))
1181 (define (not-a-super) 'not-a-super
)
1182 (define (py-super class obj
)
1183 (define (make cl parents
)
1184 (pk 'parents cl parents
)
1187 (let ((c (make-p <py
>))
1189 (rawset c
'__class__ type
)
1190 (rawset c
'__mro__
(cons* c parents
))
1191 (rawset c
'__getattribute__
1193 (set! key
(if (string? key
) (string->symbol key
) key
))
1195 (pk key
(kif it
(pk 'it
(ficap c key fail
))
1196 (aif dt
(pk '__get__
(ref it
'__get__
))
1200 (rawset c
'__name__
"**super**")
1201 (rawset o
'__class__ c
)
1204 (pk 'super class
(ref obj
'__name__
))
1208 (let ((ll (pk 'l class
(ref (ref obj
'__class__
) '__mro__
'()))))
1212 (if (eq? class
(car l
))
1218 (values (car ll
) ll
)))
1224 (define-syntax py-super-mac
1227 (py-super *class
* *self
*))
1229 (py-super class self
))))
1232 (pretty-print (syntax->datum x
))
1235 (define-syntax letruc
1238 ((_ ((x v
) ...
) code ...
)
1239 (let lp
((a #'(x ...
)) (b #'(v ...
)) (u '()))
1242 (s (syntax->datum x
)))
1243 (let lp2
((a2 (cdr a
)) (b2 (cdr b
)) (a3 '()) (b3 '())
1246 (if (eq?
(syntax->datum a2
) s
)
1247 (lp2 (cdr a2
) (cdr b2
) a3 b3
(cons (car b2
) r
))
1248 (lp2 (cdr a2
) (cdr b2
)
1252 (lp (reverse a3
) (reverse b3
)
1254 (list x
#`(let* #,(map (lambda (v) (list x v
))
1257 #`(letrec #,(reverse u
) code ...
)))))))
1261 (define-method (py-init . l
)
1264 (define-method (py-init (o <p
>) . l
)
1265 (aif it
(ref o
'__init__
)
1273 ((root hist
) (vector root hist
))))
1275 (define (geth t
) (vector-ref t
1))
1276 (define (getr t
) (vector-ref t
0))
1277 (define (tree-ref t
) (car (getr t
)))
1283 (dive (car r
) (cons (cdr r
) h
))
1289 (up (car h
) (cdr h
))
1296 (let ((r (getr tree
)) (h (geth tree
)))
1303 (dive x
(cons (cdr r
) h
))
1306 (up (car h
) (cdr h
))
1310 (up (car h
) (cdr h
))
1313 (define (class-to-tree cl
)
1316 (ref cl
'__bases__
'()))))
1318 (define (find-tree o tree
)
1320 (let ((x (tree-ref tree
)))
1323 (find-tree o
(nxt tree
))))
1326 (define (linearize x
)
1330 (append (linearize (car x
)) (linearize (cdr x
))))
1333 (define (get-mro parents
)
1337 (get-mro0 (map class-to-tree parents
)))))
1339 (define (get-mro0 parents
)
1340 (define tree
(mk-tree parents
))
1341 (let lp
((tree tree
) (r '()))
1343 (let ((x (tree-ref tree
))
1350 (define-method (py-equal?
(x <p
>) y
)
1351 (aif it
(ref x
'__eq__
)
1355 (define-method (py-equal? y
(x <p
>))
1356 (aif it
(ref x
'__eq__
)
1360 (define-method (py-equal? x y
) ((@ (guile) equal?
) x y
))
1362 (define (equal? x y
) (or (eq? x y
) (py-equal? x y
)))
1364 (define (subclasses self
)
1365 (aif it
(ref self
'__zubclasses__
)
1366 (let ((h (make-hash-table)))
1368 (let lp
((l (hash-fold
1378 (hash-fold (lambda (k v s
) (cons k s
)) '() h
))
1382 (define __getattribute__
1385 (define (-fail class
)
1387 (find-in-class self
'__mro__ fail
)
1390 (aif class
(pkk 'class
(find-in-class self
'__class__
#f
))
1391 (kif it1
(pkk 'c
(find-in-class-and-parents class key fail
))
1392 (aif dd1
(pkk 'get
(rawref it1
'__get__
))
1393 (if (pkk 'set
(rawref it1
'__set__
))
1394 (pkk 'desc key
(dd1 self class
))
1395 (kif it2
(find-in-class-and-parents self key fail
)
1396 (pkk 'object key it2
)
1397 (pkk 'gox key
(dd1 self class
))))
1398 (kif it2
(pkk 'o
(find-in-class-and-parents self key fail
))
1399 (pkk 'object key it2
)
1400 (pkk 'class key it1
)))
1401 (kif it2
(pkk 'o2
(find-in-class-and-parents self key fail
))
1402 (pkk 'object key it2
)
1403 (aif it
(pkk 'getattr
1404 (find-in-class-and-parents class
'__getattr__
#f
))
1406 (lambda () (it self
(symbol->string key
)))
1408 (aif dd1
(rawref it1
'__get__
)
1409 (pkk 'getattr-gox key
(dd1 self class
))
1410 (pkk 'getattr key it1
))
1411 (pkk 'fail1
(-fail class
)))
1412 (pkk 'fail2
(-fail class
)))))
1413 (pkk 'classfail fail
)))))
1415 (define attr __getattribute__
)
1417 (define (*str
* self
)
1418 (scmstr (ref self
'__name__
)))
1420 (define *setattr
* __setattr__
)
1423 (make-python-class type
()
1424 (define __new__ new-class0
)
1425 (define __init_subclass__
(lambda x
(values)))
1426 (define ___zub_classes__
(make-weak-key-hash-table))
1427 (define __subclasses__ subclasses
)
1428 (define __call__ type-call
)
1429 (define __str__
*str
*)
1430 (define __getattribute__ attr
)
1431 (define __setattr__
(object-method *setattr
*))
1432 (define __format__
(lambda (self x
) (*str
* self
)))
1433 (define __reduce_ex__
(lambda x
(error "not implemented")))
1434 (define mro
(lambda (self) (ref self
'__mro__
)))))
1436 (set type
'__class__ type
)
1438 (define _mro
(object-method (lambda (self) (ref self
'__mro__
))))
1440 (define (scmstr s
) (if (symbol? s
) (symbol->string s
) s
))
1443 (make-python-class object
()
1444 (define __init__
(lambda x
(values)))
1445 (define __subclasses__ subclasses
)
1446 (define __getattribute__ attr
)
1447 (define __setattr__
(object-method *setattr
*))
1448 (define __str__
*str
*)
1449 (define __format__
(lambda (self x
) (*str
* self
)))
1450 (define __reduce_ex__
(lambda x
(error "not implemented")))
1451 (define __weakref__
(lambda (self) self
))))
1455 (name-object object
)
1457 (define-method (py-class (o <p
>))
1458 (aif it
(ref o
'__class__
)
1462 (define-python-class NoneObj
()
1466 (define-method (py-dict x
)
1471 (define-method (py-dict (o <p
>))
1472 (aif it
(ref o
'__dict__
)