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