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