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