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