debuggings
[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 (when (struct? obj)
376 (aif it (ficap class '__init__ #f)
377 (apply it obj x)
378 #f)
379
380 (slot-set! obj 'procedure
381 (lambda x
382 (aif it (ref obj '__call__)
383 (apply it x)
384 (error "not a callable object")))))
385
386 obj))
387
388 (define (create-object class x)
389 (if (pytype? class)
390 (apply type-call class x)
391 (let ((meta (and class (find-in-class-raw class '__class__ #f))))
392 (with-fluids ((*make-class* #t))
393 (aif it (ficap meta '__call__ #f)
394 (apply it class x)
395 (the-create-object class x))))))
396
397 (define type-call
398 (lambda (class . l)
399 (if (pytype? class)
400 (apply (case-lambda
401 ((meta obj)
402 (and obj (find-in-class-raw obj '__class__ 'None)))
403 ((meta name bases dict . keys)
404 (type- meta name bases dict keys)))
405 class l)
406 (the-create-object class l))))
407
408 (define (get-dict self name parents)
409 (aif it (and self (ficap self '__prepare__ #f))
410 (dictNs (it self name parents))
411 (make-hash-table)))
412
413 (define (create-class meta name parents gen-methods keys)
414 (let ((dict (gen-methods (get-dict meta name parents))))
415 (aif it (and meta (find-in-class-raw meta '__class__ #f))
416 (aif it (ficap-raw it '__call__ #f)
417 (apply it meta name parents dict keys)
418 (type- meta name parents dict keys))
419 (type- meta name parents dict keys))))
420
421 (define (make-object class meta goops)
422 (let ((obj (make-p goops)))
423 (rawset obj '__class__ class)
424 obj))
425
426 ;; Make an empty pf object
427 (define (make-p <x>)
428 (let ((r (make <x>)))
429 (cond
430 ((is-a? r <pf>)
431 (slot-set! r 'h vlist-null)
432 (slot-set! r 'size 0)
433 (slot-set! r 'n 0))
434 ((is-a? r <p>)
435 (slot-set! r 'h (make-hash-table)))
436 (else
437 (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
438 r)))
439 r))
440
441
442 (define-syntax-rule (hif it (k h) x y)
443 (let ((a (vhash-assq k h)))
444 (if (pair? a)
445 (let ((it (cdr a)))
446 x)
447 y)))
448
449 (define-syntax-rule (cif (it h) (k cl) x y)
450 (let* ((h (slot-ref cl 'h))
451 (a (vhash-assq k h)))
452 (if (pair? a)
453 (let ((it (cdr a)))
454 x)
455 y)))
456
457 (define-inlinable (gox obj it)
458 (let ((class (fluid-ref *location*)))
459 (aif f (rawref it '__get__)
460 (f obj class)
461 it)))
462
463 (define-inlinable (gokx obj class it)
464 (aif f (rawref it '__get__)
465 (f obj class)
466 it))
467
468 (define *location* (make-fluid #f))
469 (define-syntax-rule (mrefx x key l)
470 (let ()
471 (define (end)
472 (if (null? l)
473 #f
474 (car l)))
475
476 (define (parents li)
477 (let lp ((li li))
478 (if (pair? li)
479 (let ((p (car li)))
480 (cif (it h) (key p)
481 (begin (fluid-set! *location* p) it)
482 (lp (cdr li))))
483 fail)))
484
485 (cif (it h) (key x)
486 (begin (fluid-set! *location* x) it)
487 (hif cl ('__class__ h)
488 (cif (it h) (key cl)
489 (begin (fluid-set! *location* cl) it)
490 (hif p ('__mro__ h)
491 (let ((r (parents p)))
492 (if (eq? r fail)
493 (end)
494 r))
495 (end)))
496 (end)))))
497
498 (define-syntax-rule (mrefx klass key l)
499 (let ()
500 (define (end) (if (pair? l) (car l) #f))
501 (fluid-set! *location* klass)
502 (kif it (find-in-class-and-parents klass key fail)
503 it
504 (aif klass (and klass (find-in-class-raw klass '__class__ #f))
505 (begin
506 (fluid-set! *location* klass)
507 (kif it (find-in-class-and-parents klass key fail)
508 it
509 (end)))
510 (end)))))
511
512 (define not-implemented (cons 'not 'implemeneted))
513
514 (define (mrefx-py x key l)
515 (let ((xx x))
516 (define (exit) (if (pair? l) (car l) #f))
517 (aif class (find-in-class-raw xx '__class__ #f)
518 (aif f (ficap-raw class '__getattribute__ #f)
519 (kif it (if (eq? f __getattribute__)
520 (f xx key)
521 (catch #t
522 (lambda ()
523 (f xx (symbol->string key)))
524 (lambda q fail)))
525
526 it
527 (exit))
528 (kif it (__getattribute__ xx key)
529 it
530 (exit)))
531 #f)))
532
533 (define-syntax-rule (mref x key l)
534 (let ((xx x))
535 (mrefx xx key l)))
536
537 (define-syntax-rule (mref-py x key l)
538 (let ((xx x))
539 (let ((res (mrefx-py xx key l)))
540 res)))
541
542 (define-method (ref x key . l)
543 (cond
544 ((eq? x 'None)
545 (apply ref NoneObj key l))
546 ((pair? l)
547 (car l))
548 (else
549 #f)))
550
551 (define-method (ref (x <pf> ) key . l) (mref x key l))
552 (define-method (ref (x <p> ) key . l) (mref x key l))
553 (define-method (ref (x <pyf>) key . l) (mref-py x key l))
554 (define-method (ref (x <py> ) key . l) (mref-py x key l))
555
556 (define-method (rawref x key . l) (if (pair? l) (car l) #f))
557 (define-method (rawref (x <pf> ) key . l) (mref x key l))
558 (define-method (rawref (x <p> ) key . l) (mref x key l))
559
560
561 (define-method (set (f <procedure>) key val)
562 (set-procedure-property! f key val))
563
564 (define-method (ref (f <procedure>) key . l)
565 (aif it (assoc key (procedure-properties f))
566 (cdr it)
567 (if (pair? l) (car l) #f)))
568
569
570 ;; the reshape function that will create a fresh new pf object with less size
571 ;; this is an expensive operation and will only be done when we now there is
572 ;; a lot to gain essentially tho complexity is as in the number of set
573 (define (reshape x)
574 (let ((h (slot-ref x 'h))
575 (m (make-hash-table))
576 (n 0))
577 (define h2 (vhash-fold (lambda (k v s)
578 (if (hash-ref m k #f)
579 s
580 (begin
581 (hash-set! m k #t)
582 (set! n (+ n 1))
583 (vhash-consq k v s))))
584 vlist-null
585 h))
586 (slot-set! x 'h h2)
587 (slot-set! x 'size n)
588 (slot-set! x 'n n)
589 (values)))
590
591 ;; on object x add a binding that key -> val
592 (define-method (mset (x <pf>) key val)
593 (let ((h (slot-ref x 'h))
594 (s (slot-ref x 'size))
595 (n (slot-ref x 'n)))
596 (slot-set! x 'size (+ 1 s))
597 (let ((r (vhash-assoc key h)))
598 (when (not r)
599 (slot-set! x 'n (+ n 1)))
600 (slot-set! x 'h (vhash-cons key val h))
601 (when (> s (* 2 n))
602 (reshape x))
603 (values))))
604
605 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
606
607 (define-method (mset (x <p>) key val)
608 (begin
609 (hash-set! (slot-ref x 'h) key val)
610 (values)))
611
612 (define *make-class* (make-fluid #f))
613 (define (mc?) (not (fluid-ref *make-class*)))
614
615 (define __setattr__
616 (lambda (self key1 val)
617 (define key (if (string? key1) (string->symbol key1) key1))
618 (let ((h (aif dict (rawref self '__dict__)
619 dict
620 (slot-ref self 'h))))
621 (kif desc (py-get h key fail)
622 (aif it (rawref desc '__set__ #f)
623 (it self val)
624 (pylist-set! h key val))
625 (pylist-set! h key val)))))
626
627 (define (mset-py x key val)
628 (let* ((xx x))
629 (aif class (find-in-class-raw xx '__class__ #f)
630 (aif f (find-in-class-and-parents-raw class '__setattr__ #f)
631 (if (eq? f __setattr__)
632 (f xx key val)
633 (f xx (symbol->string key) val))
634 (__setattr__ xx key val))
635 (mset xx key val))))
636
637 (define-syntax-rule (mklam (mset a ...) val)
638 (mset a ... val))
639
640 (define-method (set (x <pf>) key val) (mklam (mset x key) val))
641 (define-method (set (x <p>) key val) (mklam (mset x key) val))
642 (define-method (set (x <pyf>) key val) (mklam (mset-py x key) val))
643 (define-method (set (x <py>) key val) (mklam (mset-py x key) val))
644
645 (define-method (rawset (x <pf>) key val) (mklam (mset x key) val))
646 (define-method (rawset (x <p>) key val) (mklam (mset x key) val))
647
648 ;; mref will reference the value of the key in the object x, an extra default
649 ;; parameter will tell what the fail object is else #f if fail
650 ;; if there is no found binding in the object search the class and
651 ;; the super classes for a binding
652
653 ;; call a function as a value of key in x with the object otself as a first
654 ;; parameter, this is pythonic object semantics
655 (define-syntax-rule (mk-call mcall mref)
656 (define-syntax-rule (mcall x key l)
657 (apply (mref x key '()) l)))
658
659 (mk-call mcall mref)
660 (mk-call mcall-py mref-py)
661
662 (define-method (call (x <pf>) key . l) (mcall x key l))
663 (define-method (call (x <p>) key . l) (mcall x key l))
664 (define-method (call (x <pyf>) key . l) (mcall-py x key l))
665 (define-method (call (x <py>) key . l) (mcall-py x key l))
666
667
668 ;; make a copy of a pf object
669 (define-syntax-rule (mcopy x)
670 (let ((r (make-p (ref x '__goops__))))
671 (slot-set! r 'h (slot-ref x 'h))
672 (slot-set! r 'size (slot-ref x 'size))
673 (slot-set! r 'n (slot-ref x 'n))
674 r))
675
676 (define-syntax-rule (mcopy- x)
677 (let* ((r (make-p (ref x '__goops__)))
678 (h (slot-ref r 'h)))
679 (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
680 r))
681
682 (define-method (copy (x <pf>)) (mcopy x))
683 (define-method (copy (x <p> )) (mcopy- x))
684
685 ;; make a copy of a pf object
686 (define-syntax-rule (mtr r x)
687 (begin
688 (slot-set! r 'h (slot-ref x 'h ))
689 (slot-set! r 'size (slot-ref x 'size))
690 (slot-set! r 'n (slot-ref x 'n ))
691 (values)))
692
693 (define-syntax-rule (mtr- r x)
694 (begin
695 (slot-set! r 'h (slot-ref x 'h))
696 (values)))
697
698
699 (define-method (tr (r <pf>) (x <pf>)) (mtr r x))
700 (define-method (tr (r <p> ) (x <p> )) (mtr- r x))
701
702
703 ;; with will execute thunk and restor x to it's initial state after it has
704 ;; finished note that this is a cheap operatoin because we use a functional
705 ;; datastructure
706 (define-syntax-rule (mwith x thunk)
707 (let ((old (mcopy x)))
708 (let ((r (thunk)))
709 (slot-set! x 'h (slot-ref old 'h))
710 (slot-set! x 'size (slot-ref old 'size))
711 (slot-set! x 'n (slot-ref old 'n))
712 r)))
713
714 (define-syntax-rule (mwith- x thunk)
715 (let ((old (mcopy- x)))
716 (let ((r (thunk)))
717 (slot-set! x 'h (slot-ref old 'h))
718 r)))
719
720
721
722 ;; a functional set will return a new object with the added binding and keep
723 ;; x untouched
724 (define-method (fset (x <pf>) key val)
725 (let ((x (mcopy x)))
726 (mset x key val val)
727 x))
728
729 (define-method (fset (x <p>) key val)
730 (let ((x (mcopy- x)))
731 (mset x key val val)
732 x))
733
734 (define (fset-x obj l val)
735 (let lp ((obj obj) (l l) (r '()))
736 (match l
737 (()
738 (let lp ((v val) (r r))
739 (if (pair? r)
740 (lp (fset (caar r) (cdar r) v) (cdr r))
741 v)))
742 ((k . l)
743 (lp (ref obj k #f) l (cons (cons obj k) r))))))
744
745
746
747
748
749 ;; a functional call will keep x untouched and return (values fknval newx)
750 ;; e.g. we get both the value of the call and the new version of x with
751 ;; perhaps new bindings added
752 (define-method (fcall (x <pf>) key . l)
753 (let* ((y (mcopy x))
754 (r (mcall y key l)))
755 (if (eq? (slot-ref x 'h) (slot-ref y 'h))
756 (values r x)
757 (values r y))))
758
759 (define-method (fcall (x <p>) key . l)
760 (let ((x (mcopy x)))
761 (values (mcall x key l)
762 x)))
763
764 ;; this shows how we can override addition in a pythonic way
765
766 ;; lets define get put pcall etc so that we can refer to an object like
767 ;; e.g. (put x.y.z 1) (pcall x.y 1)
768
769 (define-syntax-rule (cross x k f set)
770 (call-with-values (lambda () f)
771 (lambda (r y)
772 (if (eq? x y)
773 (values r x)
774 (values r (set x k y))))))
775
776 (define-syntax-rule (cross! x k f _) f)
777
778 (define-syntax mku
779 (syntax-rules ()
780 ((_ cross set setx f (key) (val ...))
781 (setx f key val ...))
782 ((_ cross set setx f (k . l) val)
783 (cross f k (mku cross set setx (ref f k) l val) set))))
784
785 (define-syntax-rule (mkk pset setx set cross)
786 (define-syntax pset
787 (lambda (x)
788 (syntax-case x ()
789 ((_ f val (... ...))
790 (let* ((to (lambda (x)
791 (datum->syntax #'f (string->symbol x))))
792 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
793 (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
794 (cdr l)))
795 (h (to (car l))))
796 #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
797
798 (mkk put fset fset cross)
799 (mkk put! set set cross!)
800 (mkk pcall! call fset cross!)
801 (mkk pcall fcall fset cross)
802 (mkk get ref fset cross!)
803
804 ;; it's good to have a null object so we don't need to construct it all the
805 ;; time because it is functional we can get away with this.
806 (define null (make-p <pf>))
807
808 (define (filter-parents l)
809 (let lp ((l l))
810 (if (pair? l)
811 (if (is-a? (car l) <p>)
812 (cons (car l) (lp (cdr l)))
813 (lp (cdr l)))
814 '())))
815
816 (define (kw->class kw meta)
817 (if (memq #:functional kw)
818 (if (memq #:fast kw)
819 <pf>
820 (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
821 <pyf>
822 <pf>))
823 (if (memq #:fast kw)
824 (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
825 <pf>
826 <p>)
827 (cond
828 ((is-a? meta <pyf>)
829 <pyf>)
830 ((is-a? meta <py>)
831 <py>)
832 ((is-a? meta <pf>)
833 <pf>)
834 ((is-a? meta <p>)
835 <p>)
836 (else
837 <py>)))))
838
839
840 (define (defaulter d)
841 (if d
842 (aif it (ref d '__goops__)
843 it
844 (if (is-a? d <py>)
845 <py>
846 <p>))
847 <py>))
848
849 (define (kwclass->class kw default)
850 (if (memq #:functionalClass kw)
851 (if (memq #:fastClass kw)
852 <pf>
853 (if (memq #:pyClass kw)
854 <pyf>
855 (if (or (is-a? default <py>) (is-a? default <pyf>))
856 <pyf>
857 <pf>)))
858 (if (memq #:mutatingClass kw)
859 (if (memq #:fastClass kw)
860 <p>
861 (if (memq #:pyClass kw)
862 <py>
863 (if (or (is-a? default <py>) (is-a? default <pyf>))
864 <py>
865 <p>)))
866 (if (memq #:fastClass kw)
867 (if (or (is-a? default <pf>) (is-a? default <pyf>))
868 <pf>
869 <p>)
870 (if (memq #:pyClass kw)
871 (if (or (is-a? default <pf>) (is-a? default <pyf>))
872 <pyf>
873 <py>)
874 (defaulter default))))))
875
876 (define type #f)
877 (define object #f)
878 (define make-p-class
879 (case-lambda
880 ((name supers.kw methods)
881 (make-p-class name "" supers.kw methods))
882 ((name doc supers.kw methods)
883 (define s.kw supers.kw)
884 (define kw (cdr s.kw))
885 (define supers (car s.kw))
886 (define goopses (map (lambda (sups)
887 (aif it (find-in-class sups '__goops__ #f)
888 it
889 sups))
890 supers))
891
892 (define parents (let ((p (filter-parents supers)))
893 p))
894
895 (define cparents (if (null? parents)
896 (if object
897 (list object)
898 '())
899 parents))
900
901 (define meta (aif it (memq #:metaclass kw)
902 (cadr it)
903 (if (null? cparents)
904 type
905 (let* ((p (car cparents))
906 (m (rawref p '__class__))
907 (mro (reverse (ref m '__mro__ '()))))
908 (let lp ((l (cdr cparents)) (m m) (mro mro))
909 (match l
910 ((pp . l)
911 (aif mm (rawref pp '__class__)
912 (aif mmro (rawref mm '__mro__)
913 (cond
914 ((memq m mmro)
915 (lp l mm mmro))
916 ((memq mm mro)
917 (lp l m mro))
918 (error "TypeError for meta"))
919 (lp l m mro))
920 (lp l m mro)))
921 (() m)))))))
922
923 (define (unique l)
924 (define t (make-hash-table))
925 (let lp ((l l))
926 (if (pair? l)
927 (let ((c (car l)))
928 (if (hashq-ref t c)
929 (lp (cdr l))
930 (begin
931 (hashq-set! t c #t)
932 (cons c (lp (cdr l))))))
933 '())))
934
935 (define goops (make-class (unique
936 (append goopses
937 (list (kw->class kw meta))))
938 '() #:name name))
939
940 (define (make-module)
941 (let ((l (module-name (current-module))))
942 (if (and (>= (length l) 3)
943 (equal? (list-ref l 0) 'language)
944 (equal? (list-ref l 1) 'python)
945 (equal? (list-ref l 2) 'module))
946 (string-join
947 (map symbol->string (cdddr l))
948 ".")
949 l)))
950
951 (define (gen-methods dict)
952 (define (filt-bases x)
953 (let lp ((x x))
954 (if (pair? x)
955 (let ((y (car x)))
956 (if (is-a? y <p>)
957 (cons y (lp (cdr x)))
958 (lp (cdr x))))
959 '())))
960
961 (methods dict)
962 (pylist-set! dict '__goops__ goops)
963 (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
964 (pylist-set! dict '__module__ (make-module))
965 (pylist-set! dict '__bases__ (filt-bases parents))
966 (pylist-set! dict '__name__ name)
967 (pylist-set! dict '__qualname__ name)
968 (pylist-set! dict '__mro__ (get-mro cparents))
969 (pylist-set! dict '__doc__ doc)
970 (pylist-set! dict '__class__ meta)
971 dict)
972
973 (let ((cl (with-fluids ((*make-class* #t))
974 (create-class meta name parents gen-methods kw))))
975 (aif it (ref meta '__init_subclass__)
976 (let lp ((ps cparents))
977 (if (pair? ps)
978 (let ((super (car ps)))
979 (it cl super)
980 (lp (cdr ps)))))
981 #f)
982 cl))))
983
984
985
986 ;; Let's make an object essentially just move a reference
987
988 ;; the make class and defclass syntactic sugar
989
990 (define-syntax make-up
991 (syntax-rules (lambda case-lambda lambda* letrec letrec*)
992 ((_ (lambda . l))
993 (object-method (lambda . l)))
994 ((_ (case-lambda . l))
995 (object-method (case-lambda . l)))
996 ((_ (lambda* . l))
997 (object-method (lambda* . l)))
998 ((_ (letrec . l))
999 (object-method (letrec . l)))
1000 ((_ (letrec* . l))
1001 (object-method (letrec* . l)))
1002 ((_ x) x)))
1003
1004 (define-syntax mk-p-class
1005 (lambda (x)
1006 (syntax-case x ()
1007 ((_ name parents (ddef dname dval) ...)
1008 #'(mk-p-class name parents "" (ddef dname dval) ...))
1009 ((_ name parents doc (ddef dname dval) ...)
1010 (with-syntax (((ddname ...)
1011 (map (lambda (dn)
1012 (datum->syntax
1013 #'name
1014 (string->symbol
1015 (string-append
1016 (symbol->string
1017 (syntax->datum #'name))
1018 "-"
1019 (symbol->string
1020 (syntax->datum dn))))))
1021 #'(dname ...)))
1022 (nname (datum->syntax
1023 #'name
1024 (string->symbol
1025 (string-append
1026 (symbol->string
1027 (syntax->datum #'name))
1028 "-goops-class")))))
1029 (%add-to-warn-list (syntax->datum #'nname))
1030 (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
1031 #'(ddname ...))
1032 #'(let ()
1033 (define name
1034 (letruc ((dname (make-up dval)) ...)
1035 (let ((ret
1036 (make-p-class 'name doc
1037 parents
1038 (lambda (dict)
1039 (pylist-set! dict 'dname dname)
1040 ...
1041 (values)))))
1042 (begin
1043 (module-define! (current-module) 'ddname dname)
1044 (name-object ddname))
1045 ...
1046 ret)))
1047
1048 (module-define! (current-module) 'nname (rawref name '__goops__))
1049 (name-object nname)
1050 (name-object name)
1051 name))))))
1052
1053 (define-syntax mk-p-class2
1054 (lambda (x)
1055 (syntax-case x ()
1056 ((_ name parents ((ddef dname dval) ...) body)
1057 #'(mk-p-class2 name parents "" ((ddef dname dval) ...) body))
1058 ((_ name parents doc ((ddef dname dval) ...) body)
1059 (with-syntax (((ddname ...)
1060 (map (lambda (dn)
1061 (datum->syntax
1062 #'name
1063 (string->symbol
1064 (string-append
1065 (symbol->string
1066 (syntax->datum #'name))
1067 "-"
1068 (symbol->string
1069 (syntax->datum dn))))))
1070 #'(dname ...)))
1071 (nname (datum->syntax
1072 #'name
1073 (string->symbol
1074 (string-append
1075 (symbol->string
1076 (syntax->datum #'name))
1077 "-goops-class")))))
1078
1079 (%add-to-warn-list (syntax->datum #'nname))
1080 (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
1081 #'(ddname ...))
1082
1083 #'(let ()
1084 (define name
1085 (letruc ((dname (make-up dval)) ...)
1086 body
1087 (let ((ret
1088 (make-p-class 'name doc
1089 parents
1090 (lambda (dict)
1091 (pylist-set! dict 'dname dname)
1092 ...
1093 dict))))
1094 (begin
1095 (module-define! (current-module) 'ddname dname)
1096 (name-object ddname))
1097 ...
1098 ret)))
1099 (module-define! (current-module) 'nname (rawref name '__goops__))
1100 (name-object nname)
1101 (name-object name)
1102 name))))))
1103
1104 (define-syntax mk-p-class-noname
1105 (lambda (x)
1106 (syntax-case x ()
1107 ((_ name parents (ddef dname dval) ...)
1108 #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
1109 ((_ name parents doc (ddef dname dval) ...)
1110 #'(let ()
1111 (define name
1112 (letruc ((dname dval) ...)
1113 (make-p-class 'name doc
1114 parents
1115 (lambda (dict)
1116 (pylist-set! dict 'dname dname)
1117 ...
1118 (values)))))
1119 name)))))
1120
1121 (define-syntax-rule (def-p-class name . l)
1122 (define name (mk-p-class name . l)))
1123
1124 (define (get-class o)
1125 (cond
1126 ((is-a? o <p>)
1127 o)
1128 (else
1129 (error "not a pyclass"))))
1130
1131 (define (get-type o)
1132 (cond
1133 ((is-a? o <pyf>)
1134 'pyf)
1135 ((is-a? o <py>)
1136 'py)
1137 ((is-a? o <pf>)
1138 'pf)
1139 ((is-a? o <p>)
1140 'p)
1141 (else
1142 'none)))
1143
1144 (define (print o l z)
1145 (begin
1146 (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
1147 (define port (if (pair? l) (car l) #t))
1148 (format port "~a"
1149 (aif it (if (pyclass? o)
1150 #f
1151 (if (pyobject? o)
1152 z
1153 #f))
1154 (format
1155 #f "~a(~a)<~a>"
1156 p (get-type o) (it))
1157 (format
1158 #f "~a(~a)<~a>"
1159 p (get-type o) (aif it (find-in-class-raw
1160 o '__name__ 'Annonymous)
1161 it
1162 (ref
1163 o '__name__ 'Annonymous)))))))
1164
1165 (define-method (write (o <p>) . l)
1166 (aif it (ref o '__repr__)
1167 (print o l it)
1168 (print o l #f)))
1169
1170 (define-method (display (o <p>) . l)
1171 (aif it (ref o '__repr__)
1172 (print o l it)
1173 (print o l #f)))
1174
1175 (define (arglist->pkw l)
1176 (let lp ((l l) (r '()))
1177 (if (pair? l)
1178 (let ((x (car l)))
1179 (if (keyword? x)
1180 (cons (reverse r) l)
1181 (lp (cdr l) (cons x r))))
1182 (cons (reverse r) '()))))
1183
1184 (define-syntax-rule (define-python-class name (parents ...) code ...)
1185 (define name
1186 (syntax-parameterize ((*class* (lambda (x) #'name)))
1187 (mk-p-class name (arglist->pkw (list parents ...)) code ...))))
1188
1189 (define-syntax-rule (define-python-class-noname name (parents ...) code ...)
1190 (define name
1191 (syntax-parameterize ((*class* (lambda (x) #'name)))
1192 (mk-p-class-noname name (arglist->pkw (list parents ...))
1193 code ...))))
1194
1195
1196 (define-syntax make-python-class
1197 (lambda (x)
1198 (syntax-case x ()
1199 ((_ name (parents ...) code ...)
1200 #'(let* ((cl (mk-p-class name
1201 (arglist->pkw (list parents ...))
1202 code ...)))
1203 cl)))))
1204
1205 (define type-goops #f)
1206 (define (kind x)
1207 (if (not type-goops) (set! type-goops (rawref type '__goops__)))
1208 (and (is-a? x <p>)
1209 (aif it (find-in-class x '__goops__ #f)
1210 (if (or
1211 (not type-goops)
1212 (eq? it type-goops)
1213 (member it (class-subclasses type-goops)))
1214 'type
1215 'class)
1216 'object)))
1217
1218 (define (pyobject? x) (eq? (kind x) 'object))
1219 (define (pyclass? x) (eq? (kind x) 'class))
1220 (define (pytype? x) (eq? (kind x) 'type))
1221
1222 (define (mark-fkn tag f)
1223 (set-procedure-property! f 'py-special tag)
1224 f)
1225
1226 (define-syntax-parameter
1227 *class* (lambda (x) (error "*class* not parameterized")))
1228 (define-syntax-parameter
1229 *self* (lambda (x) (error "*class* not parameterized")))
1230
1231 (define *super* (list 'super))
1232
1233 (define (not-a-super) 'not-a-super)
1234 (define (py-super class obj)
1235 (define (make cl parents)
1236 (if (not cl)
1237 #f
1238 (let ((c (make-p <py>))
1239 (o (make-p <py>)))
1240 (rawset c '__class__ type)
1241 (rawset c '__mro__ (cons* c parents))
1242 (rawset c '__getattribute__
1243 (lambda (self key)
1244 (set! key (if (string? key) (string->symbol key) key))
1245 (kif it (ficap c key fail)
1246 (aif dt (ref it '__get__)
1247 (dt obj cl)
1248 it)
1249 fail)))
1250 (rawset c '__name__ "**super**")
1251 (rawset o '__class__ c)
1252 o)))
1253
1254 (call-with-values
1255 (lambda ()
1256 (let ((ll (ref (ref obj '__class__) '__mro__ '())))
1257 (if (pair? ll)
1258 (let lp ((l ll))
1259 (if (pair? l)
1260 (if (eq? class (car l))
1261 (let ((r (cdr l)))
1262 (if (pair? r)
1263 (values (car r) r)
1264 (values #f #f)))
1265 (lp (cdr l)))
1266 (values (car ll) ll)))
1267 (values #f #f))))
1268 make))
1269
1270
1271
1272 (define-syntax py-super-mac
1273 (syntax-rules ()
1274 ((_)
1275 (py-super *class* *self*))
1276 ((_ class self)
1277 (py-super class self))))
1278
1279 (define (pp x)
1280 (pretty-print (syntax->datum x))
1281 x)
1282
1283 (define-syntax letruc
1284 (lambda (x)
1285 (syntax-case x ()
1286 ((_ ((x v) ...) code ...)
1287 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
1288 (if (pair? a)
1289 (let* ((x (car a))
1290 (s (syntax->datum x)))
1291 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
1292 (r (list (car b))))
1293 (if (pair? a2)
1294 (if (eq? (syntax->datum a2) s)
1295 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
1296 (lp2 (cdr a2) (cdr b2)
1297 (cons (car a2) a3)
1298 (cons (car b2) b3)
1299 r))
1300 (lp (reverse a3) (reverse b3)
1301 (cons
1302 (list x #`(let* #,(map (lambda (v) (list x v))
1303 (reverse r)) #,x))
1304 u)))))
1305 #`(letrec #,(reverse u) code ...)))))))
1306
1307
1308
1309 (define-method (py-init . l)
1310 (values))
1311
1312 (define-method (py-init (o <p>) . l)
1313 (aif it (ref o '__init__)
1314 (apply it l)
1315 (next-method)))
1316
1317 (define mk-tree
1318 (case-lambda
1319 ((root)
1320 (vector root '()))
1321 ((root hist) (vector root hist))))
1322
1323 (define (geth t) (vector-ref t 1))
1324 (define (getr t) (vector-ref t 0))
1325 (define (tree-ref t) (car (getr t)))
1326
1327 (define (nxt tree)
1328 (define (dive r h)
1329 (let ((x (car r)))
1330 (if (pair? x)
1331 (dive (car r) (cons (cdr r) h))
1332 (mk-tree r h))))
1333
1334 (define (up r h)
1335 (if (null? r)
1336 (if (pair? h)
1337 (up (car h) (cdr h))
1338 #f)
1339 (let ((x (car r)))
1340 (if (pair? x)
1341 (dive r h)
1342 (mk-tree r h)))))
1343
1344 (let ((r (getr tree)) (h (geth tree)))
1345 (cond
1346 ((pair? r)
1347 (let ((r (cdr r)))
1348 (if (pair? r)
1349 (let ((x (car r)))
1350 (if (pair? x)
1351 (dive x (cons (cdr r) h))
1352 (mk-tree r h)))
1353 (if (pair? h)
1354 (up (car h) (cdr h))
1355 #f))))
1356 (else
1357 (if (pair? h)
1358 (up (car h) (cdr h))
1359 #f)))))
1360
1361 (define (class-to-tree cl)
1362 (cons cl
1363 (map class-to-tree
1364 (ref cl '__bases__ '()))))
1365
1366 (define (find-tree o tree)
1367 (if tree
1368 (let ((x (tree-ref tree)))
1369 (if (eq? o x)
1370 #t
1371 (find-tree o (nxt tree))))
1372 #f))
1373
1374 (define (linearize x)
1375 (cond
1376 ((null? x) x)
1377 ((pair? x)
1378 (append (linearize (car x)) (linearize (cdr x))))
1379 (else (list x))))
1380
1381 (define (get-mro parents)
1382 (linearize
1383 (if (null? parents)
1384 parents
1385 (get-mro0 (map class-to-tree parents)))))
1386
1387 (define (get-mro0 parents)
1388 (define tree (mk-tree parents))
1389 (let lp ((tree tree) (r '()))
1390 (if tree
1391 (let ((x (tree-ref tree))
1392 (n (nxt tree)))
1393 (if (find-tree x n)
1394 (lp n r)
1395 (lp n (cons x r))))
1396 (reverse r))))
1397
1398 (define-method (py-equal? (x <p>) y)
1399 (aif it (ref x '__eq__)
1400 (it y)
1401 (next-method)))
1402
1403 (define-method (py-equal? y (x <p>))
1404 (aif it (ref x '__eq__)
1405 (it y)
1406 (next-method)))
1407
1408 (define-method (py-equal? x y) ((@ (guile) equal?) x y))
1409
1410 (define (equal? x y) (or (eq? x y) (py-equal? x y)))
1411
1412 (define (subclasses self)
1413 (aif it (ref self '__zubclasses__)
1414 (let ((h (make-hash-table)))
1415 (let lp0 ((it it))
1416 (let lp ((l (hash-fold
1417 (lambda (k v s)
1418 (hash-set! h k #t)
1419 (cons k s))
1420 '() it)))
1421 (if (pair? l)
1422 (begin
1423 (lp0 (car l))
1424 (lp (cdr l))))))
1425
1426 (hash-fold (lambda (k v s) (cons k s)) '() h))
1427 '()))
1428
1429 (define ref-class
1430 (lambda (self key fail)
1431 (aif class (find-in-class-raw self '__class__ #f)
1432 (kif it1 (ficap class key fail)
1433 (aif dd1 (rawref it1 '__get__)
1434 (dd1 self class)
1435 it1)
1436 fail)
1437 fail)))
1438
1439
1440 (define __getattribute__
1441 (lambda (self key-)
1442 (define key (if (string? key-) (string->symbol key-) key-))
1443 (aif class (find-in-class-raw self '__class__ #f)
1444 (kif it1 (ficap class key fail)
1445 (aif dd1 (ref it1 '__get__)
1446 (if (ref it1 '__set__)
1447 (dd1 self class)
1448 (kif it2 (ficap self key fail)
1449 it2
1450 (dd1 self class)))
1451 (kif it2 (ficap self key fail)
1452 it2
1453 it1))
1454 (kif it2 (ficap self key fail)
1455 it2
1456 (aif it (ficap-raw class '__getattr__ #f)
1457 (kif it1 (catch #t
1458 (lambda ()
1459 (it self (symbol->string key)))
1460 (lambda x fail))
1461 (aif dd1 (ref it1 '__get__)
1462 (dd1 self class)
1463 it1)
1464 fail)
1465 fail)))
1466 fail)))
1467
1468 (define attr __getattribute__)
1469
1470 (define (*str* self)
1471 (scmstr (ref self '__name__)))
1472
1473 (define *setattr* __setattr__)
1474
1475 (set! type
1476 (make-python-class type ()
1477 (define __new__ new-class0)
1478 (define __init_subclass__ (lambda x (values)))
1479 (define ___zub_classes__ (make-weak-key-hash-table))
1480 (define __subclasses__ subclasses)
1481 (define __call__ type-call)
1482 (define __str__ *str*)
1483 (define __getattribute__ attr)
1484 (define __setattr__ (object-method *setattr*))
1485 (define __format__ (lambda (self x) (*str* self)))
1486 (define __reduce_ex__ (lambda x (error "not implemented")))
1487 (define mro (lambda (self) (ref self '__mro__)))))
1488
1489 (set type '__class__ type)
1490 (rawset type '__mro__ (list type))
1491
1492 (define _mro (object-method (lambda (self) (ref self '__mro__))))
1493
1494 (define (scmstr s) (if (symbol? s) (symbol->string s) s))
1495
1496 (set! object
1497 (make-python-class object ()
1498 (define __new__ (lambda (class . a)
1499 (make-object
1500 class
1501 (find-in-class-raw class '__class__ #f)
1502 (find-in-class-raw class '__goops__ #f))))
1503 (define __init__ (lambda x (values)))
1504 (define __subclasses__ subclasses)
1505 (define __getattribute__ attr)
1506 (define __setattr__ (object-method *setattr*))
1507 (define __str__ *str*)
1508 (define __format__ (lambda (self x) (*str* self)))
1509 (define __reduce_ex__ (lambda x (error "not implemented")))
1510 (define __weakref__ (lambda (self) self))))
1511
1512 (rawset object '__mro__ (list object))
1513
1514 (name-object type)
1515 (name-object object)
1516
1517 (define-method (py-class (o <p>))
1518 (aif it (ref o '__class__)
1519 it
1520 (next-method)))
1521
1522 (define-python-class NoneObj ()
1523 (define __new__
1524 (lambda x 'None)))
1525
1526 (define-method (py-dict x)
1527 (if (eq? x 'None)
1528 (py-dict NoneObj)
1529 (make-hash-table)))
1530
1531 (define-method (py-dict (o <p>))
1532 (aif it (ref o '__dict__)
1533 it
1534 (dictRNs (slot-ref o 'h))))