remove warnings, reordering
[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 (system base message)
6 #:use-module (language python guilemod)
7 #:use-module (ice-9 pretty-print)
8 #:use-module (persist persistance)
9 #:replace (equal?)
10 #:export (set ref make-p <p> <py> <pf> <pyf> <property>
11 call with copy fset fcall put put! py-get
12 pcall pcall! get fset-x pyclass?
13 def-p-class mk-p-class make-p-class mk-p-class2
14 define-python-class define-python-class-noname
15 get-type py-class find-in-class
16 object-method class-method static-method
17 py-super-mac py-super py-equal?
18 *class* *self* pyobject? pytype?
19 type object pylist-set! pylist-ref tr
20 resolve-method-g rawref rawset rawdel py-dict
21 ref-class fastref fastset
22 ))
23
24 #|
25 Python object system is basically syntactic suger otop of a hashmap and one
26 this project is inspired by the python object system and what it measn when
27 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
28 with assocs or tree like functional hashmaps in stead.
29
30 The hashmap works like an assoc e.g. we will define new values by 'consing' a
31 new binding on the list and when the assoc take up too much space it will be
32 reshaped and all extra bindings will be removed.
33
34 The datastructure is functional but the objects mutate. So one need to
35 explicitly tell it to not update etc.
36 |#
37
38
39 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
40
41 ;; this is mutated by the dict class
42 (define dictNs '(dictNs))
43 (define dictRNs '(dictRNs))
44
45 (define prophash (make-hash-table))
46
47 (define (procedure-property- o key . l)
48 (define ret (if (pair? l) (car l) #f))
49 (aif props (hashq-ref prophash o)
50 (aif it (assq key props)
51 (cdr it)
52 ret)
53 ret))
54
55 (define (procedure-properties- o)
56 (define ret #f)
57 (aif props (hashq-ref prophash o)
58 props
59 ret))
60
61 (define (set-procedure-property!- o key v)
62 (hashq-set! prophash
63 o
64 (aif props (hashq-ref prophash o)
65 (cons (cons key v) props)
66 (list (cons key v)))))
67
68 (define (set-procedure-properties!- o l)
69 (hashq-set! prophash o l))
70
71 #;
72 (define (pkk . l)
73 (let* ((r (reverse l))
74 (x (reverse (cdr r)))
75 (z (car r)))
76 (apply pk x)
77 z))
78
79
80 (define (pkk . l)
81 (car (reverse l)))
82
83 (define (pk-obj o)
84 (pk 'start-pk-obj)
85 (let ((h (slot-ref o 'h)))
86 (hash-for-each (lambda (k v)
87 (if (member k '(__name__ __qualname__ __class__))
88 (pk k v)
89 (pk k))) h)
90
91 (pk 'finished-obj)
92
93 (let lp ((l (pk 'mro (rawref o '__mro__ '()))))
94 (if (pair? l)
95 (let ((cl (car l)))
96 (if (is-a? cl <p>)
97 (if (hash-table? (slot-ref cl 'h))
98 (hash-for-each (lambda (k v)
99 (if (member k '(__name__ __qualname__))
100 (pk k v)
101 (pk k)))
102 (slot-ref cl 'h))
103 (pk 'no-hash-table))
104 (pk 'no-class))
105 (lp (cdr l)))))
106
107 (pk 'end-pk-obj)))
108
109 (define fail (cons 'fail '()))
110
111 (define-syntax-rule (kif it p x y)
112 (let ((it p))
113 (if (eq? it fail)
114 y
115 x)))
116
117 (define-method (pylist-set! (o <hashtable>) key val)
118 (hash-set! o key val))
119
120 (define-method (pylist-ref (o <hashtable>) key)
121 (kif it (hash-ref o key fail)
122 it
123 (error "IndexError")))
124
125 (define-method (py-get x key . l)
126 (if (pair? l) (car l) #f))
127
128 (define-method (py-get (o <hashtable>) key . l)
129 (define -fail (if (pair? l) (car l) #f))
130 (kif it (hash-ref o key fail)
131 it
132 -fail))
133
134 (define (is-acl? a b) (member a (cons b (class-subclasses b))))
135
136 (define-class <p> (<applicable-struct> <object>) h)
137 (define-class <pf> (<p>) size n) ; the pf object consist of a functional
138 ; hashmap it's size and number of live
139 ; object
140 (define-class <py> (<p>))
141 (define-class <pyf> (<pf>))
142
143 (define-class <property> () get set del)
144
145 (name-object <p>)
146 (name-object <pf>)
147 (name-object <py>)
148 (name-object <pyf>)
149 (name-object <property>)
150
151 (define (fastref o k . e)
152 (define r (if (pair? e) (car e) #f))
153 (let ((h (slot-ref o 'h)))
154 (if (hash-table? h)
155 (hash-ref (slot-ref o 'h) k r)
156 (aif it (vhash-assoc k (slot-ref o 'h)) (cdr it) r))))
157
158 (define (fastset o k v)
159 (let ((h (slot-ref o 'h)))
160 (if (hash-table? h)
161 (hash-set! (slot-ref o 'h) k v)
162 (slot-set! o 'h
163 (vhash-cons k v (slot-ref o 'h))))))
164
165 (define-method (pylist-set! (o <p>) key val)
166 (aif it (ref o '__setitem__)
167 (it key val)
168 (next-method)))
169
170 (define-method (pylist-ref (o <p>) key)
171 (aif it (ref o '__getitem__)
172 (it key)
173 (next-method)))
174
175 (define-method (ref (o <procedure>) key . l)
176 (aif it (procedure-property- o key)
177 it
178 (if (pair? l)
179 (car l)
180 #f)))
181
182 (define-method (rawref (o <procedure>) key . l)
183 (aif it (procedure-property- o key)
184 it
185 (if (pair? l)
186 (car l)
187 #f)))
188
189 (define-method (rawdel (o <procedure>) key)
190 (error "not implemented yet"))
191
192 (define-method (set (o <procedure>) key val)
193 (set-procedure-property!- o key val))
194
195 (define-method (rawset (o <procedure>) key val)
196 (set-procedure-property!- o key val))
197
198 (define-method (find-in-class x key fail) fail)
199 (define-method (find-in-class (klass <pf>) key fail)
200 (let ((r (vhash-assoc key (slot-ref klass 'h))))
201 (if r
202 (cdr r)
203 fail)))
204
205 (define inclass (make-fluid #f))
206 (define-method (find-in-class (klass <p>) key -fail)
207 (let ((h (slot-ref klass 'h)))
208 (aif dict (hash-ref h '__dict__)
209 (kif it (py-get dict key fail)
210 it
211 (kif it (py-get dict (symbol->string key) fail)
212 it
213 (hash-ref h key -fail)))
214 (hash-ref h key -fail))))
215
216 (define-method (find-in-class x key fail) fail)
217 (define-method (find-in-class-raw klass key fail) fail)
218
219 (define-method (find-in-class-raw (klass <pf>) key fail)
220 (let ((r (vhash-assoc key (slot-ref klass 'h))))
221 (if r
222 (cdr r)
223 fail)))
224
225 (define-method (find-in-class-raw (klass <p>) key -fail)
226 (let ((h (slot-ref klass 'h)))
227 (hash-ref h key -fail)))
228
229
230 (define-syntax-rule (find-in-class-and-parents klass key fail-)
231 (kif r (find-in-class klass key fail)
232 r
233 (aif parents (let ((x (find-in-class-raw klass '__mro__ #f)))
234 (if (null? x)
235 #f
236 x))
237 (let lp ((parents parents))
238 (if (pair? parents)
239 (kif r (find-in-class (car parents) key fail)
240 r
241 (lp (cdr parents)))
242 fail-))
243 fail-)))
244
245 (define-syntax-rule (find-in-class-and-parents-raw klass key fail-)
246 (aif parents (find-in-class-raw klass '__mro__ #f)
247 (let lp ((parents parents))
248 (if (pair? parents)
249 (kif r (find-in-class-raw (car parents) key fail)
250 r
251 (lp (cdr parents)))
252 fail-))
253 (kif r (find-in-class-raw klass key fail)
254 r
255 fail-)))
256
257 (define-inlinable (ficap klass key fail)
258 (find-in-class-and-parents klass key fail))
259
260 (define-inlinable (ficap-raw klass key fail)
261 (find-in-class-and-parents-raw klass key fail))
262
263 (define (mk-getter-object f)
264 (lambda (obj cls)
265 (if (pytype? obj)
266 f
267 (if (pyclass? obj)
268 (if (pytype? cls)
269 (lambda x (apply f obj x))
270 f)
271 (if (pyclass? cls)
272 (lambda x (apply f obj x))
273 f)))))
274
275 (define (mk-getter-class f)
276 (lambda (obj cls)
277 (lambda x (apply f cls x))))
278
279 (define (class-method f)
280 (set f '__get__ (mk-getter-class f))
281 f)
282
283 (define (object-method f)
284 (set f '__get__ (mk-getter-object f))
285 f)
286
287 (define (static-method f)
288 (set f '__get__ #f)
289 f)
290
291
292 (define (resolve-method-g g pattern)
293 (define (mmatch p pp)
294 (if (eq? pp '_)
295 '()
296 (match (cons p pp)
297 (((p . ps) . (pp . pps))
298 (if (eq? pp '_)
299 (mmatch ps pps)
300 (if (or (eq? p pp) (is-a? p pp))
301 (cons p (mmatch ps pps))
302 #f)))
303 ((() . ())
304 '())
305 (_
306 #f))))
307
308 (define (q< x y)
309 (let lp ((x x) (y y))
310 (match (cons x y)
311 (((x . xs) . (y . ys))
312 (and (is-a? x y)
313 (lp xs ys)))
314 (_ #t))))
315
316 (let ((l
317 (let lp ((ms (generic-function-methods g)))
318 (if (pair? ms)
319 (let* ((m (car ms))
320 (p (method-specializers m))
321 (f (method-procedure m)))
322 (aif it (mmatch p pattern)
323 (cons (cons it f) (lp (cdr ms)))
324 (lp (cdr ms))))
325 '()))))
326
327
328 (cdr (car (sort l q<)))))
329
330 (define (resolve-method-o o pattern)
331 (resolve-method-g (class-of o) pattern))
332
333 (define (hashforeach a b) (values))
334
335 (define (add-default c l)
336 (if (pair? l)
337 (let ((l (let ((y (car l))) (if (eq? y c) l (cons c l)))))
338 (let* ((r (reverse l))
339 (x (car r)))
340 (if x
341 (if (or (not type) (pytype? x))
342 (if (or (not type) (eq? x type))
343 l
344 (reverse (cons type r)))
345 (if (or (not object) (eq? x object))
346 l
347 (reverse (cons object r))))
348 l)))
349 (if object
350 (if (pytype? c)
351 (list c type)
352 (list c object))
353 (cons c l))))
354
355 (define hash-for-each* hash-for-each)
356
357 (define (kw->class kw meta)
358 (if (memq #:functional kw)
359 (if (memq #:fast kw)
360 <pf>
361 (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
362 <pyf>
363 <pf>))
364 (if (memq #:fast kw)
365 (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
366 <pf>
367 <p>)
368 (cond
369 ((is-a? meta <pyf>)
370 <pyf>)
371 ((is-a? meta <py>)
372 <py>)
373 ((is-a? meta <pf>)
374 <pf>)
375 ((is-a? meta <p>)
376 <p>)
377 (else
378 <py>)))))
379
380 (define (project-goopses supers)
381 (map (lambda (sups)
382 (aif it (find-in-class sups '__goops__ #f)
383 it
384 sups))
385 supers))
386
387 (define (filter-parents l)
388 (let lp ((l l))
389 (if (pair? l)
390 (if (is-a? (car l) <p>)
391 (cons (car l) (lp (cdr l)))
392 (lp (cdr l)))
393 '())))
394
395 (define (get-goops meta name parents kw)
396 (define (unique l)
397 (define t (make-hash-table))
398 (let lp ((l l))
399 (if (pair? l)
400 (let ((c (car l)))
401 (if (hashq-ref t c)
402 (lp (cdr l))
403 (begin
404 (hashq-set! t c #t)
405 (cons c (lp (cdr l))))))
406 '())))
407
408 (make-class
409 (unique
410 (append
411 (project-goopses parents)
412 (list (kw->class kw meta)))) '() #:name name))
413
414 (define (get-cparents supers)
415 (let ((parents (filter-parents supers)))
416 (if (null? parents)
417 (if object
418 (list object)
419 '())
420 parents)))
421
422 (define (get-mros supers)
423 (get-mro (get-cparents supers)))
424
425 (define (Module x . l) (reverse x))
426
427 (define (add-specials pylist-set! dict name goops supers meta doc)
428 (define (make-module)
429 (let ((l (module-name (current-module))))
430 (if (and (>= (length l) 3)
431 (equal? (list-ref l 0) 'language)
432 (equal? (list-ref l 1) 'python)
433 (equal? (list-ref l 2) 'module))
434 (Module (reverse l) (reverse (cdddr l)))
435 l)))
436
437 (define parents (filter-parents supers))
438 (define cparents (get-cparents supers))
439
440 (define (filt-bases x)
441 (let lp ((x x))
442 (if (pair? x)
443 (let ((y (car x)))
444 (if (is-a? y <p>)
445 (cons y (lp (cdr x)))
446 (lp (cdr x))))
447 '())))
448
449 (pylist-set! dict '__goops__ goops)
450 (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
451 (pylist-set! dict '__module__ (make-module))
452 (pylist-set! dict '__bases__ (filt-bases parents))
453 (pylist-set! dict '__name__ name)
454 (pylist-set! dict '__qualname__ name)
455 (pylist-set! dict '__mro__ (get-mro cparents))
456 (if doc (pylist-set! dict '__doc__ doc))
457 (pylist-set! dict '__class__ meta))
458
459 (define (new-class0 meta name parents dict . kw)
460 (set! name (if (symbol? name) name (string->symbol name)))
461 (let* ((raw? #f)
462 (goops (catch #t
463 (lambda () (pylist-ref dict '__goops__))
464 (lambda x
465 (set! raw? #t)
466 (get-goops meta name parents kw))))
467 (p (kwclass->class kw meta))
468 (class (make-p p)))
469
470 (slot-set! class 'procedure
471 (lambda x
472 (create-object class x)))
473
474 (when class
475 (let lp ((mro (catch #t
476 (lambda () (pylist-ref dict '__mro__))
477 (lambda x (get-mros parents)))))
478
479 (if (pair? mro)
480 (let ((p (car mro)))
481 (aif it (find-in-class p '__zub_classes__ #f)
482 (hash-set! it class #t)
483 #f)
484
485 (aif it (find-in-class p '__init_subclass__ #f)
486 (apply it class p #f kw)
487 #f)
488
489 (lp (cdr mro)))))
490
491 (hash-for-each*
492 (lambda (k v)
493 (let ((k (if (string? k) (string->symbol k) k)))
494 (rawset class k v)))
495 dict)
496
497 (if raw?
498 (begin
499 (add-specials rawset class name goops parents meta
500 (catch #t
501 (lambda () (pylist-ref kw "doc"))
502 (lambda x #f)))
503 (set (rawref class '__module__)
504 (if (string? name) (string->symbol name) name)
505 class))
506 (rawset class '__goops__ goops))
507
508 (let ((mro (add-default class
509 (catch #t
510 (lambda () (pylist-ref dict '__mro__))
511 (lambda x (get-mros parents))))))
512 (rawset class '__mro__ mro))
513
514 (catch #t
515 (lambda ()
516 (if (not (ficap-raw class '__getattribute__ #f))
517 (rawset class '__getattribute__ attr)))
518 (lambda x
519 (rawset class '__getattribute__ attr))))
520
521 class))
522
523 (define (new-class meta name parents dict kw)
524 (aif it (and meta (ficap meta '__new__ #f))
525 (apply it meta name parents dict kw)
526 (apply new-class0 meta name parents dict kw)))
527
528 (define (type- meta name parents dict keys)
529 (let ((class (new-class meta name parents dict keys)))
530 (aif it (and meta (find-in-class-and-parents meta '__init__ #f))
531 (it class name parents dict keys)
532 #f)
533
534 class))
535
536
537 (define (the-create-object class x)
538 (let* ((meta (and class (find-in-class-raw class '__class__ #f)))
539 (goops (find-in-class class '__goops__ #f))
540 (obj (aif it (ficap class '__new__ #f)
541 (apply it class x)
542 (make-object class meta goops))))
543
544 (when (struct? obj)
545 (aif it (ficap class '__init__ #f)
546 (apply it obj x)
547 #f)
548
549 (slot-set! obj 'procedure
550 (lambda x
551 (aif it (ref obj '__call__)
552 (apply it x)
553 (error "not a callable object")))))
554
555 obj))
556
557 (define (create-object class x)
558 (if (pytype? class)
559 (apply type-call class x)
560 (let ((meta (and class (find-in-class-raw class '__class__ #f))))
561 (with-fluids ((*make-class* #t))
562 (aif it (ficap meta '__call__ #f)
563 (apply it class x)
564 (the-create-object class x))))))
565
566 ;; This are finished in the _python.scm module
567 (define int-cls #f)
568 (define int? #f)
569 (define tuple-cls #f)
570 (define tuple? #f)
571 (define string-cls #f)
572 (define str? #f)
573 (define bytes-cls #f)
574 (define bytes? #f)
575 (define list-cls #f)
576 (define list? #f)
577 (define float-cls #f)
578 (define float? #f)
579
580 (define (check-obj obj)
581 (cond
582 ((int? obj) int-cls)
583 ((tuple? obj) tuple-cls)
584 ((float? obj) float-cls)
585 ((str? obj) string-cls)
586 ((list? obj) list-cls)
587 ((bytes? obj) bytes-cls)
588 (else
589 object)))
590
591 (define type-call
592 (lambda (class . l)
593 (if (pytype? class)
594 (apply (case-lambda
595 ((meta obj)
596 (catch #t
597 (lambda ()
598 (aif it (find-in-class-raw obj '__class__ #f)
599 it
600 (check-obj obj)))
601 (lambda x
602 (warn x)
603 (check-obj obj))))
604
605 ((meta name bases dict . keys)
606 (type- meta name bases dict keys)))
607 class l)
608 (the-create-object class l))))
609
610 (define (get-dict self name parents)
611 (aif it (and self (ficap self '__prepare__ #f))
612 (dictNs (it self name parents))
613 (make-hash-table)))
614
615 (define (create-class meta name parents gen-methods keys)
616 (let ((dict (gen-methods (get-dict meta name parents))))
617 (aif it (and meta (find-in-class-raw meta '__class__ #f))
618 (aif it (ficap-raw it '__call__ #f)
619 (apply it meta name parents dict keys)
620 (type- meta name parents dict keys))
621 (type- meta name parents dict keys))))
622
623 (define (make-object class meta goops)
624 (let ((obj (make-p goops)))
625 (rawset obj '__class__ class)
626 obj))
627
628 ;; Make an empty pf object
629 (define (make-p <x>)
630 (let ((r (make <x>)))
631 (cond
632 ((is-a? r <pf>)
633 (slot-set! r 'h vlist-null)
634 (slot-set! r 'size 0)
635 (slot-set! r 'n 0))
636 ((is-a? r <p>)
637 (slot-set! r 'h (make-hash-table)))
638 (else
639 (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
640 r)))
641 r))
642
643
644 (define-syntax-rule (hif it (k h) x y)
645 (let ((a (vhash-assq k h)))
646 (if (pair? a)
647 (let ((it (cdr a)))
648 x)
649 y)))
650
651 (define-syntax-rule (cif (it h) (k cl) x y)
652 (let* ((h (slot-ref cl 'h))
653 (a (vhash-assq k h)))
654 (if (pair? a)
655 (let ((it (cdr a)))
656 x)
657 y)))
658
659 (define-inlinable (gox obj it)
660 (let ((class (fluid-ref *location*)))
661 (aif f (rawref it '__get__)
662 (f obj class)
663 it)))
664
665 (define-inlinable (gokx obj class it)
666 (aif f (rawref it '__get__)
667 (f obj class)
668 it))
669
670 (define *location* (make-fluid #f))
671 (define-syntax-rule (mrefx x key l)
672 (let ()
673 (define (end)
674 (if (null? l)
675 #f
676 (car l)))
677
678 (define (parents li)
679 (let lp ((li li))
680 (if (pair? li)
681 (let ((p (car li)))
682 (cif (it h) (key p)
683 (begin (fluid-set! *location* p) it)
684 (lp (cdr li))))
685 fail)))
686
687 (cif (it h) (key x)
688 (begin (fluid-set! *location* x) it)
689 (hif cl ('__class__ h)
690 (cif (it h) (key cl)
691 (begin (fluid-set! *location* cl) it)
692 (hif p ('__mro__ h)
693 (let ((r (parents p)))
694 (if (eq? r fail)
695 (end)
696 r))
697 (end)))
698 (end)))))
699
700 (define-syntax-rule (mrefx klass key l)
701 (let ()
702 (define (end) (if (pair? l) (car l) #f))
703 (fluid-set! *location* klass)
704 (kif it (find-in-class-and-parents klass key fail)
705 it
706 (aif klass (and klass (find-in-class-raw klass '__class__ #f))
707 (begin
708 (fluid-set! *location* klass)
709 (kif it (find-in-class-and-parents klass key fail)
710 it
711 (end)))
712 (end)))))
713
714 (define not-implemented (cons 'not 'implemeneted))
715
716 (define (mrefx-py x key l)
717 (let ((xx x))
718 (define (exit) (if (pair? l) (car l) #f))
719 (aif class (find-in-class-raw xx '__class__ #f)
720 (aif f (ficap-raw class '__getattribute__ #f)
721 (kif it (if (eq? f __getattribute__)
722 (f xx key)
723 (catch #t
724 (lambda ()
725 (f xx (symbol->string key)))
726 (lambda q fail)))
727
728 it
729 (exit))
730 (kif it (__getattribute__ xx key)
731 it
732 (exit)))
733 #f)))
734
735 (define-syntax-rule (mref x key l)
736 (let ((xx x))
737 (mrefx xx key l)))
738
739 (define-syntax-rule (mref-py x key l)
740 (let ((xx x))
741 (let ((res (mrefx-py xx key l)))
742 res)))
743
744 (define-method (ref x key . l)
745 (cond
746 ((eq? x 'None)
747 (apply ref NoneObj key l))
748 ((pair? l)
749 (car l))
750 (else
751 #f)))
752
753 (define-syntax-rule (mox o x)
754 (if (and (procedure? x) (not (is-a? x <p>)))
755 (aif it (procedure-property- x '__get__)
756 (it x o (fluid-ref *location*))
757 x)))
758
759 (define-method (ref (x <pf> ) key . l) (mox x (mref x key l)))
760 (define-method (ref (x <p> ) key . l) (mox x (mref x key l)))
761 (define-method (ref (x <pyf>) key . l) (mref-py x key l))
762 (define-method (ref (x <py> ) key . l) (mref-py x key l))
763
764 (define-method (rawref x key . l) (if (pair? l) (car l) #f))
765 (define-method (rawref (x <pf> ) key . l) (mref x key l))
766 (define-method (rawref (x <p> ) key . l) (mref x key l))
767
768 (define-method (rawdel (x <p> ) key)
769 (hash-remove! (slot-ref x 'h)
770 (if (symbol? key)
771 key
772 (string->symbol key))))
773
774 (define-method (set (f <procedure>) key val)
775 (set-procedure-property!- f key val))
776
777 (define-method (ref (f <procedure>) key . l)
778 (aif it (assoc key (procedure-properties- f))
779 (cdr it)
780 (if (pair? l) (car l) #f)))
781
782
783 ;; the reshape function that will create a fresh new pf object with less size
784 ;; this is an expensive operation and will only be done when we now there is
785 ;; a lot to gain essentially tho complexity is as in the number of set
786 (define (reshape x)
787 (let ((h (slot-ref x 'h))
788 (m (make-hash-table))
789 (n 0))
790 (define h2 (vhash-fold (lambda (k v s)
791 (if (hash-ref m k #f)
792 s
793 (begin
794 (hash-set! m k #t)
795 (set! n (+ n 1))
796 (vhash-consq k v s))))
797 vlist-null
798 h))
799 (slot-set! x 'h h2)
800 (slot-set! x 'size n)
801 (slot-set! x 'n n)
802 (values)))
803
804 ;; on object x add a binding that key -> val
805 (define-method (mset (x <pf>) key val)
806 (let ((h (slot-ref x 'h))
807 (s (slot-ref x 'size))
808 (n (slot-ref x 'n)))
809 (slot-set! x 'size (+ 1 s))
810 (let ((r (vhash-assoc key h)))
811 (when (not r)
812 (slot-set! x 'n (+ n 1)))
813 (slot-set! x 'h (vhash-cons key val h))
814 (when (> s (* 2 n))
815 (reshape x))
816 (values))))
817
818 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
819
820 (define-method (mset (x <p>) key val)
821 (begin
822 (hash-set! (slot-ref x 'h) key val)
823 (values)))
824
825 (define *make-class* (make-fluid #f))
826 (define (mc?) (not (fluid-ref *make-class*)))
827
828 (define __setattr__
829 (lambda (self key1 val)
830 (define key (if (string? key1) (string->symbol key1) key1))
831 (let ((h (aif dict (rawref self '__dict__)
832 dict
833 (slot-ref self 'h))))
834 (kif desc (py-get h key fail)
835 (aif it (rawref desc '__set__ #f)
836 (it self val)
837 (pylist-set! h key val))
838 (pylist-set! h key val)))))
839
840 (define (mset-py x key val)
841 (let* ((xx x))
842 (aif class (find-in-class-raw xx '__class__ #f)
843 (aif f (find-in-class-and-parents-raw class '__setattr__ #f)
844 (if (eq? f __setattr__)
845 (f xx key val)
846 (f xx (symbol->string key) val))
847 (__setattr__ xx key val))
848 (mset xx key val))))
849
850 (define-syntax-rule (mklam (mset a ...) val)
851 (mset a ... val))
852
853 (define-method (set (x <pf>) key val) (mklam (mset x key) val))
854 (define-method (set (x <p>) key val) (mklam (mset x key) val))
855 (define-method (set (x <pyf>) key val) (mklam (mset-py x key) val))
856 (define-method (set (x <py>) key val) (mklam (mset-py x key) val))
857
858 (define-method (rawset (x <pf>) key val) (mklam (mset x key) val))
859 (define-method (rawset (x <p>) key val) (mklam (mset x key) val))
860
861 ;; mref will reference the value of the key in the object x, an extra default
862 ;; parameter will tell what the fail object is else #f if fail
863 ;; if there is no found binding in the object search the class and
864 ;; the super classes for a binding
865
866 ;; call a function as a value of key in x with the object otself as a first
867 ;; parameter, this is pythonic object semantics
868 (define-syntax-rule (mk-call mcall mref)
869 (define-syntax-rule (mcall x key l)
870 (apply (mref x key '()) l)))
871
872 (mk-call mcall mref)
873 (mk-call mcall-py mref-py)
874
875 (define-method (call (x <pf>) key . l) (mcall x key l))
876 (define-method (call (x <p>) key . l) (mcall x key l))
877 (define-method (call (x <pyf>) key . l) (mcall-py x key l))
878 (define-method (call (x <py>) key . l) (mcall-py x key l))
879
880
881 ;; make a copy of a pf object
882 (define-syntax-rule (mcopy x)
883 (let ((r (make-p (ref x '__goops__))))
884 (slot-set! r 'h (slot-ref x 'h))
885 (slot-set! r 'size (slot-ref x 'size))
886 (slot-set! r 'n (slot-ref x 'n))
887 r))
888
889 (define-syntax-rule (mcopy- x)
890 (let* ((r (make-p (ref x '__goops__)))
891 (h (slot-ref r 'h)))
892 (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
893 r))
894
895 (define-method (copy (x <pf>)) (mcopy x))
896 (define-method (copy (x <p> )) (mcopy- x))
897
898 ;; make a copy of a pf object
899 (define-syntax-rule (mtr r x)
900 (begin
901 (slot-set! r 'h (slot-ref x 'h ))
902 (slot-set! r 'size (slot-ref x 'size))
903 (slot-set! r 'n (slot-ref x 'n ))
904 (values)))
905
906 (define-syntax-rule (mtr- r x)
907 (begin
908 (slot-set! r 'h (slot-ref x 'h))
909 (values)))
910
911
912 (define-method (tr (r <pf>) (x <pf>)) (mtr r x))
913 (define-method (tr (r <p> ) (x <p> )) (mtr- r x))
914
915
916 ;; with will execute thunk and restor x to it's initial state after it has
917 ;; finished note that this is a cheap operatoin because we use a functional
918 ;; datastructure
919 (define-syntax-rule (mwith x thunk)
920 (let ((old (mcopy x)))
921 (let ((r (thunk)))
922 (slot-set! x 'h (slot-ref old 'h))
923 (slot-set! x 'size (slot-ref old 'size))
924 (slot-set! x 'n (slot-ref old 'n))
925 r)))
926
927 (define-syntax-rule (mwith- x thunk)
928 (let ((old (mcopy- x)))
929 (let ((r (thunk)))
930 (slot-set! x 'h (slot-ref old 'h))
931 r)))
932
933
934
935 ;; a functional set will return a new object with the added binding and keep
936 ;; x untouched
937 (define-method (fset (x <pf>) key val)
938 (let ((x (mcopy x)))
939 (mset x key val val)
940 x))
941
942 (define-method (fset (x <p>) key val)
943 (let ((x (mcopy- x)))
944 (mset x key val val)
945 x))
946
947 (define (fset-x obj l val)
948 (let lp ((obj obj) (l l) (r '()))
949 (match l
950 (()
951 (let lp ((v val) (r r))
952 (if (pair? r)
953 (lp (fset (caar r) (cdar r) v) (cdr r))
954 v)))
955 ((k . l)
956 (lp (ref obj k #f) l (cons (cons obj k) r))))))
957
958
959
960
961
962 ;; a functional call will keep x untouched and return (values fknval newx)
963 ;; e.g. we get both the value of the call and the new version of x with
964 ;; perhaps new bindings added
965 (define-method (fcall (x <pf>) key . l)
966 (let* ((y (mcopy x))
967 (r (mcall y key l)))
968 (if (eq? (slot-ref x 'h) (slot-ref y 'h))
969 (values r x)
970 (values r y))))
971
972 (define-method (fcall (x <p>) key . l)
973 (let ((x (mcopy x)))
974 (values (mcall x key l)
975 x)))
976
977 ;; this shows how we can override addition in a pythonic way
978
979 ;; lets define get put pcall etc so that we can refer to an object like
980 ;; e.g. (put x.y.z 1) (pcall x.y 1)
981
982 (define-syntax-rule (cross x k f set)
983 (call-with-values (lambda () f)
984 (lambda (r y)
985 (if (eq? x y)
986 (values r x)
987 (values r (set x k y))))))
988
989 (define-syntax-rule (cross! x k f _) f)
990
991 (define-syntax mku
992 (syntax-rules ()
993 ((_ cross set setx f (key) (val ...))
994 (setx f key val ...))
995 ((_ cross set setx f (k . l) val)
996 (cross f k (mku cross set setx (ref f k) l val) set))))
997
998 (define-syntax-rule (mkk pset setx set cross)
999 (define-syntax pset
1000 (lambda (x)
1001 (syntax-case x ()
1002 ((_ f val (... ...))
1003 (let* ((to (lambda (x)
1004 (datum->syntax #'f (string->symbol x))))
1005 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
1006 (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
1007 (cdr l)))
1008 (h (to (car l))))
1009 #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
1010
1011 (mkk put fset fset cross)
1012 (mkk put! set set cross!)
1013 (mkk pcall! call fset cross!)
1014 (mkk pcall fcall fset cross)
1015 (mkk get ref fset cross!)
1016
1017 ;; it's good to have a null object so we don't need to construct it all the
1018 ;; time because it is functional we can get away with this.
1019 (define null (make-p <pf>))
1020
1021 (define (defaulter d)
1022 (if d
1023 (aif it (ref d '__goops__)
1024 it
1025 (if (is-a? d <py>)
1026 <py>
1027 <p>))
1028 <py>))
1029
1030 (define (kwclass->class kw default)
1031 (if (memq #:functionalClass kw)
1032 (if (memq #:fastClass kw)
1033 <pf>
1034 (if (memq #:pyClass kw)
1035 <pyf>
1036 (if (or (is-a? default <py>) (is-a? default <pyf>))
1037 <pyf>
1038 <pf>)))
1039 (if (memq #:mutatingClass kw)
1040 (if (memq #:fastClass kw)
1041 <p>
1042 (if (memq #:pyClass kw)
1043 <py>
1044 (if (or (is-a? default <py>) (is-a? default <pyf>))
1045 <py>
1046 <p>)))
1047 (if (memq #:fastClass kw)
1048 (if (or (is-a? default <pf>) (is-a? default <pyf>))
1049 <pf>
1050 <p>)
1051 (if (memq #:pyClass kw)
1052 (if (or (is-a? default <pf>) (is-a? default <pyf>))
1053 <pyf>
1054 <py>)
1055 (defaulter default))))))
1056
1057 (define type #f)
1058 (define object #f)
1059
1060 (define make-p-class
1061 (case-lambda
1062 ((name supers.kw methods)
1063 (make-p-class name "" supers.kw methods))
1064 ((name doc supers.kw methods)
1065 (define s.kw supers.kw)
1066 (define kw (cdr s.kw))
1067 (define supers (car s.kw))
1068 (define parents (filter-parents supers))
1069 (define cparents (get-cparents supers))
1070 (define meta (aif it (memq #:metaclass kw)
1071 (cadr it)
1072 (if (null? cparents)
1073 type
1074 (let* ((p (car cparents))
1075 (m (rawref p '__class__))
1076 (mro (reverse (ref m '__mro__ '()))))
1077 (let lp ((l (cdr cparents)) (m m) (mro mro))
1078 (match l
1079 ((pp . l)
1080 (aif mm (rawref pp '__class__)
1081 (aif mmro (rawref mm '__mro__)
1082 (cond
1083 ((memq m mmro)
1084 (lp l mm mmro))
1085 ((memq mm mro)
1086 (lp l m mro))
1087 (error "TypeError for meta"))
1088 (lp l m mro))
1089 (lp l m mro)))
1090 (() m)))))))
1091
1092 (define goops (get-goops meta name supers kw))
1093
1094 (define (gen-methods dict)
1095 (methods dict)
1096 (add-specials pylist-set! dict name goops supers meta doc)
1097 dict)
1098
1099 (let ((cl (with-fluids ((*make-class* #t))
1100 (create-class meta name parents gen-methods kw))))
1101 (aif it (ref meta '__init_subclass__)
1102 (let lp ((ps cparents))
1103 (if (pair? ps)
1104 (let ((super (car ps)))
1105 (it cl super)
1106 (lp (cdr ps)))))
1107 #f)
1108 cl))))
1109
1110
1111
1112 ;; Let's make an object essentially just move a reference
1113
1114 ;; the make class and defclass syntactic sugar
1115
1116 (define-syntax make-up
1117 (syntax-rules (lambda case-lambda lambda* letrec letrec*)
1118 ((_ (lambda . l))
1119 (object-method (lambda . l)))
1120 ((_ (case-lambda . l))
1121 (object-method (case-lambda . l)))
1122 ((_ (lambda* . l))
1123 (object-method (lambda* . l)))
1124 ((_ (letrec . l))
1125 (object-method (letrec . l)))
1126 ((_ (letrec* . l))
1127 (object-method (letrec* . l)))
1128 ((_ x) x)))
1129
1130 (define-syntax mk-p-class
1131 (lambda (x)
1132 (syntax-case x ()
1133 ((_ name parents (ddef dname dval) ...)
1134 #'(mk-p-class name parents "" (ddef dname dval) ...))
1135 ((_ name parents doc (ddef dname dval) ...)
1136 (with-syntax (((ddname ...)
1137 (map (lambda (dn)
1138 (datum->syntax
1139 #'name
1140 (string->symbol
1141 (string-append
1142 (symbol->string
1143 (syntax->datum #'name))
1144 "-"
1145 (symbol->string
1146 (syntax->datum dn))))))
1147 #'(dname ...)))
1148 (nname (datum->syntax
1149 #'name
1150 (string->symbol
1151 (string-append
1152 (symbol->string
1153 (syntax->datum #'name))
1154 "-goops-class")))))
1155 (%add-to-warn-list (syntax->datum #'nname))
1156 (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
1157 #'(ddname ...))
1158 #'(let ()
1159 (define name
1160 (letruc ((dname (make-up dval)) ...)
1161 (let ((ret
1162 (make-p-class 'name doc
1163 parents
1164 (lambda (dict)
1165 (pylist-set! dict 'dname dname)
1166 ...
1167 (values)))))
1168 (begin
1169 (module-define! (current-module) 'ddname dname)
1170 (name-object ddname))
1171 ...
1172 ret)))
1173
1174 (module-define! (current-module) 'nname (rawref name '__goops__))
1175 (name-object nname)
1176 (name-object name)
1177 name))))))
1178
1179 (define-syntax mk-p-class2
1180 (lambda (x)
1181 (syntax-case x ()
1182 ((_ name parents ((ddef dname dval) ...) body)
1183 #'(mk-p-class2 name parents "" ((ddef dname dval) ...) body))
1184 ((_ name parents doc ((ddef dname dval) ...) body)
1185 (with-syntax (((ddname ...)
1186 (map (lambda (dn)
1187 (datum->syntax
1188 #'name
1189 (string->symbol
1190 (string-append
1191 (symbol->string
1192 (syntax->datum #'name))
1193 "-"
1194 (symbol->string
1195 (syntax->datum dn))))))
1196 #'(dname ...)))
1197 (nname (datum->syntax
1198 #'name
1199 (string->symbol
1200 (string-append
1201 (symbol->string
1202 (syntax->datum #'name))
1203 "-goops-class")))))
1204
1205 (%add-to-warn-list (syntax->datum #'nname))
1206 (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
1207 #'(ddname ...))
1208
1209 #'(let ()
1210 (define name
1211 (let ((pa parents))
1212 (letruc2 ((dname (make-up dval)) ...)
1213 body
1214 (let ((ret
1215 (make-p-class 'name doc
1216 pa
1217 (lambda (dict)
1218 (pylist-set! dict 'dname dname)
1219 ...
1220 dict))))
1221 (begin
1222 (module-define! (current-module) 'ddname dname)
1223 (name-object ddname))
1224 ...
1225 ret))))
1226 (module-define! (current-module) 'nname (rawref name '__goops__))
1227 (name-object nname)
1228 (name-object name)
1229 name))))))
1230
1231 (define-syntax mk-p-class-noname
1232 (lambda (x)
1233 (syntax-case x ()
1234 ((_ name parents (ddef dname dval) ...)
1235 #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
1236 ((_ name parents doc (ddef dname dval) ...)
1237 #'(let ()
1238 (define name
1239 (letruc ((dname dval) ...)
1240 (make-p-class 'name doc
1241 parents
1242 (lambda (dict)
1243 (pylist-set! dict 'dname dname)
1244 ...
1245 (values)))))
1246 name)))))
1247
1248 (define-syntax-rule (def-p-class name . l)
1249 (define name (mk-p-class name . l)))
1250
1251 (define (get-class o)
1252 (cond
1253 ((is-a? o <p>)
1254 o)
1255 (else
1256 (error "not a pyclass"))))
1257
1258 (define (get-type o)
1259 (cond
1260 ((is-a? o <pyf>)
1261 'pyf)
1262 ((is-a? o <py>)
1263 'py)
1264 ((is-a? o <pf>)
1265 'pf)
1266 ((is-a? o <p>)
1267 'p)
1268 (else
1269 'none)))
1270
1271 (define (print o l z)
1272 (begin
1273 (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
1274 (define port (if (pair? l) (car l) #t))
1275 (format port "~a"
1276 (aif it (if (pyclass? o)
1277 #f
1278 (if (pyobject? o)
1279 z
1280 #f))
1281 (format
1282 #f "~a(~a)<~a>"
1283 p (get-type o) (it))
1284 (format
1285 #f "~a(~a)<~a>"
1286 p (get-type o) (aif it (find-in-class-raw
1287 o '__name__ #f)
1288 it
1289 (ref
1290 o '__name__ 'Annonymous)))))))
1291
1292 (define-method (write (o <p>) . l)
1293 (aif it (ref o '__repr__)
1294 (print o l it)
1295 (print o l #f)))
1296
1297 (define-method (display (o <p>) . l)
1298 (aif it (ref o '__repr__)
1299 (print o l it)
1300 (print o l #f)))
1301
1302 (define (arglist->pkw l)
1303 (let lp ((l l) (r '()))
1304 (if (pair? l)
1305 (let ((x (car l)))
1306 (if (keyword? x)
1307 (cons (reverse r) l)
1308 (lp (cdr l) (cons x r))))
1309 (cons (reverse r) '()))))
1310
1311 (define-syntax-rule (define-python-class name (parents ...) code ...)
1312 (define name
1313 (syntax-parameterize ((*class* (lambda (x) #'name)))
1314 (mk-p-class name (arglist->pkw (list parents ...)) code ...))))
1315
1316 (define-syntax-rule (define-python-class-noname name (parents ...) code ...)
1317 (define name
1318 (syntax-parameterize ((*class* (lambda (x) #'name)))
1319 (mk-p-class-noname name (arglist->pkw (list parents ...))
1320 code ...))))
1321
1322
1323 (define-syntax make-python-class
1324 (lambda (x)
1325 (syntax-case x ()
1326 ((_ name (parents ...) code ...)
1327 #'(let* ((cl (mk-p-class name
1328 (arglist->pkw (list parents ...))
1329 code ...)))
1330 cl)))))
1331
1332 (define type-goops #f)
1333 (define kind-cache (make-hash-table))
1334 (define (kind-cache-it type it)
1335 (hashq-set! kind-cache type it)
1336 type)
1337
1338 (define (kind x)
1339 (if (not type-goops) (set! type-goops (rawref type '__goops__)))
1340 (and (is-a? x <p>)
1341 (aif it (find-in-class-raw x '__goops__ #f)
1342 (aif it2 (hashq-ref kind-cache it)
1343 it2
1344 (if (or
1345 (not type-goops)
1346 (eq? it type-goops)
1347 (member it (class-subclasses type-goops)))
1348 (kind-cache-it 'type it)
1349 (kind-cache-it 'class it)))
1350 'object)))
1351
1352 (define (pyobject? x) (eq? (kind x) 'object))
1353 (define (pyclass? x) (eq? (kind x) 'class))
1354 (define (pytype? x) (eq? (kind x) 'type))
1355
1356 (define (mark-fkn tag f)
1357 (set-procedure-property!- f 'py-special tag)
1358 f)
1359
1360 (define-syntax-parameter
1361 *class* (lambda (x) (error "*class* not parameterized")))
1362 (define-syntax-parameter
1363 *self* (lambda (x) (error "*class* not parameterized")))
1364
1365 (define *super* (list 'super))
1366
1367 (define (not-a-super) 'not-a-super)
1368 (define (py-super class obj)
1369 (define (make cl parents)
1370 (if (not cl)
1371 #f
1372 (let ((c (make-p <py>))
1373 (o (make-p <py>)))
1374 (rawset c '__class__ type)
1375 (rawset c '__mro__ (cons* c parents))
1376 (rawset c '__getattribute__
1377 (lambda (self key)
1378 (set! key (if (string? key) (string->symbol key) key))
1379 (kif it (ficap c key fail)
1380 (aif dt (ref it '__get__)
1381 (dt obj cl)
1382 it)
1383 fail)))
1384 (rawset c '__name__ "**super**")
1385 (rawset o '__class__ c)
1386 o)))
1387
1388 (call-with-values
1389 (lambda ()
1390 (let ((ll (ref (ref obj '__class__) '__mro__ '())))
1391 (if (pair? ll)
1392 (let lp ((l ll))
1393 (if (pair? l)
1394 (if (eq? class (car l))
1395 (let ((r (cdr l)))
1396 (if (pair? r)
1397 (values (car r) r)
1398 (values #f #f)))
1399 (lp (cdr l)))
1400 (values (car ll) ll)))
1401 (values #f #f))))
1402 make))
1403
1404
1405
1406 (define-syntax py-super-mac
1407 (syntax-rules ()
1408 ((_)
1409 (py-super *class* *self*))
1410 ((_ class self)
1411 (py-super class self))))
1412
1413 (define (pp x)
1414 (pretty-print (syntax->datum x))
1415 x)
1416
1417 (define-syntax letruc
1418 (lambda (x)
1419 (syntax-case x ()
1420 ((_ ((x v) ...) code ...)
1421 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
1422 (if (pair? a)
1423 (let* ((x (car a))
1424 (s (syntax->datum x)))
1425 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
1426 (r (list (car b))))
1427 (if (pair? a2)
1428 (if (eq? (syntax->datum a2) s)
1429 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
1430 (lp2 (cdr a2) (cdr b2)
1431 (cons (car a2) a3)
1432 (cons (car b2) b3)
1433 r))
1434 (lp (reverse a3) (reverse b3)
1435 (cons
1436 (list x #`(let* #,(map (lambda (v) (list x v))
1437 (reverse r)) #,x))
1438 u)))))
1439 #`(letrec #,(reverse u) code ...)))))))
1440
1441 (define-syntax letruc2
1442 (lambda (x)
1443 (syntax-case x ()
1444 ((_ ((x v) ...) code ...)
1445 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
1446 (if (pair? a)
1447 (let* ((x (car a))
1448 (s (syntax->datum x)))
1449 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
1450 (r (list (car b))))
1451 (if (pair? a2)
1452 (if (eq? (syntax->datum a2) s)
1453 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
1454 (lp2 (cdr a2) (cdr b2)
1455 (cons (car a2) a3)
1456 (cons (car b2) b3)
1457 r))
1458 (lp (reverse a3) (reverse b3)
1459 (cons
1460 (list x #`(let* #,(map (lambda (v) (list x v))
1461 (reverse r)) #,x))
1462 u)))))
1463 #`(let #,(reverse u) code ...)))))))
1464
1465
1466
1467 (define-method (py-init . l)
1468 (values))
1469
1470 (define-method (py-init (o <p>) . l)
1471 (aif it (ref o '__init__)
1472 (apply it l)
1473 (next-method)))
1474
1475 (define mk-tree
1476 (case-lambda
1477 ((root)
1478 (vector root '()))
1479 ((root hist) (vector root hist))))
1480
1481 (define (geth t) (vector-ref t 1))
1482 (define (getr t) (vector-ref t 0))
1483 (define (tree-ref t) (car (getr t)))
1484
1485 (define (nxt tree)
1486 (define (dive r h)
1487 (let ((x (car r)))
1488 (if (pair? x)
1489 (dive (car r) (cons (cdr r) h))
1490 (mk-tree r h))))
1491
1492 (define (up r h)
1493 (if (null? r)
1494 (if (pair? h)
1495 (up (car h) (cdr h))
1496 #f)
1497 (let ((x (car r)))
1498 (if (pair? x)
1499 (dive r h)
1500 (mk-tree r h)))))
1501
1502 (let ((r (getr tree)) (h (geth tree)))
1503 (cond
1504 ((pair? r)
1505 (let ((r (cdr r)))
1506 (if (pair? r)
1507 (let ((x (car r)))
1508 (if (pair? x)
1509 (dive x (cons (cdr r) h))
1510 (mk-tree r h)))
1511 (if (pair? h)
1512 (up (car h) (cdr h))
1513 #f))))
1514 (else
1515 (if (pair? h)
1516 (up (car h) (cdr h))
1517 #f)))))
1518
1519 (define (class-to-tree cl)
1520 (cons cl
1521 (map class-to-tree
1522 (ref cl '__bases__ '()))))
1523
1524 (define (find-tree o tree)
1525 (if tree
1526 (let ((x (tree-ref tree)))
1527 (if (eq? o x)
1528 #t
1529 (find-tree o (nxt tree))))
1530 #f))
1531
1532 (define (linearize x)
1533 (cond
1534 ((null? x) x)
1535 ((pair? x)
1536 (append (linearize (car x)) (linearize (cdr x))))
1537 (else (list x))))
1538
1539 (define (get-mro parents)
1540 (linearize
1541 (if (null? parents)
1542 parents
1543 (get-mro0 (map class-to-tree parents)))))
1544
1545 (define (get-mro0 parents)
1546 (define tree (mk-tree parents))
1547 (let lp ((tree tree) (r '()))
1548 (if tree
1549 (let ((x (tree-ref tree))
1550 (n (nxt tree)))
1551 (if (find-tree x n)
1552 (lp n r)
1553 (lp n (cons x r))))
1554 (reverse r))))
1555
1556 (define-method (py-equal? (x <p>) y)
1557 (aif it (ref x '__eq__)
1558 (it y)
1559 (next-method)))
1560
1561 (define-method (py-equal? y (x <p>))
1562 (aif it (ref x '__eq__)
1563 (it y)
1564 (next-method)))
1565
1566 (define-method (py-equal? x y) ((@ (guile) equal?) x y))
1567
1568 (define (equal? x y) (or (eq? x y) (py-equal? x y)))
1569
1570 (define (subclasses self)
1571 (aif it (ref self '__zubclasses__)
1572 (let ((h (make-hash-table)))
1573 (let lp0 ((it it))
1574 (let lp ((l (hash-fold
1575 (lambda (k v s)
1576 (hash-set! h k #t)
1577 (cons k s))
1578 '() it)))
1579 (if (pair? l)
1580 (begin
1581 (lp0 (car l))
1582 (lp (cdr l))))))
1583
1584 (hash-fold (lambda (k v s) (cons k s)) '() h))
1585 '()))
1586
1587 (define ref-class
1588 (lambda (self key fail)
1589 (aif class (find-in-class-raw self '__class__ #f)
1590 (kif it1 (ficap class key fail)
1591 (aif dd1 (rawref it1 '__get__)
1592 (dd1 self class)
1593 it1)
1594 fail)
1595 fail)))
1596
1597
1598 (define __getattribute__
1599 (lambda (self key-)
1600 (define key (if (string? key-) (string->symbol key-) key-))
1601 (aif class (find-in-class-raw self '__class__ #f)
1602 (kif it1 (ficap class key fail)
1603 (aif dd1 (ref it1 '__get__)
1604 (if (ref it1 '__set__)
1605 (dd1 self class)
1606 (kif it2 (ficap self key fail)
1607 it2
1608 (dd1 self class)))
1609 (kif it2 (ficap self key fail)
1610 it2
1611 it1))
1612 (kif it2 (ficap self key fail)
1613 (if (pyobject? self)
1614 it2
1615 (aif dd1 (ref it2 '__get__)
1616 (dd1 self self)
1617 it2))
1618 (aif it (ficap-raw class '__getattr__ #f)
1619 (kif it1 (catch #t
1620 (lambda ()
1621 (it self (symbol->string key)))
1622 (lambda x fail))
1623 (if (pyobject? self)
1624 it1
1625 (aif dd1 (ref it1 '__get__)
1626 (dd1 self self)
1627 it1))
1628 fail)
1629 fail)))
1630 fail)))
1631
1632 (define attr __getattribute__)
1633
1634 (define (*str* self . l)
1635 (scmstr (ref self '__name__)))
1636
1637 (define *setattr* __setattr__)
1638
1639 (set! type
1640 (make-python-class type ()
1641 (define __new__ new-class0)
1642 (define __init_subclass__ (lambda x (values)))
1643 (define __zub_classes__ (make-weak-key-hash-table))
1644 (define __subclasses__ subclasses)
1645 (define __call__ type-call)
1646 (define __str__ *str*)
1647 (define __getattribute__ attr)
1648 (define __setattr__ (object-method *setattr*))
1649 (define __format__ (lambda (self x) (*str* self)))
1650 (define __reduce_ex__ (lambda x (error "not implemented")))
1651 (define mro (lambda (self) (ref self '__mro__)))))
1652
1653 (set type '__class__ type)
1654 (rawset type '__mro__ (list type))
1655
1656 (define _mro (object-method (lambda (self) (ref self '__mro__))))
1657
1658 (define (scmstr s) (if (symbol? s) (symbol->string s) s))
1659
1660 (set! object
1661 (make-python-class object ()
1662 (define __new__ (lambda (class . a)
1663 (make-object
1664 class
1665 (find-in-class-raw class '__class__ #f)
1666 (find-in-class-raw class '__goops__ #f))))
1667 (define __init__ (lambda x (values)))
1668 (define __subclasses__ subclasses)
1669 (define __getattribute__ attr)
1670 (define __setattr__ (object-method *setattr*))
1671 (define __str__ *str*)
1672 (define __ne__ (object-method
1673 (lambda (self x) (not (equal? self x)))))
1674 (define __format__ (lambda (self x) (*str* self)))
1675 (define __reduce_ex__ (lambda x (error "not implemented")))
1676 (define __weakref__ (lambda (self) self))))
1677
1678 (rawset object '__mro__ (list object))
1679
1680 (name-object type)
1681 (name-object object)
1682
1683 (define-method (py-class (o <p>))
1684 (aif it (ref o '__class__)
1685 it
1686 (next-method)))
1687
1688 (define-python-class NoneObj ()
1689 (define __new__
1690 (lambda x 'None)))
1691
1692 (define-method (py-dict x)
1693 (if (eq? x 'None)
1694 (py-dict NoneObj)
1695 (make-hash-table)))
1696
1697 (define-method (py-dict (o <p>))
1698 (aif it (ref o '__dict__)
1699 it
1700 (dictRNs (slot-ref o 'h))))