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