cashing of attribute reference and setting
[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>) ref)
37 (define-class <pyf> (<pf>) ref)
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* ((g (mrefx- xx '__fget__ '(#t)))
177 (f (if g
178 (if (eq? g #t)
179 (aif it (mrefx- xx '__getattribute__ '())
180 (begin
181 (set xx '__fget__ it)
182 it)
183 (begin
184 (set xx '__fget__ it)
185 #f))
186 g)
187 #f)))
188 (if (or (not f) (eq? f not-implemented))
189 (mrefx- xx key l)
190 (apply f xx key l))))))
191
192 (define-syntax-rule (mrefx-py x key l)
193 (let ((xx x))
194 (prop-ref
195 xx
196 (let* ((g (mrefx xx '__fget__ '(#t)))
197 (f (if g
198 (if (eq? g #t)
199 (aif it (mrefx xx '__getattribute__ '())
200 (begin
201 (set xx '__fget__ it)
202 it)
203 (begin
204 (set xx '__fget__ it)
205 #f))
206 g)
207 #f)))
208 (if (or (not f) (eq? f not-implemented))
209 (mrefx xx key l)
210 (apply f xx key l))))))
211
212 (define-syntax-rule (unx mrefx- mref-)
213 (define-syntax-rule (mref- x key l)
214 (let ((xx x))
215 (let ((res (mrefx- xx key l)))
216 (if (and (not (struct? res)) (procedure? res))
217 (res xx)
218 res)))))
219
220 (unx mrefx- mref-)
221 (unx mrefx mref)
222 (unx mrefx-py mref-py)
223 (unx mrefx-py- mref-py-)
224
225 (define-syntax-rule (unx mrefx- mref-)
226 (define-syntax-rule (mref- x key l)
227 (let ((xx x))
228 (let ((res (mrefx- xx key l)))
229 (if (and (not (struct? res))
230 (not (pyclass? res))
231 (procedure? res))
232 (res xx)
233 res)))))
234
235 (unx mrefx- mref-q)
236 (unx mrefx mrefq)
237 (unx mrefx-py mref-pyq)
238 (unx mrefx-py- mref-py-q)
239
240 (define-method (ref (x <pf> ) key . l) (mref x key l))
241 (define-method (ref (x <p> ) key . l) (mref- x key l))
242 (define-method (ref (x <pyf>) key . l) (mref-py x key l))
243 (define-method (ref (x <py> ) key . l) (mref-py- x key l))
244
245 (define-method (refq (x <pf> ) key . l) (mrefq x key l))
246 (define-method (refq (x <p> ) key . l) (mref-q x key l))
247 (define-method (refq (x <pyf>) key . l) (mref-pyq x key l))
248 (define-method (refq (x <py> ) key . l) (mref-py-q x key l))
249
250 ;; the reshape function that will create a fresh new pf object with less size
251 ;; this is an expensive operation and will only be done when we now there is
252 ;; a lot to gain essentially tho complexity is as in the number of set
253 (define (reshape x)
254 (let ((h (slot-ref x 'h))
255 (m (make-hash-table))
256 (n 0))
257 (define h2 (vhash-fold (lambda (k v s)
258 (if (hash-ref m k #f)
259 s
260 (begin
261 (hash-set! m k #t)
262 (set! n (+ n 1))
263 (vhash-consq k v s))))
264 vlist-null
265 h))
266 (slot-set! x 'h h2)
267 (slot-set! x 'size n)
268 (slot-set! x 'n n)
269 (values)))
270
271 ;; on object x add a binding that key -> val
272 (define-syntax-rule (mset x key val)
273 (let ((h (slot-ref x 'h))
274 (s (slot-ref x 'size))
275 (n (slot-ref x 'n)))
276 (slot-set! x 'size (+ 1 s))
277 (let ((r (vhash-assq key h)))
278 (when (not r)
279 (slot-set! x 'n (+ n 1)))
280 (slot-set! x 'h (vhash-consq key val h))
281 (when (> s (* 2 n))
282 (reshape x))
283 (values))))
284
285 (define-syntax-rule (mset-py x key val)
286 (let* ((g (mrefx x '__fset__ '(#t)))
287 (f (if g
288 (if (eq? g #t)
289 (let ((class (aif it (mref x '__class__ '())
290 it
291 x)))
292 (aif it (mrefx x '__setattr__ '())
293 (begin
294 (mset class '__fset__ it)
295 it)
296 (begin
297 (mset class '__fset__ it)
298 #f)))
299 g)
300 #f)))
301 (if (or (eq? f not-implemented) (not f))
302 (mset x key val)
303 (f key val))))
304
305 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
306
307 (define-syntax-rule (mset- x key val)
308 (begin
309 (hash-set! (slot-ref x 'h) key val)
310 (values)))
311
312 (define-syntax-rule (mset-py- x key val)
313 (let* ((h (slot-ref x 'h))
314 (v (hash-ref h key fail)))
315 (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x)))))
316 (let* ((g (mrefx- x '__fset__ '(#t)))
317 (f (if g
318 (if (eq? g #t)
319 (let ((class (aif it (mref- x '__class__ '())
320 it
321 x)))
322 (aif it (mrefx- x '__setattr__ '())
323 (begin
324 (mset- class '__fset__ it)
325 it)
326 (begin
327 (mset- class '__fset__ it)
328 #f)))
329 g)
330 #f)))
331 (if (or (eq? f not-implemented) (not f))
332 (mset- x key val)
333 (f key val)))
334 ((slot-ref v 'set) x val))))
335
336 (define-syntax-rule (mklam (mset a ...) val)
337 (if (and (procedure? val)
338 (not (pyclass? val))
339 (if (is-a? val <p>)
340 (ref val '__call__)
341 #t))
342 (if (procedure-property val 'py-special)
343 (mset a ... val)
344 (mset a ... (object-method val)))
345 (mset a ... val)))
346
347 (define-method (set (x <pf>) key val) (mklam (mset x key) val))
348 (define-method (set (x <p>) key val) (mklam (mset- x key) val))
349 (define-method (set (x <pyf>) key val) (mklam (mset-py x key) val))
350 (define-method (set (x <py>) key val) (mklam (mset-py- x key) val))
351
352 ;; mref will reference the value of the key in the object x, an extra default
353 ;; parameter will tell what the fail object is else #f if fail
354 ;; if there is no found binding in the object search the class and
355 ;; the super classes for a binding
356
357 ;; call a function as a value of key in x with the object otself as a first
358 ;; parameter, this is pythonic object semantics
359 (define-syntax-rule (mk-call mcall mref)
360 (define-syntax-rule (mcall x key l)
361 (apply (mref x key '()) l)))
362
363 (mk-call mcall mref)
364 (mk-call mcall- mref-)
365 (mk-call mcall-py mref-py)
366 (mk-call mcall-py- mref-py-)
367
368 (define-method (call (x <pf>) key . l) (mcall x key l))
369 (define-method (call (x <p>) key . l) (mcall- x key l))
370 (define-method (call (x <pyf>) key . l) (mcall-py x key l))
371 (define-method (call (x <py>) key . l) (mcall-py- x key l))
372
373
374 ;; make a copy of a pf object
375 (define-syntax-rule (mcopy x)
376 (let ((r (make-pyclass <pf>)))
377 (slot-set! r 'h (slot-ref x 'h))
378 (slot-set! r 'size (slot-ref x 'size))
379 (slot-set! r 'n (slot-ref x 'n))
380 r))
381
382 (define-syntax-rule (mcopy- x)
383 (let* ((r (make-p))
384 (h (slot-ref r 'h)))
385 (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
386 r))
387
388 (define-method (copy (x <pf>)) (mcopy x))
389 (define-method (copy (x <p> )) (mcopy- x))
390
391
392 ;; with will execute thunk and restor x to it's initial state after it has
393 ;; finished note that this is a cheap operatoin because we use a functional
394 ;; datastructure
395 (define-syntax-rule (mwith x thunk)
396 (let ((old (mcopy x)))
397 (let ((r (thunk)))
398 (slot-set! x 'h (slot-ref old 'h))
399 (slot-set! x 'size (slot-ref old 'size))
400 (slot-set! x 'n (slot-ref old 'n))
401 r)))
402
403 (define-syntax-rule (mwith- x thunk)
404 (let ((old (mcopy- x)))
405 (let ((r (thunk)))
406 (slot-set! x 'h (slot-ref old 'h))
407 r)))
408
409
410
411 ;; a functional set will return a new object with the added binding and keep
412 ;; x untouched
413 (define-method (fset (x <pf>) key val)
414 (let ((x (mcopy x)))
415 (mset x key val)
416 x))
417
418 (define-method (fset (x <p>) key val)
419 (let ((x (mcopy- x)))
420 (mset x key val)
421 x))
422
423 (define (fset-x obj l val)
424 (let lp ((obj obj) (l l) (r '()))
425 (match l
426 (()
427 (let lp ((v val) (r r))
428 (if (pair? r)
429 (lp (fset (caar r) (cdar r) v) (cdr r))
430 v)))
431 ((k . l)
432 (lp (ref obj k #f) l (cons (cons obj k) r))))))
433
434
435
436
437
438 ;; a functional call will keep x untouched and return (values fknval newx)
439 ;; e.g. we get both the value of the call and the new version of x with
440 ;; perhaps new bindings added
441 (define-method (fcall (x <pf>) key . l)
442 (let* ((y (mcopy x))
443 (r (mcall y key l)))
444 (if (eq? (slot-ref x 'h) (slot-ref y 'h))
445 (values r x)
446 (values r y))))
447
448 (define-method (fcall (x <p>) key . l)
449 (let ((x (mcopy x)))
450 (values (mcall- x key l)
451 x)))
452
453 ;; this shows how we can override addition in a pythonic way
454
455 ;; lets define get put pcall etc so that we can refer to an object like
456 ;; e.g. (put x.y.z 1) (pcall x.y 1)
457
458 (define-syntax-rule (cross x k f set)
459 (call-with-values (lambda () f)
460 (lambda (r y)
461 (if (eq? x y)
462 (values r x)
463 (values r (set x k y))))))
464
465 (define-syntax-rule (cross! x k f _) f)
466
467 (define-syntax mku
468 (syntax-rules ()
469 ((_ cross set setx f (key) (val ...))
470 (setx f key val ...))
471 ((_ cross set setx f (k . l) val)
472 (cross f k (mku cross set setx (ref f k) l val) set))))
473
474 (define-syntax-rule (mkk pset setx set cross)
475 (define-syntax pset
476 (lambda (x)
477 (syntax-case x ()
478 ((_ f val (... ...))
479 (let* ((to (lambda (x)
480 (datum->syntax #'f (string->symbol x))))
481 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
482 (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
483 (cdr l)))
484 (h (to (car l))))
485 #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
486
487 (mkk put fset fset cross)
488 (mkk put! set set cross!)
489 (mkk pcall! call fset cross!)
490 (mkk pcall fcall fset cross)
491 (mkk get ref fset cross!)
492
493 ;; it's good to have a null object so we don't need to construct it all the
494 ;; time because it is functional we can get away with this.
495 (define null (make-pf))
496
497 ;; append the bindings in x in front of y + some optimizations
498 (define (union x y)
499 (define hx (slot-ref x 'h))
500 (define hy (slot-ref y 'h))
501 (define n (slot-ref x 'n))
502 (define s (slot-ref x 'size))
503 (define m (make-hash-table))
504
505 (define h
506 (vhash-fold
507 (lambda (k v st)
508 (if (vhash-assq k hy)
509 (begin
510 (set! s (+ s 1))
511 (vhash-consq k v st))
512 (if (hash-ref m k)
513 s
514 (begin
515 (set! n (+ n 1))
516 (set! s (+ s 1))
517 (hash-set! m k #t)
518 (vhash-consq k v st)))))
519 hy
520 hx))
521
522 (define out (make-pyclass <pf>))
523 (slot-set! out 'h h)
524 (slot-set! out 'n n)
525 (slot-set! out 'size s)
526 out)
527
528 (define (union- class x y)
529 (define hx (slot-ref x 'h))
530 (define hy (slot-ref y 'h))
531 (define out (make-p class))
532 (define h (slot-ref out 'h))
533 (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
534 (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
535 out)
536
537
538 ;; make a class. A class add some meta information to allow for multiple
539 ;; inherritance and add effectively static data to the object the functional
540 ;; datastructure show it's effeciency now const is data that will not change
541 ;; and bindings that are added to all objects. Dynamic is the mutating class
542 ;; information. supers is a list of priorities
543 (define-syntax-rule (mk-pf make-pf-class <pf>)
544 (define-syntax make-pf-class
545 (lambda (x)
546 (syntax-case x ()
547 ((_ name const dynamic (supers (... ...)))
548 (with-syntax (((sups (... ...)) (generate-temporaries
549 #'(supers (... ...)))))
550 #'(let ((sups supers) (... ...))
551 (define name (make-class (list sups (... ...) <pf>) '()))
552 (define class (dynamic name))
553 (define __const__
554 (union const
555 (let lp ((sup (filter-parents
556 (list sups (... ...)))))
557 (if (pair? sup)
558 (union (ref (car sup) '__const__ null)
559 (lp (cdr sup)))
560 null))))
561
562 (reshape __const__)
563 (set class '__class__ #f)
564 (set class '__fget__ #t)
565 (set class '__fset__ #t)
566 (set class '__const__ __const__)
567 (set class '__goops__ name)
568 (set class '__name__ 'name)
569 (set class '__parents__ (filter-parents
570 (list sups (... ...))))
571 (set class '__mro__ (get-mro class))
572 (set class '__goops__ name)
573 (set __const__ '__name__ 'name)
574 (set __const__ '__goops__ class)
575 (set __const__ '__parents__ (filter-parents
576 (list sups (... ...))))
577 (set __const__ '__goops__ name)
578
579 class)))))))
580
581 (mk-pf make-pf-class <pf>)
582 (mk-pf make-pyf-class <pyf>)
583
584 (define (filter-parents l)
585 (let lp ((l l))
586 (if (pair? l)
587 (if (is-a? (car l) <p>)
588 (cons (car l) (lp (cdr l)))
589 (lp (cdr l)))
590 '())))
591
592 (define-syntax-rule (mk-p make-p-class <p>)
593 (define-syntax make-p-class
594 (lambda (x)
595 (syntax-case x ()
596 ((_ name const dynamic (supers (... ...)))
597 (with-syntax (((sups (... ...)) (generate-temporaries
598 #'(supers (... ...)))))
599 #'(let ((sups supers) (... ...))
600 (define name (make-class (list
601 (if (is-a? sups <p>)
602 (aif it (ref sups '__goops__ #f)
603 it
604 sups)
605 sups)
606 (... ...) <p>) '()))
607
608 (define class (dynamic <p>))
609 (set class '__class__ #f)
610 (set class '__fget__ #t)
611 (set class '__fset__ #t)
612 (set class '__name__ 'name)
613 (set class '__goops__ name)
614 (set class '__parents__ (filter-parents (list sups (... ...))))
615 (set class '__mro__ (get-mro class))
616 class)))))))
617
618 (mk-p make-p-class <p>)
619 (mk-p make-py-class <py>)
620
621 ;; Let's make an object essentially just move a reference
622
623 ;; the make class and defclass syntactic sugar
624 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
625 (define-syntax-rule (mk-pf-class name (parents (... ...))
626 #:const
627 ((sdef mname sval) (... ...))
628 #:dynamic
629 ((ddef dname dval) (... ...)))
630 (let ()
631 (define name
632 (letruc ((mname sval) (... ...) (dname dval) (... ...))
633 (make-pf-class name
634 (let ((s (make-pf)))
635 (set s 'mname mname) (... ...)
636 s)
637 (lambda (class)
638 (let ((d (make-pf class)))
639 (set d 'dname dname) (... ...)
640 d))
641 (parents (... ...)))))
642 name)))
643
644 (mk-p/f make-pf mk-pf-class make-pf-class)
645 (mk-p/f make-p mk-p-class make-p-class)
646 (mk-p/f make-pf mk-pyf-class make-pyf-class)
647 (mk-p/f make-p mk-py-class make-py-class)
648
649 (define-syntax-rule (def-pf-class name . l)
650 (define name (mk-pf-class name . l)))
651
652 (define-syntax-rule (def-p-class name . l)
653 (define name (mk-p-class name . l)))
654
655 (define-syntax-rule (def-pyf-class name . l)
656 (define name (mk-pyf-class name . l)))
657
658 (define-syntax-rule (def-py-class name . l)
659 (define name (mk-py-class name . l)))
660
661 (define (get-class o)
662 (cond
663 ((is-a? o <p>)
664 o)
665 (else
666 (error "not a pyclass"))))
667
668 (define (get-type o)
669 (cond
670 ((is-a? o <pyf>)
671 'pyf)
672 ((is-a? o <py>)
673 'py)
674 ((is-a? o <pf>)
675 'pf)
676 ((is-a? o <p>)
677 'p)
678 (else
679 'none)))
680
681 (define (print o l)
682 (define p1 (if (pyclass? o) "C" "O"))
683 (define p2 (if (pyclass? o) "C" "O"))
684 (define port (if (pair? l) (car l) #t))
685 (format port "~a"
686 (aif it (if (pyclass? o) #f (ref o '__repr__ #f))
687 (format
688 #f "~a(~a)<~a>" p1 (get-type o) (it))
689 (format
690 #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
691
692 (define-method (write (o <p>) . l) (print o l))
693 (define-method (display (o <p>) . l) (print o l))
694
695 (define-syntax-rule (define-python-class name parents code ...)
696 (define name
697 (mk-py-class name parents
698 #:const
699 ()
700 #:dynamic
701 (code ...))))
702
703 (define (pyclass? x)
704 (and (is-a? x <p>)
705 (if (ref x '__class__)
706 #f
707 (if (ref x '__super__)
708 'super
709 #t))))
710
711 (define-method (py-class (o <p>))
712 (ref o '__class__ 'type))
713
714 (define (mark-fkn tag f)
715 (set-procedure-property! f 'py-special tag)
716 f)
717
718 (define (object-method f)
719 (letrec ((self
720 (mark-fkn 'object
721 (lambda (x)
722 (aif it (pyclass? x)
723 (if (eq? it 'super)
724 self
725 f)
726 (lambda z (apply f x z)))))))
727 self))
728
729 (define (class-method f)
730 (letrec ((self
731 (mark-fkn 'class
732 (lambda (x)
733 (aif it (pyclass? x)
734 (if (eq? it 'super)
735 self
736 (lambda z (apply f x z)))
737 (lambda z (apply f (ref x '__class__) z)))))))
738 self))
739
740 (define (static-method f)
741 (letrec ((self
742 (mark-fkn 'static
743 (lambda (x)
744 (if (eq? (pyclass? x) 'super)
745 self
746 f)))))
747 self))
748
749
750 (define-syntax-parameter
751 *class* (lambda (x) (error "*class* not parameterized")))
752 (define-syntax-parameter
753 *self* (lambda (x) (error "*class* not parameterized")))
754
755 (define *super* (list 'super))
756
757 (define (not-a-super) 'not-a-super)
758 (define (py-super class obj)
759 (define (make cl parents)
760 (let ((c (make-p))
761 (o (make-p)))
762 (set c '__super__ #t)
763 (set c '__mro__ parents)
764 (set c '__getattribute__ (lambda (self key . l)
765 (aif it (ref c key)
766 (if (procedure? it)
767 (if (eq? (procedure-property
768 it
769 'py-special)
770 'class)
771 (it cl)
772 (it obj))
773 it)
774 (error "no attribute"))))
775 (set o '__class__ c)
776 o))
777
778 (call-with-values
779 (lambda ()
780 (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
781 (if (pair? l)
782 (if (eq? class (car l))
783 (let ((r (cdr l)))
784 (if (pair? r)
785 (values (car r) r)
786 (values #f #f)))
787 (lp (cdr l)))
788 (values #f #f))))
789 make))
790
791
792
793 (define-syntax py-super-mac
794 (syntax-rules ()
795 ((_)
796 (py-super *class* *self*))
797 ((_ class self)
798 (py-super class self))))
799
800 (define-syntax letruc
801 (lambda (x)
802 (syntax-case x ()
803 ((_ ((x v) ...) code ...)
804 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
805 (if (pair? a)
806 (let* ((x (car a))
807 (s (syntax->datum x)))
808 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
809 (r (list (car b))))
810 (if (pair? a2)
811 (if (eq? (syntax->datum a2) s)
812 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
813 (lp2 (cdr a2) (cdr b2)
814 (cons (car a2) a3)
815 (cons (car b2) b3)
816 r))
817 (lp (reverse a3) (reverse b3)
818 (cons
819 (list x #`(let* #,(map (lambda (v) (list x v))
820 (reverse r)) #,x))
821 u)))))
822 #`(letrec #,(reverse u) code ...)))))))
823
824
825
826
827 (define-method (py-init (o <p>) . l)
828 (apply (ref o '__init__) l))
829
830 (define mk-tree
831 (case-lambda
832 ((root)
833 (vector root '()))
834 ((root hist) (vector root hist))))
835
836 (define (geth t) (vector-ref t 1))
837 (define (getr t) (vector-ref t 0))
838 (define (tree-ref t) (car (getr t)))
839
840 (define (nxt tree)
841 (define (dive r h)
842 (let ((x (car r)))
843 (if (pair? x)
844 (dive (car r) (cons (cdr r) h))
845 (mk-tree r h))))
846
847 (define (up r h)
848 (if (null? r)
849 (if (pair? h)
850 (up (car h) (cdr h))
851 #f)
852 (let ((x (car r)))
853 (if (pair? x)
854 (dive r h)
855 (mk-tree r h)))))
856
857 (let ((r (getr tree)) (h (geth tree)))
858 (cond
859 ((pair? r)
860 (let ((r (cdr r)))
861 (if (pair? r)
862 (let ((x (car r)))
863 (if (pair? x)
864 (dive x (cons (cdr r) h))
865 (mk-tree r h)))
866 (if (pair? h)
867 (up (car h) (cdr h))
868 #f))))
869 (else
870 (if (pair? h)
871 (up (car h) (cdr h))
872 #f)))))
873
874 (define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
875
876 (define (find-tree o tree)
877 (if tree
878 (let ((x (tree-ref tree)))
879 (if (eq? o x)
880 #t
881 (find-tree o (nxt tree))))
882 #f))
883
884 (define (get-mro class)
885 (define tree (mk-tree (class-to-tree class)))
886 (let lp ((tree tree) (r '()))
887 (if tree
888 (let ((x (tree-ref tree))
889 (n (nxt tree)))
890 (if (find-tree x n)
891 (lp n r)
892 (lp n (cons x r))))
893 (reverse r))))