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