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