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