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