1 (define-module (oop pf-objects
)
2 #:use-module
(oop goops
)
3 #:use-module
(ice-9 vlist
)
4 #:use-module
(ice-9 match
)
5 #:export
(set ref make-pf
<p
> <py
> <pf
> <pyf
>
6 call with copy fset fcall make-p put put
!
7 pcall pcall
! get fset-x
8 def-pf-class mk-pf-class make-pf-class
9 def-p-class mk-p-class make-p-class
10 def-pyf-class mk-pyf-class make-pyf-class
11 def-py-class mk-py-class make-py-class
12 define-python-class get-type
15 Python object system is basically syntactic suger otop of a hashmap and one
16 this project is inspired by the python object system and what it measn when
17 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
18 with assocs or tree like functional hashmaps in stead.
20 The hashmap works like an assoc e.g. we will define new values by
'consing
' a
21 new binding on the list and when the assoc take up too much space it will be
22 reshaped and all extra bindings will be removed.
24 The datastructure is functional but the objects mutate. So one need to
25 explicitly tell it to not update etc.
28 (define-syntax-rule (aif it p x y
) (let ((it p
)) (if it x y
)))
29 (define-class <p
> (<applicable-struct
>) h
)
30 (define-class <pf
> (<p
>) size n
) ; the pf object consist of a functional
31 ; hashmap it's size and number of live
33 (define-class <py
> (<p
>))
34 (define-class <pyf
> (<pf
>))
37 (letrec ((o (make (ref x
'__goops__
))))
38 (slot-set! o
'procedure
41 (ref o
'__call__
(lambda x
(error "no __call__ method")))
45 (let ((r (ref x
'__const__
)))
46 (slot-set! o
'h
(slot-ref r
'h
))
47 (slot-set! o
'size
(slot-ref r
'size
))
48 (slot-set! o
'n
(slot-ref r
'n
))
52 (let ((r (ref x
'__const__
))
53 (h (make-hash-table)))
54 (hash-set! h
'__class__ x
)
58 (define (make-pyclass x
)
59 (letrec ((class (make x
)))
60 (slot-set! class
'procedure
62 (let ((obj (mk class
)))
63 (aif it
(ref obj
'__init__
)
69 ;; Make an empty pf object
71 (define r
(make-pyclass <pf
>))
72 (slot-set! r
'h vlist-null
)
78 (define r
(make-pyclass <p
>))
79 (slot-set! r
'h
(make-hash-table))
82 (define-syntax-rule (hif it
(k h
) x y
)
83 (let ((a (vhash-assq k h
)))
89 (define-syntax-rule (cif (it h
) (k cl
) x y
)
90 (let* ((h (slot-ref cl
'h
))
97 (define fail
(cons 'fail
'()))
98 (define-syntax-rule (mrefx x key l
)
111 (hif it
('__parents__ h
)
112 (let ((r (parents it
)))
121 (hif cl
('__class__ h
)
124 (hif p
('__parents__ h
)
125 (let ((r (parents p
)))
132 (define-syntax-rule (mrefx- x key l
) (mrefx-- (slot-ref x
'h
) key l
))
133 (define-syntax-rule (mrefx-- hi key l
)
135 (define (end) (if (pair? l
) (car l
) #f
))
136 (define (ret q
) (if (eq? q fail
) (end) q
))
138 (define (find-in-class h
)
139 (let lp
((class-h h
))
140 (let ((r (hash-ref class-h key fail
)))
142 (aif parents
(hash-ref class-h
'__parents__
#f
)
143 (let lpp
((parents parents
))
145 (let ((parent (car parents
)))
146 (let ((r (lp (slot-ref parent
'h
))))
155 (r (hash-ref h key fail
)))
157 (aif class
(hash-ref h
'__class__
)
158 (ret (find-in-class (slot-ref class
'h
)))
162 (define not-implemented
(cons 'not
'implemeneted
))
164 (define-syntax-rule (mrefx-py- x key l
)
165 (let ((f (mrefx- x
'__ref__
'())))
166 (if (or (not f
) (eq? f not-implemented
))
170 (define-syntax-rule (mrefx-py x key l
)
171 (let ((f (mrefx x
'__ref__
'())))
172 (if (or (not f
) (eq? f not-implemented
))
176 (define-syntax-rule (unx mrefx- mref-
)
177 (define-syntax-rule (mref- x key l
)
179 (let ((res (mrefx- xx key l
)))
187 (unx mrefx-py mref-py
)
188 (unx mrefx-py- mref-py-
)
190 (define-method (ref (x <pf
> ) key . l
) (mref x key l
))
191 (define-method (ref (x <p
> ) key . l
) (mref- x key l
))
192 (define-method (ref (x <pyf
>) key . l
) (mref-py x key l
))
193 (define-method (ref (x <py
> ) key . l
) (mref-py- x key l
))
195 ;; the reshape function that will create a fresh new pf object with less size
196 ;; this is an expensive operation and will only be done when we now there is
197 ;; a lot to gain essentially tho complexity is as in the number of set
199 (let ((h (slot-ref x
'h
))
200 (m (make-hash-table))
202 (define h2
(vhash-fold (lambda (k v s
)
203 (if (hash-ref m k
#f
)
208 (vhash-consq k v s
))))
212 (slot-set! x
'size n
)
216 ;; on object x add a binding that key -> val
217 (define-syntax-rule (mset x key val
)
218 (let ((h (slot-ref x
'h
))
219 (s (slot-ref x
'size
))
221 (slot-set! x
'size
(+ 1 s
))
222 (let ((r (vhash-assq key h
)))
224 (slot-set! x
'n
(+ n
1)))
225 (slot-set! x
'h
(vhash-consq key val h
))
230 (define-syntax-rule (mset-py x key val
)
231 (let ((f (mref-py x
'__set__
'())))
232 (if (or (eq? f not-implemented
) (not f
))
236 (define (pkh h
) (hash-for-each (lambda x
(pk x
)) h
) h
)
238 (define-syntax-rule (mset- x key val
)
240 (define (s h
) (begin (hash-set! h key val
) #f
))
242 (define (r h k
) (hash-ref h k
))
243 (define-syntax-rule (ifh h fail-code
)
248 (define (hm x
) (slot-ref x
'h
))
251 (aif it
(r h
'__class__
)
255 (aif it
(r h
'__parents__
)
256 (let lp2
((parents it
))
258 (if (lp (car parents
))
267 (define-syntax-rule (mset-py- x key val
)
268 (let ((f (mref-py- x
'__set__
'())))
269 (if (or (eq? f not-implemented
) (not f
))
273 (define-method (set (x <pf
>) key val
) (mset x key val
))
274 (define-method (set (x <p
>) key val
) (mset- x key val
))
275 (define-method (set (x <pyf
>) key val
) (mset-py x key val
))
276 (define-method (set (x <py
>) key val
) (mset-py- x key val
))
278 ;; mref will reference the value of the key in the object x, an extra default
279 ;; parameter will tell what the fail object is else #f if fail
280 ;; if there is no found binding in the object search the class and
281 ;; the super classes for a binding
283 ;; call a function as a value of key in x with the object otself as a first
284 ;; parameter, this is pythonic object semantics
285 (define-syntax-rule (mk-call mcall mref
)
286 (define-syntax-rule (mcall x key l
)
287 (apply (mref x key
'()) l
)))
290 (mk-call mcall- mref-
)
291 (mk-call mcall-py mref-py
)
292 (mk-call mcall-py- mref-py-
)
294 (define-method (call (x <pf
>) key . l
) (mcall x key l
))
295 (define-method (call (x <p
>) key . l
) (mcall- x key l
))
296 (define-method (call (x <pyf
>) key . l
) (mcall-py x key l
))
297 (define-method (call (x <py
>) key . l
) (mcall-py- x key l
))
300 ;; make a copy of a pf object
301 (define-syntax-rule (mcopy x
)
302 (let ((r (make-pyclass <pf
>)))
303 (slot-set! r
'h
(slot-ref x
'h
))
304 (slot-set! r
'size
(slot-ref x
'size
))
305 (slot-set! r
'n
(slot-ref x
'n
))
308 (define-syntax-rule (mcopy- x
)
311 (hash-for-each (lambda (k v
) (hash-set! h k v
)) (slot-ref x
'h
))
314 (define-method (copy (x <pf
>)) (mcopy x
))
315 (define-method (copy (x <p
> )) (mcopy- x
))
318 ;; with will execute thunk and restor x to it's initial state after it has
319 ;; finished note that this is a cheap operatoin because we use a functional
321 (define-syntax-rule (mwith x thunk
)
322 (let ((old (mcopy x
)))
324 (slot-set! x
'h
(slot-ref old
'h
))
325 (slot-set! x
'size
(slot-ref old
'size
))
326 (slot-set! x
'n
(slot-ref old
'n
))
329 (define-syntax-rule (mwith- x thunk
)
330 (let ((old (mcopy- x
)))
332 (slot-set! x
'h
(slot-ref old
'h
))
337 ;; a functional set will return a new object with the added binding and keep
339 (define-method (fset (x <pf
>) key val
)
344 (define-method (fset (x <p
>) key val
)
345 (let ((x (mcopy- x
)))
349 (define (fset-x obj l val
)
350 (let lp
((obj obj
) (l l
) (r '()))
353 (let lp
((v val
) (r r
))
355 (lp (fset (caar r
) (cdar r
) v
) (cdr r
))
358 (lp (ref obj k
#f
) l
(cons (cons obj k
) r
))))))
364 ;; a functional call will keep x untouched and return (values fknval newx)
365 ;; e.g. we get both the value of the call and the new version of x with
366 ;; perhaps new bindings added
367 (define-method (fcall (x <pf
>) key . l
)
370 (if (eq?
(slot-ref x
'h
) (slot-ref y
'h
))
374 (define-method (fcall (x <p
>) key . l
)
376 (values (mcall- x key l
)
379 ;; this shows how we can override addition in a pythonic way
380 (define-syntax-rule (mk-arith + +x __add__ __radd__
)
382 (define-method (+ (x <p
>) y
)
385 (define-method (+ x
(y <p
>))
386 (call y
'__radd__ x
))
388 (define-method (+ (x <py
>) y
)
389 (let ((f (mref-py- x
'__add__
'())))
394 (define-method (+ (x <pyf
>) y
)
395 (let ((f (mref-py x
'__add__
'())))
398 (if (eq? res not-implemented
)
403 (define-method (+ (x <py
>) y
)
404 (let ((f (mref-py- x
'__add__
'())))
407 (if (eq? res not-implemented
)
412 (define-method (+ x
(y <py
>))
413 (call y
'__radd__ x
))
415 (define-method (+ x
(y <pyf
>))
416 (call y
'__radd__ x
))
418 (define-method (+x
(x <p
>) y
)
419 (call x
'__radd__ y
))))
421 ;; A few arithmetic operations at service
422 (mk-arith + +x __add__ __radd__
)
423 (mk-arith - -x __sub__ __rsub__
)
424 (mk-arith * *x __mul__ __rmul__
)
426 ;; lets define get put pcall etc so that we can refer to an object like
427 ;; e.g. (put x.y.z 1) (pcall x.y 1)
429 (define-syntax-rule (cross x k f set
)
430 (call-with-values (lambda () f
)
434 (values r
(set x k y
))))))
436 (define-syntax-rule (cross! x k f _
) f
)
440 ((_ cross set setx f
(key) (val ...
))
441 (setx f key val ...
))
442 ((_ cross set setx f
(k . l
) val
)
443 (cross f k
(mku cross set setx
(ref f k
) l val
) set
))))
445 (define-syntax-rule (mkk pset setx set cross
)
450 (let* ((to (lambda (x)
451 (datum->syntax
#'f
(string->symbol x
))))
452 (l (string-split (symbol->string
(syntax->datum
#'f
)) #\.
)))
453 (with-syntax (((a (... ...
)) (map (lambda (x) #`'#,(to x
))
456 #'(mku cross setx set h
(a (... ...
)) (val (... ...
))))))))))
458 (mkk put fset fset cross
)
459 (mkk put
! set set cross
!)
460 (mkk pcall
! call fset cross
!)
461 (mkk pcall fcall fset cross
)
462 (mkk get ref fset cross
!)
464 ;; it's good to have a null object so we don't need to construct it all the
465 ;; time because it is functional we can get away with this.
466 (define null
(make-pf))
468 ;; append the bindings in x in front of y + some optimizations
470 (define hx
(slot-ref x
'h
))
471 (define hy
(slot-ref y
'h
))
472 (define n
(slot-ref x
'n
))
473 (define s
(slot-ref x
'size
))
474 (define m
(make-hash-table))
479 (if (vhash-assq k hy
)
482 (vhash-consq k v st
))
489 (vhash-consq k v st
)))))
493 (define out
(make-pyclass <pf
>))
496 (slot-set! out
'size s
)
500 (define hx
(slot-ref x
'h
))
501 (define hy
(slot-ref y
'h
))
502 (define out
(make-p))
503 (define h
(slot-ref out
'h
))
504 (hash-for-each (lambda (k v
) (hash-set! h k v
)) hy
)
505 (hash-for-each (lambda (k v
) (hash-set! h k v
)) hx
)
509 ;; make a class. A class add some meta information to allow for multiple
510 ;; inherritance and add effectively static data to the object the functional
511 ;; datastructure show it's effeciency now const is data that will not change
512 ;; and bindings that are added to all objects. Dynamic is the mutating class
513 ;; information. supers is a list of priorities
514 (define-syntax-rule (mk-pf make-pf-class
<pf
>)
515 (define-syntax make-pf-class
518 ((_ name const dynamic
(supers (... ...
)))
519 (with-syntax (((sups (... ...
)) (generate-temporaries
520 #'(supers (... ...
)))))
521 #'(let ((sups supers
) (... ...
))
522 (define class dynamic
)
523 (define name
(make-class (list sups
(... ...
) <pf
>) '()))
527 (let lp
((sup (list sups
(... ...
))))
529 (union (ref (car sup
) '__const__ null
)
534 (set class
'__const__ __const__
)
535 (set class
'__goops__ name
)
536 (set class
'__name__
'name
)
537 (set class
'__parents__
(list sups
(... ...
)))
539 (set __const__
'__name__
'name
)
540 (set __const__
'__class__ class
)
541 (set __const__
'__parents__
(list sups
(... ...
)))
542 (set __const__
'__goops__ name
)
545 (mk-pf make-pf-class
<pf
>)
546 (mk-pf make-pyf-class
<pyf
>)
548 (define-syntax-rule (mk-p make-p-class
<p
>)
549 (define-syntax make-p-class
552 ((_ name const dynamic
(supers (... ...
)))
553 (with-syntax (((sups (... ...
)) (generate-temporaries
554 #'(supers (... ...
)))))
555 #'(let ((sups supers
) (... ...
))
556 (define class dynamic
)
557 (define name
(make-class (list (ref sups
'__goops__
#f
)
562 (let lp
((sup (list sups
(... ...
))))
569 (set class
'__goops__ name
)
570 (set class
'__name__
'name
)
571 (set class
'__parents__
(list sups
(... ...
)))
575 (mk-p make-p-class
<p
>)
576 (mk-p make-py-class
<py
>)
578 ;; Let's make an object essentially just move a reference
580 ;; the make class and defclass syntactic sugar
581 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class
)
582 (define-syntax-rule (mk-pf-class name
(parents (... ...
))
584 ((sdef mname sval
) (... ...
))
586 ((ddef dname dval
) (... ...
)))
591 (set s
'mname sval
) (... ...
)
594 (set d
'dname dval
) (... ...
)
596 (parents (... ...
))))
599 (mk-p/f make-pf mk-pf-class make-pf-class
)
600 (mk-p/f make-p mk-p-class make-p-class
)
601 (mk-p/f make-pf mk-pyf-class make-pyf-class
)
602 (mk-p/f make-p mk-py-class make-py-class
)
604 (define-syntax-rule (def-pf-class name . l
)
605 (define name
(mk-pf-class name . l
)))
607 (define-syntax-rule (def-p-class name . l
)
608 (define name
(mk-p-class name . l
)))
610 (define-syntax-rule (def-pyf-class name . l
)
611 (define name
(mk-pyf-class name . l
)))
613 (define-syntax-rule (def-py-class name . l
)
614 (define name
(mk-py-class name . l
)))
616 (define (get-class o
)
621 (error "not a pyclass"))))
637 (define p1
(if (pyclass? o
) "Class" "Object"))
638 (define p2
(if (pyclass? o
) "Class" "Object"))
639 (define port
(if (pair? l
) (car l
) #t
))
641 (aif it
(ref o
'__repr__
#f
)
643 #f
"~a(~a)<~a>" p1
(get-type o
) (it))
645 #f
"~a(~a)<~a>" p2
(get-type o
) (ref o
'__name__
'None
)))))
647 (define-method (write (o <p
>) . l
) (print o l
))
648 (define-method (display (o <p
>) . l
) (print o l
))
650 (define-syntax-rule (define-python-class name parents code ...
)
652 (mk-py-class name parents
659 (and (is-a? x
<p
>) (not (ref x
'__class__
))))