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