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