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