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