iterators refactorings
[software/python-on-guile.git] / modules / oop / pf-objects.scm
1 (define-module (oop pf-objects)
2 #:use-module (oop goops)
3 #:use-module (ice-9 vlist)
4 #:use-module (ice-9 match)
5 #:export (set ref make-pf <p> <py> <pf> <pyf> <property>
6 call with copy fset fcall make-p put put!
7 pcall pcall! get fset-x pyclass? refq
8 def-pf-class mk-pf-class make-pf-class
9 def-p-class mk-p-class make-p-class
10 def-pyf-class mk-pyf-class make-pyf-class
11 def-py-class mk-py-class make-py-class
12 define-python-class get-type py-class
13 object-method class-method static-method
14 py-super-mac py-super
15 *class* *self*
16 ))
17 #|
18 Python object system is basically syntactic suger otop of a hashmap and one
19 this project is inspired by the python object system and what it measn when
20 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
21 with assocs or tree like functional hashmaps in stead.
22
23 The hashmap works like an assoc e.g. we will define new values by 'consing' a
24 new binding on the list and when the assoc take up too much space it will be
25 reshaped and all extra bindings will be removed.
26
27 The datastructure is functional but the objects mutate. So one need to
28 explicitly tell it to not update etc.
29 |#
30
31 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
32 (define-class <p> (<applicable-struct>) h)
33 (define-class <pf> (<p>) size n) ; the pf object consist of a functional
34 ; hashmap it's size and number of live
35 ; object
36 (define-class <py> (<p>))
37 (define-class <pyf> (<pf>))
38
39 (define-class <property> () get set del)
40
41 (define (mk x)
42 (letrec ((o (make (ref x '__goops__))))
43 (slot-set! o 'procedure
44 (lambda x
45 (apply
46 (ref o '__call__ (lambda x (error "no __call__ method")))
47 x)))
48 (cond
49 ((is-a? x <pf>)
50 (let ((r (ref x '__const__)))
51 (slot-set! o 'h (slot-ref r 'h))
52 (slot-set! o 'size (slot-ref r 'size))
53 (slot-set! o 'n (slot-ref r 'n))
54 o))
55
56 ((is-a? x <p>)
57 (let ((r (ref x '__const__))
58 (h (make-hash-table)))
59 (hash-set! h '__class__ x)
60 (slot-set! o 'h h))
61 o))))
62
63 (define (make-pyclass x)
64 (letrec ((class (make x)))
65 (slot-set! class 'procedure
66 (lambda x
67 (let ((obj (mk class)))
68 (aif it (ref obj '__init__)
69 (apply it x)
70 (values))
71 obj)))
72 class))
73
74 ;; Make an empty pf object
75 (define* (make-pf #:optional (class <pf>))
76 (define r (make-pyclass class))
77 (slot-set! r 'h vlist-null)
78 (slot-set! r 'size 0)
79 (slot-set! r 'n 0)
80 r)
81
82 (define* (make-p #:optional (class <p>))
83 (define r (make-pyclass class))
84 (slot-set! r 'h (make-hash-table))
85 r)
86
87 (define-syntax-rule (hif it (k h) x y)
88 (let ((a (vhash-assq k h)))
89 (if (pair? a)
90 (let ((it (cdr a)))
91 x)
92 y)))
93
94 (define-syntax-rule (cif (it h) (k cl) x y)
95 (let* ((h (slot-ref cl 'h))
96 (a (vhash-assq k h)))
97 (if (pair? a)
98 (let ((it (cdr a)))
99 x)
100 y)))
101
102 (define fail (cons 'fail '()))
103 (define-syntax-rule (mrefx x key l)
104 (let ()
105 (define (end)
106 (if (null? l)
107 #f
108 (car l)))
109
110 (define (parents li)
111 (let lp ((li li))
112 (if (pair? li)
113 (let ((p (car li)))
114 (cif (it h) (key p)
115 it
116 (lp (cdr li))))
117 fail)))
118
119 (cif (it h) (key x)
120 it
121 (hif cl ('__class__ h)
122 (cif (it h) (key cl)
123 it
124 (hif p ('__mro__ h)
125 (let ((r (parents p)))
126 (if (eq? r fail)
127 (end)
128 r))
129 (end)))
130 (end)))))
131
132 (define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
133 (define-syntax-rule (mrefx-- hi key l)
134 (let ()
135 (define (end) (if (pair? l) (car l) #f))
136 (define (ret q) (if (eq? q fail) (end) q))
137
138 (define (find-in-class h)
139 (let lp ((class-h h))
140 (let ((r (hash-ref class-h key fail)))
141 (if (eq? r fail)
142 (aif parents (hash-ref class-h '__mro__ #f)
143 (let lpp ((parents parents))
144 (if (pair? parents)
145 (let ((parent (car parents)))
146 (let* ((h (slot-ref parent 'h))
147 (r (hash-ref h key fail)))
148 (if (eq? r fail)
149 (lpp (cdr parents))
150 r)))
151 fail))
152 fail)
153 r))))
154
155 (let* ((h hi)
156 (r (hash-ref h key fail)))
157 (if (eq? r fail)
158 (aif class (hash-ref h '__class__)
159 (ret (find-in-class (slot-ref class 'h)))
160 (end))
161 r))))
162
163 (define not-implemented (cons 'not 'implemeneted))
164
165 (define-syntax-rule (prop-ref xx x)
166 (let ((y xx)
167 (r x))
168 (if (and (is-a? r <property>) (not (pyclass? y)))
169 ((slot-ref r 'get) y)
170 r)))
171
172 (define-syntax-rule (mrefx-py- x key l)
173 (let ((xx x))
174 (prop-ref
175 xx
176 (let ((f (mrefx- xx '__getattribute__ '())))
177 (if (or (not f) (eq? f not-implemented))
178 (mrefx- xx key l)
179 (apply f xx key l))))))
180
181 (define-syntax-rule (mrefx-py x key l)
182 (let ((xx x))
183 (prop-ref
184 xx
185 (let ((f (mrefx xx '__getattribute__ '())))
186 (if (or (not f) (eq? f not-implemented))
187 (mrefx xx key l)
188 (apply f xx key l))))))
189
190 (define-syntax-rule (unx mrefx- mref-)
191 (define-syntax-rule (mref- x key l)
192 (let ((xx x))
193 (let ((res (mrefx- xx key l)))
194 (if (and (not (struct? res)) (procedure? res))
195 (res xx)
196 res)))))
197
198 (unx mrefx- mref-)
199 (unx mrefx mref)
200 (unx mrefx-py mref-py)
201 (unx mrefx-py- mref-py-)
202
203 (define-syntax-rule (unx mrefx- mref-)
204 (define-syntax-rule (mref- x key l)
205 (let ((xx x))
206 (let ((res (mrefx- xx key l)))
207 (if (and (not (struct? res))
208 (not (pyclass? res))
209 (procedure? res))
210 (res xx)
211 res)))))
212
213 (unx mrefx- mref-q)
214 (unx mrefx mrefq)
215 (unx mrefx-py mref-pyq)
216 (unx mrefx-py- mref-py-q)
217
218 (define-method (ref (x <pf> ) key . l) (mref x key l))
219 (define-method (ref (x <p> ) key . l) (mref- x key l))
220 (define-method (ref (x <pyf>) key . l) (mref-py x key l))
221 (define-method (ref (x <py> ) key . l) (mref-py- x key l))
222
223 (define-method (refq (x <pf> ) key . l) (mrefq x key l))
224 (define-method (refq (x <p> ) key . l) (mref-q x key l))
225 (define-method (refq (x <pyf>) key . l) (mref-pyq x key l))
226 (define-method (refq (x <py> ) key . l) (mref-py-q x key l))
227
228 ;; the reshape function that will create a fresh new pf object with less size
229 ;; this is an expensive operation and will only be done when we now there is
230 ;; a lot to gain essentially tho complexity is as in the number of set
231 (define (reshape x)
232 (let ((h (slot-ref x 'h))
233 (m (make-hash-table))
234 (n 0))
235 (define h2 (vhash-fold (lambda (k v s)
236 (if (hash-ref m k #f)
237 s
238 (begin
239 (hash-set! m k #t)
240 (set! n (+ n 1))
241 (vhash-consq k v s))))
242 vlist-null
243 h))
244 (slot-set! x 'h h2)
245 (slot-set! x 'size n)
246 (slot-set! x 'n n)
247 (values)))
248
249 ;; on object x add a binding that key -> val
250 (define-syntax-rule (mset x key val)
251 (let ((h (slot-ref x 'h))
252 (s (slot-ref x 'size))
253 (n (slot-ref x 'n)))
254 (slot-set! x 'size (+ 1 s))
255 (let ((r (vhash-assq key h)))
256 (when (not r)
257 (slot-set! x 'n (+ n 1)))
258 (slot-set! x 'h (vhash-consq key val h))
259 (when (> s (* 2 n))
260 (reshape x))
261 (values))))
262
263 (define-syntax-rule (mset-py x key val)
264 (let ((f (mref-py x '__setattr__ '())))
265 (if (or (eq? f not-implemented) (not f))
266 (mset x key val)
267 (f key val))))
268
269 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
270
271 (define-syntax-rule (mset- x key val)
272 (let ()
273 (define (s h) (begin (hash-set! h key val) #f))
274 (define fret #t)
275 (define (r h k) (hash-ref h k))
276 (define-syntax-rule (ifh h fail-code)
277 (if (r h key)
278 (s h)
279 fail-code))
280
281 (define (hm x) (slot-ref x 'h))
282 (let ((h (hm x)))
283 (if (ifh h
284 (aif it (r h '__class__)
285 (let lp ((cl it))
286 (let ((h (hm cl)))
287 (ifh h
288 (aif it (r h '__parents__)
289 (let lp2 ((parents it))
290 (if (pair? parents)
291 (let ((h (hm (car parents))))
292 (ifh h
293 (lp2 (cdr parents))))
294 fret))
295 fret))))
296 fret))
297 (s h))
298 (values))))
299
300 (define-syntax-rule (mset-py- x key val)
301 (let ((v (mref- x key fail)))
302 (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x)))))
303 (let ((f (mref-py- x '__setattr__ '())))
304 (if (or (eq? f not-implemented) (not f))
305 (mset- x key val)
306 (f key val)))
307 ((slot-ref v 'set) x val))))
308
309 (define-syntax-rule (mklam (mset a ...) val)
310 (if (and (procedure? val)
311 (not (pyclass? val))
312 (if (is-a? val <p>)
313 (ref val '__call__)
314 #t))
315 (if (procedure-property val 'py-special)
316 (mset a ... val)
317 (mset a ... (object-method val)))
318 (mset a ... val)))
319
320 (define-method (set (x <pf>) key val) (mklam (mset x key) val))
321 (define-method (set (x <p>) key val) (mklam (mset- x key) val))
322 (define-method (set (x <pyf>) key val) (mklam (mset-py x key) val))
323 (define-method (set (x <py>) key val) (mklam (mset-py- x key) val))
324
325 ;; mref will reference the value of the key in the object x, an extra default
326 ;; parameter will tell what the fail object is else #f if fail
327 ;; if there is no found binding in the object search the class and
328 ;; the super classes for a binding
329
330 ;; call a function as a value of key in x with the object otself as a first
331 ;; parameter, this is pythonic object semantics
332 (define-syntax-rule (mk-call mcall mref)
333 (define-syntax-rule (mcall x key l)
334 (apply (mref x key '()) l)))
335
336 (mk-call mcall mref)
337 (mk-call mcall- mref-)
338 (mk-call mcall-py mref-py)
339 (mk-call mcall-py- mref-py-)
340
341 (define-method (call (x <pf>) key . l) (mcall x key l))
342 (define-method (call (x <p>) key . l) (mcall- x key l))
343 (define-method (call (x <pyf>) key . l) (mcall-py x key l))
344 (define-method (call (x <py>) key . l) (mcall-py- x key l))
345
346
347 ;; make a copy of a pf object
348 (define-syntax-rule (mcopy x)
349 (let ((r (make-pyclass <pf>)))
350 (slot-set! r 'h (slot-ref x 'h))
351 (slot-set! r 'size (slot-ref x 'size))
352 (slot-set! r 'n (slot-ref x 'n))
353 r))
354
355 (define-syntax-rule (mcopy- x)
356 (let* ((r (make-p))
357 (h (slot-ref r 'h)))
358 (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
359 r))
360
361 (define-method (copy (x <pf>)) (mcopy x))
362 (define-method (copy (x <p> )) (mcopy- x))
363
364
365 ;; with will execute thunk and restor x to it's initial state after it has
366 ;; finished note that this is a cheap operatoin because we use a functional
367 ;; datastructure
368 (define-syntax-rule (mwith x thunk)
369 (let ((old (mcopy x)))
370 (let ((r (thunk)))
371 (slot-set! x 'h (slot-ref old 'h))
372 (slot-set! x 'size (slot-ref old 'size))
373 (slot-set! x 'n (slot-ref old 'n))
374 r)))
375
376 (define-syntax-rule (mwith- x thunk)
377 (let ((old (mcopy- x)))
378 (let ((r (thunk)))
379 (slot-set! x 'h (slot-ref old 'h))
380 r)))
381
382
383
384 ;; a functional set will return a new object with the added binding and keep
385 ;; x untouched
386 (define-method (fset (x <pf>) key val)
387 (let ((x (mcopy x)))
388 (mset x key val)
389 x))
390
391 (define-method (fset (x <p>) key val)
392 (let ((x (mcopy- x)))
393 (mset x key val)
394 x))
395
396 (define (fset-x obj l val)
397 (let lp ((obj obj) (l l) (r '()))
398 (match l
399 (()
400 (let lp ((v val) (r r))
401 (if (pair? r)
402 (lp (fset (caar r) (cdar r) v) (cdr r))
403 v)))
404 ((k . l)
405 (lp (ref obj k #f) l (cons (cons obj k) r))))))
406
407
408
409
410
411 ;; a functional call will keep x untouched and return (values fknval newx)
412 ;; e.g. we get both the value of the call and the new version of x with
413 ;; perhaps new bindings added
414 (define-method (fcall (x <pf>) key . l)
415 (let* ((y (mcopy x))
416 (r (mcall y key l)))
417 (if (eq? (slot-ref x 'h) (slot-ref y 'h))
418 (values r x)
419 (values r y))))
420
421 (define-method (fcall (x <p>) key . l)
422 (let ((x (mcopy x)))
423 (values (mcall- x key l)
424 x)))
425
426 ;; this shows how we can override addition in a pythonic way
427
428 ;; lets define get put pcall etc so that we can refer to an object like
429 ;; e.g. (put x.y.z 1) (pcall x.y 1)
430
431 (define-syntax-rule (cross x k f set)
432 (call-with-values (lambda () f)
433 (lambda (r y)
434 (if (eq? x y)
435 (values r x)
436 (values r (set x k y))))))
437
438 (define-syntax-rule (cross! x k f _) f)
439
440 (define-syntax mku
441 (syntax-rules ()
442 ((_ cross set setx f (key) (val ...))
443 (setx f key val ...))
444 ((_ cross set setx f (k . l) val)
445 (cross f k (mku cross set setx (ref f k) l val) set))))
446
447 (define-syntax-rule (mkk pset setx set cross)
448 (define-syntax pset
449 (lambda (x)
450 (syntax-case x ()
451 ((_ f val (... ...))
452 (let* ((to (lambda (x)
453 (datum->syntax #'f (string->symbol x))))
454 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
455 (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
456 (cdr l)))
457 (h (to (car l))))
458 #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
459
460 (mkk put fset fset cross)
461 (mkk put! set set cross!)
462 (mkk pcall! call fset cross!)
463 (mkk pcall fcall fset cross)
464 (mkk get ref fset cross!)
465
466 ;; it's good to have a null object so we don't need to construct it all the
467 ;; time because it is functional we can get away with this.
468 (define null (make-pf))
469
470 ;; append the bindings in x in front of y + some optimizations
471 (define (union x y)
472 (define hx (slot-ref x 'h))
473 (define hy (slot-ref y 'h))
474 (define n (slot-ref x 'n))
475 (define s (slot-ref x 'size))
476 (define m (make-hash-table))
477
478 (define h
479 (vhash-fold
480 (lambda (k v st)
481 (if (vhash-assq k hy)
482 (begin
483 (set! s (+ s 1))
484 (vhash-consq k v st))
485 (if (hash-ref m k)
486 s
487 (begin
488 (set! n (+ n 1))
489 (set! s (+ s 1))
490 (hash-set! m k #t)
491 (vhash-consq k v st)))))
492 hy
493 hx))
494
495 (define out (make-pyclass <pf>))
496 (slot-set! out 'h h)
497 (slot-set! out 'n n)
498 (slot-set! out 'size s)
499 out)
500
501 (define (union- class x y)
502 (define hx (slot-ref x 'h))
503 (define hy (slot-ref y 'h))
504 (define out (make-p class))
505 (define h (slot-ref out 'h))
506 (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
507 (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
508 out)
509
510
511 ;; make a class. A class add some meta information to allow for multiple
512 ;; inherritance and add effectively static data to the object the functional
513 ;; datastructure show it's effeciency now const is data that will not change
514 ;; and bindings that are added to all objects. Dynamic is the mutating class
515 ;; information. supers is a list of priorities
516 (define-syntax-rule (mk-pf make-pf-class <pf>)
517 (define-syntax make-pf-class
518 (lambda (x)
519 (syntax-case x ()
520 ((_ name const dynamic (supers (... ...)))
521 (with-syntax (((sups (... ...)) (generate-temporaries
522 #'(supers (... ...)))))
523 #'(let ((sups supers) (... ...))
524 (define name (make-class (list sups (... ...) <pf>) '()))
525 (define class (dynamic name))
526 (define __const__
527 (union const
528 (let lp ((sup (filter-parents
529 (list sups (... ...)))))
530 (if (pair? sup)
531 (union (ref (car sup) '__const__ null)
532 (lp (cdr sup)))
533 null))))
534
535 (reshape __const__)
536 (set class '__const__ __const__)
537 (set class '__goops__ name)
538 (set class '__name__ 'name)
539 (set class '__parents__ (filter-parents
540 (list sups (... ...))))
541 (set class '__mro__ (get-mro class))
542 (set class '__goops__ name)
543 (set __const__ '__name__ 'name)
544 (set __const__ '__goops__ class)
545 (set __const__ '__parents__ (filter-parents
546 (list sups (... ...))))
547 (set __const__ '__goops__ name)
548
549 class)))))))
550
551 (mk-pf make-pf-class <pf>)
552 (mk-pf make-pyf-class <pyf>)
553
554 (define (filter-parents l)
555 (let lp ((l l))
556 (if (pair? l)
557 (if (is-a? (car l) <p>)
558 (cons (car l) (lp (cdr l)))
559 (lp (cdr l)))
560 '())))
561
562 (define-syntax-rule (mk-p make-p-class <p>)
563 (define-syntax make-p-class
564 (lambda (x)
565 (syntax-case x ()
566 ((_ name const dynamic (supers (... ...)))
567 (with-syntax (((sups (... ...)) (generate-temporaries
568 #'(supers (... ...)))))
569 #'(let ((sups supers) (... ...))
570 (define name (make-class (list
571 (if (is-a? sups <p>)
572 (aif it (ref sups '__goops__ #f)
573 it
574 sups)
575 sups)
576 (... ...) <p>) '()))
577
578 (define class (dynamic <p>))
579 (set class '__name__ 'name)
580 (set class '__class__ #f)
581 (set class '__goops__ name)
582 (set class '__parents__ (filter-parents (list sups (... ...))))
583 (set class '__mro__ (get-mro class))
584 class)))))))
585
586 (mk-p make-p-class <p>)
587 (mk-p make-py-class <py>)
588
589 ;; Let's make an object essentially just move a reference
590
591 ;; the make class and defclass syntactic sugar
592 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
593 (define-syntax-rule (mk-pf-class name (parents (... ...))
594 #:const
595 ((sdef mname sval) (... ...))
596 #:dynamic
597 ((ddef dname dval) (... ...)))
598 (let ()
599 (define name
600 (letruc ((mname sval) (... ...) (dname dval) (... ...))
601 (make-pf-class name
602 (let ((s (make-pf)))
603 (set s 'mname mname) (... ...)
604 s)
605 (lambda (class)
606 (let ((d (make-pf class)))
607 (set d 'dname dname) (... ...)
608 d))
609 (parents (... ...)))))
610 name)))
611
612 (mk-p/f make-pf mk-pf-class make-pf-class)
613 (mk-p/f make-p mk-p-class make-p-class)
614 (mk-p/f make-pf mk-pyf-class make-pyf-class)
615 (mk-p/f make-p mk-py-class make-py-class)
616
617 (define-syntax-rule (def-pf-class name . l)
618 (define name (mk-pf-class name . l)))
619
620 (define-syntax-rule (def-p-class name . l)
621 (define name (mk-p-class name . l)))
622
623 (define-syntax-rule (def-pyf-class name . l)
624 (define name (mk-pyf-class name . l)))
625
626 (define-syntax-rule (def-py-class name . l)
627 (define name (mk-py-class name . l)))
628
629 (define (get-class o)
630 (cond
631 ((is-a? o <p>)
632 o)
633 (else
634 (error "not a pyclass"))))
635
636 (define (get-type o)
637 (cond
638 ((is-a? o <pyf>)
639 'pyf)
640 ((is-a? o <py>)
641 'py)
642 ((is-a? o <pf>)
643 'pf)
644 ((is-a? o <p>)
645 'p)
646 (else
647 'none)))
648
649 (define (print o l)
650 (define p1 (if (pyclass? o) "C" "O"))
651 (define p2 (if (pyclass? o) "C" "O"))
652 (define port (if (pair? l) (car l) #t))
653 (format port "~a"
654 (aif it (if (pyclass? o) #f (ref o '__repr__ #f))
655 (format
656 #f "~a(~a)<~a>" p1 (get-type o) (it))
657 (format
658 #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
659
660 (define-method (write (o <p>) . l) (print o l))
661 (define-method (display (o <p>) . l) (print o l))
662
663 (define-syntax-rule (define-python-class name parents code ...)
664 (define name
665 (mk-py-class name parents
666 #:const
667 ()
668 #:dynamic
669 (code ...))))
670
671 (define (pyclass? x)
672 (and (is-a? x <p>)
673 (if (ref x '__class__)
674 #f
675 (if (ref x '__super__)
676 'super
677 #t))))
678
679 (define-method (py-class (o <p>))
680 (ref o '__class__ 'type))
681
682 (define (mark-fkn tag f)
683 (set-procedure-property! f 'py-special tag)
684 f)
685
686 (define (object-method f)
687 (letrec ((self
688 (mark-fkn 'object
689 (lambda (x)
690 (aif it (pyclass? x)
691 (if (eq? it 'super)
692 self
693 f)
694 (lambda z (apply f x z)))))))
695 self))
696
697 (define (class-method f)
698 (letrec ((self
699 (mark-fkn 'class
700 (lambda (x)
701 (aif it (pyclass? x)
702 (if (eq? it 'super)
703 self
704 (lambda z (apply f x z)))
705 (lambda z (apply f (ref x '__class__) z)))))))
706 self))
707
708 (define (static-method f)
709 (letrec ((self
710 (mark-fkn 'static
711 (lambda (x)
712 (if (eq? (pyclass? x) 'super)
713 self
714 f)))))
715 self))
716
717
718 (define-syntax-parameter
719 *class* (lambda (x) (error "*class* not parameterized")))
720 (define-syntax-parameter
721 *self* (lambda (x) (error "*class* not parameterized")))
722
723 (define *super* (list 'super))
724
725 (define (not-a-super) 'not-a-super)
726 (define (py-super class obj)
727 (define (make cl parents)
728 (let ((c (make-p))
729 (o (make-p)))
730 (set c '__super__ #t)
731 (set c '__mro__ parents)
732 (set c '__getattribute__ (lambda (self key . l)
733 (aif it (ref c key)
734 (if (procedure? it)
735 (if (eq? (procedure-property
736 it
737 'py-special)
738 'class)
739 (it cl)
740 (it obj))
741 it)
742 (error "no attribute"))))
743 (set o '__class__ c)
744 o))
745
746 (call-with-values
747 (lambda ()
748 (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
749 (if (pair? l)
750 (if (eq? class (car l))
751 (let ((r (cdr l)))
752 (if (pair? r)
753 (values (car r) r)
754 (values #f #f)))
755 (lp (cdr l)))
756 (values #f #f))))
757 make))
758
759
760
761 (define-syntax py-super-mac
762 (syntax-rules ()
763 ((_)
764 (py-super *class* *self*))
765 ((_ class self)
766 (py-super class self))))
767
768 (define-syntax letruc
769 (lambda (x)
770 (syntax-case x ()
771 ((_ ((x v) ...) code ...)
772 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
773 (if (pair? a)
774 (let* ((x (car a))
775 (s (syntax->datum x)))
776 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
777 (r (list (car b))))
778 (if (pair? a2)
779 (if (eq? (syntax->datum a2) s)
780 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
781 (lp2 (cdr a2) (cdr b2)
782 (cons (car a2) a3)
783 (cons (car b2) b3)
784 r))
785 (lp (reverse a3) (reverse b3)
786 (cons
787 (list x #`(let* #,(map (lambda (v) (list x v))
788 (reverse r)) #,x))
789 u)))))
790 #`(letrec #,(reverse u) code ...)))))))
791
792
793
794
795 (define-method (py-init (o <p>) . l)
796 (apply (ref o '__init__) l))
797
798 (define mk-tree
799 (case-lambda
800 ((root)
801 (vector root '()))
802 ((root hist) (vector root hist))))
803
804 (define (geth t) (vector-ref t 1))
805 (define (getr t) (vector-ref t 0))
806 (define (tree-ref t) (car (getr t)))
807
808 (define (nxt tree)
809 (define (dive r h)
810 (let ((x (car r)))
811 (if (pair? x)
812 (dive (car r) (cons (cdr r) h))
813 (mk-tree r h))))
814
815 (define (up r h)
816 (if (null? r)
817 (if (pair? h)
818 (up (car h) (cdr h))
819 #f)
820 (let ((x (car r)))
821 (if (pair? x)
822 (dive r h)
823 (mk-tree r h)))))
824
825 (let ((r (getr tree)) (h (geth tree)))
826 (cond
827 ((pair? r)
828 (let ((r (cdr r)))
829 (if (pair? r)
830 (let ((x (car r)))
831 (if (pair? x)
832 (dive x (cons (cdr r) h))
833 (mk-tree r h)))
834 (if (pair? h)
835 (up (car h) (cdr h))
836 #f))))
837 (else
838 (if (pair? h)
839 (up (car h) (cdr h))
840 #f)))))
841
842 (define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
843
844 (define (find-tree o tree)
845 (if tree
846 (let ((x (tree-ref tree)))
847 (if (eq? o x)
848 #t
849 (find-tree o (nxt tree))))
850 #f))
851
852 (define (get-mro class)
853 (define tree (mk-tree (class-to-tree class)))
854 (let lp ((tree tree) (r '()))
855 (if tree
856 (let ((x (tree-ref tree))
857 (n (nxt tree)))
858 (if (find-tree x n)
859 (lp n r)
860 (lp n (cons x r))))
861 (reverse r))))