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