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