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