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