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