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