792a89a25f25e11e4988dd2b172a88c15e094c23
[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 name supers.kw methods)
704 (define kw (cdr supers.kw))
705 (define supers (car supers.kw))
706 (define goopses (map (lambda (sups)
707 (aif it (ref sups '__goops__ #f)
708 it
709 sups))
710 supers))
711 (define parents (let ((p (filter-parents supers)))
712 (if (null? p)
713 (if object
714 (list object)
715 '())
716 p)))
717
718 (define meta (aif it (memq #:metaclass kw)
719 (cadr it)
720 (if (null? parents)
721 type
722 (let* ((p (car parents))
723 (m (ref p '__class__))
724 (mro (reverse (ref m '__mro__ '()))))
725 (let lp ((l (cdr parents))
726 (max mro)
727 (min mro))
728 (if (pair? l)
729 (let* ((p (car l))
730 (meta (ref p '__class__))
731 (mro (ref meta '__mro__ '())))
732 (let lp2 ((max max) (mr (reverse mro)))
733 (if (and (pair? max) (pair? mr))
734 (if (eq? (car max) (car mr))
735 (lp2 (cdr max) (cdr mr))
736 (error
737 "need a common lead for meta"))
738 (if (pair? max)
739 (if (< (length mro) (length min))
740 (lp (cdr l) max mro)
741 (lp (cdr l) max min))
742 (lp (cdr l) mro min)))))
743 (car (reverse min))))))))
744
745 (define goops (make-class (append goopses (list (kw->class kw meta)))
746 '() #:name name))
747
748 (define (make-module)
749 (let ((l (module-name (current-module))))
750 (if (and (>= (length l) 3)
751 (equal? (list-ref l 0) 'language)
752 (equal? (list-ref l 1) 'python)
753 (equal? (list-ref l 2) 'module))
754 (string-join
755 (map symbol->string (cdddr l))
756 ".")
757 l)))
758
759 (define (gen-methods dict)
760 (methods dict)
761 (pylist-set! dict '__goops__ goops)
762 (pylist-set! dict '__class__ meta)
763 (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
764 (pylist-set! dict '__module__ (make-module))
765 (pylist-set! dict '__bases__ parents)
766 (pylist-set! dict '__fget__ #t)
767 (pylist-set! dict '__fset__ #t)
768 (pylist-set! dict '__name__ name)
769 (pylist-set! dict '__qualname__ name)
770 (pylist-set! dict '__class__ meta)
771 (pylist-set! dict '__mro__ (get-mro parents))
772 dict)
773
774 (let ((cl (with-fluids ((*make-class* #t))
775 (create-class meta name parents gen-methods kw))))
776 (aif it (ref meta '__init_subclass__)
777 (let lp ((ps parents))
778 (if (pair? ps)
779 (let ((super (car ps)))
780 (it cl super)
781 (lp (cdr ps)))))
782 #f)
783
784 cl))
785
786
787
788 ;; Let's make an object essentially just move a reference
789
790 ;; the make class and defclass syntactic sugar
791
792 (define-syntax make-up
793 (syntax-rules (lambda case-lambda lambda* letrec letrec*)
794 ((_ (lambda . l))
795 (object-method (lambda . l)))
796 ((_ (case-lambda . l))
797 (object-method (case-lambda . l)))
798 ((_ (lambda* . l))
799 (object-method (lambda* . l)))
800 ((_ (letrec . l))
801 (object-method (letrec . l)))
802 ((_ (letrec* . l))
803 (object-method (letrec* . l)))
804 ((_ x) x)))
805
806 (define-syntax mk-p-class
807 (lambda (x)
808 (syntax-case x ()
809 ((_ name parents (ddef dname dval) ...)
810 (with-syntax (((ddname ...)
811 (map (lambda (dn)
812 (datum->syntax
813 #'name
814 (string->symbol
815 (string-append
816 (symbol->string
817 (syntax->datum #'name))
818 "-"
819 (symbol->string
820 (syntax->datum dn))))))
821 #'(dname ...)))
822 (nname (datum->syntax
823 #'name
824 (string->symbol
825 (string-append
826 (symbol->string
827 (syntax->datum #'name))
828 "-goops-class")))))
829 (%add-to-warn-list (syntax->datum #'nname))
830 (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
831 #'(ddname ...))
832 #'(let ()
833 (define name
834 (letruc ((dname (make-up dval)) ...)
835 (make-p-class 'name
836 parents
837 (lambda (dict)
838 (pylist-set! dict 'dname dname)
839 ...
840 (values)))))
841
842 (begin
843 (module-define! (current-module) 'ddname (ref name 'dname))
844 (name-object ddname))
845 ...
846
847 (module-define! (current-module) 'nname (ref name '__goops__))
848 (name-object nname)
849 (name-object name)
850 name))))))
851
852 (define-syntax mk-p-class-noname
853 (lambda (x)
854 (syntax-case x ()
855 ((_ name parents (ddef dname dval) ...)
856 #'(let ()
857 (define name
858 (letruc ((dname dval) ...)
859 (make-p-class 'name
860 parents
861 (lambda (dict)
862 (pylist-set! dict 'dname dname)
863 ...
864 (values)))))
865 name)))))
866
867 (define-syntax-rule (def-p-class name . l)
868 (define name (mk-p-class name . l)))
869
870 (define (get-class o)
871 (cond
872 ((is-a? o <p>)
873 o)
874 (else
875 (error "not a pyclass"))))
876
877 (define (get-type o)
878 (cond
879 ((is-a? o <pyf>)
880 'pyf)
881 ((is-a? o <py>)
882 'py)
883 ((is-a? o <pf>)
884 'pf)
885 ((is-a? o <p>)
886 'p)
887 (else
888 'none)))
889
890 (define (print o l)
891 (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
892 (define port (if (pair? l) (car l) #t))
893 (format port "~a"
894 (aif it (if (pyclass? o)
895 #f
896 (if (pyobject? o)
897 (ref o '__repr__)
898 #f))
899 (format
900 #f "~a(~a)<~a>"
901 p (get-type o) (it))
902 (format
903 #f "~a(~a)<~a>"
904 p (get-type o) (ref o '__name__ 'Annonymous)))))
905
906 (define-method (write (o <p>) . l) (print o l))
907 (define-method (display (o <p>) . l) (print o l))
908
909 (define (arglist->pkw l)
910 (let lp ((l l) (r '()))
911 (if (pair? l)
912 (let ((x (car l)))
913 (if (keyword? x)
914 (cons (reverse r) l)
915 (lp (cdr l) (cons x r))))
916 (cons (reverse r) '()))))
917
918 (define-syntax-rule (define-python-class name (parents ...) code ...)
919 (define name
920 (syntax-parameterize ((*class* (lambda (x) #'name)))
921 (mk-p-class name (arglist->pkw (list parents ...)) code ...))))
922
923 (define-syntax-rule (define-python-class-noname name (parents ...) code ...)
924 (define name
925 (syntax-parameterize ((*class* (lambda (x) #'name)))
926 (mk-p-class-noname name (arglist->pkw (list parents ...))
927 code ...))))
928
929
930 (define-syntax make-python-class
931 (lambda (x)
932 (syntax-case x ()
933 ((_ name (parents ...) code ...)
934 #'(let* ((cl (mk-p-class name
935 (arglist->pkw (list parents ...))
936 code ...)))
937 cl)))))
938
939
940 (define (kind x)
941 (and (is-a? x <p>)
942 (aif it (find-in-class x '__goops__ #f)
943 (if (is-a? (make it) (ref type '__goops__))
944 'type
945 'class)
946 'object)))
947
948 (define (pyobject? x) (eq? (kind x) 'object))
949 (define (pyclass? x) (eq? (kind x) 'class))
950 (define (pytype? x) (eq? (kind x) 'type))
951
952 (define (mark-fkn tag f)
953 (set-procedure-property! f 'py-special tag)
954 f)
955
956 (define-syntax-parameter
957 *class* (lambda (x) (error "*class* not parameterized")))
958 (define-syntax-parameter
959 *self* (lambda (x) (error "*class* not parameterized")))
960
961 (define *super* (list 'super))
962
963 (define (not-a-super) 'not-a-super)
964 (define (py-super class obj)
965 (define (make cl parents)
966 (if (or (pyclass? obj) (pytype? obj))
967 cl
968 (let ((c (make-p <p>))
969 (o (make-p <p>)))
970 (set c '__super__ #t)
971 (set c '__mro__ parents)
972 (set c '__getattribute__ (lambda (self key . l)
973 (aif it (ref c key)
974 (if (procedure? it)
975 (if (eq? (procedure-property
976 it
977 'py-special)
978 'class)
979 (it cl)
980 (it obj))
981 it)
982 (error "no attribute"))))
983 (set o '__class__ c)
984 o)))
985
986 (call-with-values
987 (lambda ()
988 (let lp ((l (ref (if (or (pytype? obj) (pyclass? obj))
989 obj
990 (ref obj '__class__))
991 '__mro__ '())))
992 (if (pair? l)
993 (if (eq? class (car l))
994 (let ((r (cdr l)))
995 (if (pair? r)
996 (values (car r) r)
997 (values #f #f)))
998 (lp (cdr l)))
999 (values #f #f))))
1000 make))
1001
1002
1003
1004 (define-syntax py-super-mac
1005 (syntax-rules ()
1006 ((_)
1007 (py-super *class* *self*))
1008 ((_ class self)
1009 (py-super class self))))
1010
1011 (define (pp x)
1012 (pretty-print (syntax->datum x))
1013 x)
1014
1015 (define-syntax letruc
1016 (lambda (x)
1017 (syntax-case x ()
1018 ((_ ((x v) ...) code ...)
1019 (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
1020 (if (pair? a)
1021 (let* ((x (car a))
1022 (s (syntax->datum x)))
1023 (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
1024 (r (list (car b))))
1025 (if (pair? a2)
1026 (if (eq? (syntax->datum a2) s)
1027 (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
1028 (lp2 (cdr a2) (cdr b2)
1029 (cons (car a2) a3)
1030 (cons (car b2) b3)
1031 r))
1032 (lp (reverse a3) (reverse b3)
1033 (cons
1034 (list x #`(let* #,(map (lambda (v) (list x v))
1035 (reverse r)) #,x))
1036 u)))))
1037 #`(letrec #,(reverse u) code ...)))))))
1038
1039
1040
1041
1042 (define-method (py-init (o <p>) . l)
1043 (apply (ref o '__init__) l))
1044
1045 (define mk-tree
1046 (case-lambda
1047 ((root)
1048 (vector root '()))
1049 ((root hist) (vector root hist))))
1050
1051 (define (geth t) (vector-ref t 1))
1052 (define (getr t) (vector-ref t 0))
1053 (define (tree-ref t) (car (getr t)))
1054
1055 (define (nxt tree)
1056 (define (dive r h)
1057 (let ((x (car r)))
1058 (if (pair? x)
1059 (dive (car r) (cons (cdr r) h))
1060 (mk-tree r h))))
1061
1062 (define (up r h)
1063 (if (null? r)
1064 (if (pair? h)
1065 (up (car h) (cdr h))
1066 #f)
1067 (let ((x (car r)))
1068 (if (pair? x)
1069 (dive r h)
1070 (mk-tree r h)))))
1071
1072 (let ((r (getr tree)) (h (geth tree)))
1073 (cond
1074 ((pair? r)
1075 (let ((r (cdr r)))
1076 (if (pair? r)
1077 (let ((x (car r)))
1078 (if (pair? x)
1079 (dive x (cons (cdr r) h))
1080 (mk-tree r h)))
1081 (if (pair? h)
1082 (up (car h) (cdr h))
1083 #f))))
1084 (else
1085 (if (pair? h)
1086 (up (car h) (cdr h))
1087 #f)))))
1088
1089 (define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__bases__))))
1090
1091 (define (find-tree o tree)
1092 (if tree
1093 (let ((x (tree-ref tree)))
1094 (if (eq? o x)
1095 #t
1096 (find-tree o (nxt tree))))
1097 #f))
1098
1099 (define (get-mro parents)
1100 (if (null? parents)
1101 parents
1102 (get-mro0 parents)))
1103
1104 (define (get-mro0 parents)
1105 (define tree (mk-tree parents))
1106 (let lp ((tree tree) (r '()))
1107 (if tree
1108 (let ((x (tree-ref tree))
1109 (n (nxt tree)))
1110 (if (find-tree x n)
1111 (lp n r)
1112 (lp n (cons x r))))
1113 (reverse r))))
1114
1115 (define-method (py-equal? (x <p>) y)
1116 (aif it (ref x '__eq__)
1117 (it y)
1118 (next-method)))
1119
1120 (define-method (py-equal? y (x <p>))
1121 (aif it (ref x '__eq__)
1122 (it y)
1123 (next-method)))
1124
1125 (define-method (py-equal? x y) ((@ (guile) equal?) x y))
1126
1127 (define (equal? x y) (or (eq? x y) (py-equal? x y)))
1128
1129 (define (subclasses self)
1130 (aif it (ref self '__zubclasses__)
1131 (let ((h (make-hash-table)))
1132 (let lp0 ((it it))
1133 (let lp ((l (hash-fold
1134 (lambda (k v s)
1135 (hash-set! h k #t)
1136 (cons k s))
1137 '() it)))
1138 (if (pair? l)
1139 (begin
1140 (lp0 (car l))
1141 (lp (cdr l))))))
1142
1143 (hash-fold (lambda (k v s) (cons k s)) '() h))
1144 '()))
1145
1146 (set! type
1147 (make-python-class type ()
1148 (define __new__ new-class0)
1149 (define __init_subclass__ (lambda x (values)))
1150 (define ___zub_classes__ (make-weak-key-hash-table))
1151 (define __subclasses__ subclasses)
1152 (define __call__
1153 (case-lambda
1154 ((meta obj)
1155 (ref obj '__class__ 'None))
1156 ((meta name bases dict . keys)
1157 (type- meta name bases dict keys))))))
1158 (set type '__class__ type)
1159
1160 (set! object (make-python-class object ()
1161 (define __subclasses__ subclasses)
1162 (define __weakref__ (lambda (self) self))))
1163
1164 (name-object type)
1165 (name-object object)