summaryrefslogtreecommitdiff
path: root/modules/oop/pf-objects.scm.bak
diff options
context:
space:
mode:
Diffstat (limited to 'modules/oop/pf-objects.scm.bak')
-rw-r--r--modules/oop/pf-objects.scm.bak1072
1 files changed, 0 insertions, 1072 deletions
diff --git a/modules/oop/pf-objects.scm.bak b/modules/oop/pf-objects.scm.bak
deleted file mode 100644
index 8946c59..0000000
--- a/modules/oop/pf-objects.scm.bak
+++ /dev/null
@@ -1,1072 +0,0 @@
-(define-module (oop pf-objects)
- #:use-module (oop goops)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 match)
-<<<<<<< HEAD
- #:use-module (system base message)
- #:use-module (language python guilemod)
-=======
- #:use-module (ice-9 pretty-print)
->>>>>>> d71244f5cb87a4a61a6b341e4838a38e50142815
- #:use-module (logic guile-log persistance)
- #:replace (equal?)
- #:export (set ref make-p <p> <py> <pf> <pyf> <property>
- call with copy fset fcall put put!
- pcall pcall! get fset-x pyclass?
- def-p-class mk-p-class make-p-class
- define-python-class get-type py-class
- object-method class-method static-method
- py-super-mac py-super py-equal?
- *class* *self* pyobject? pytype?
- type object pylist-set! pylist-ref tr
- resolve-method rawref rawset
- ))
-
-#|
-Python object system is basically syntactic suger otop of a hashmap and one
-this project is inspired by the python object system and what it measn when
-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
-with assocs or tree like functional hashmaps in stead.
-
-The hashmap works like an assoc e.g. we will define new values by 'consing' a
-new binding on the list and when the assoc take up too much space it will be
-reshaped and all extra bindings will be removed.
-
-The datastructure is functional but the objects mutate. So one need to
-explicitly tell it to not update etc.
-|#
-
-(define fail (cons 'fail '()))
-
-(define-syntax-rule (kif it p x y)
- (let ((it p))
- (if (eq? it fail)
- y
- x)))
-
-(define-method (pylist-set! (o <hashtable>) key val)
- (hash-set! o key val))
-
-(define-method (pylist-ref (o <hashtable>) key)
- (kif it (hash-ref o key fail)
- it
- (error "IndexError")))
-
-(define (is-acl? a b) (member a (cons b (class-subclasses b))))
-
-(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
-(define-class <p> (<applicable-struct> <object>) h)
-(define-class <pf> (<p>) size n) ; the pf object consist of a functional
- ; hashmap it's size and number of live
- ; object
-(define-class <py> (<p>))
-(define-class <pyf> (<pf>))
-
-(define-class <property> () get set del)
-
-(name-object <p>)
-(name-object <pf>)
-(name-object <py>)
-(name-object <pyf>)
-(name-object <property>)
-
-(define (resolve-method-g g pattern)
- (define (mmatch p pp)
- (if (eq? pp '_)
- '()
- (match (cons p pp)
- (((p . ps) . (pp . pps))
- (if (eq? pp '_)
- (mmatch ps pps)
- (if (is-a? p pp)
- (cons p (mmatch ps pps))
- #f)))
- ((() . ())
- '())
- (_
- #f))))
-
- (define (q< x y)
- (let lp ((x x) (y y))
- (match (cons x y)
- (((x . xs) . (y . ys))
- (and (is-a? x y)
- (lp xs ys)))
- (_ #t))))
-
- (let ((l
- (let lp ((ms (generic-function-methods g)))
- (if (pair? ms)
- (let* ((m (car ms))
- (p (method-specializers m))
- (f (method-generic-function m)))
- (aif it (mmatch p pattern)
- (cons (cons it f) (lp (cdr ms)))
- (lp (cdr ms))))
- '()))))
-
-
- (cdr (car (sort l q<)))))
-
-(define (resolve-method-o o pattern)
- (resolve-method-g (class-of o) pattern))
-
-(define (get-dict self name parents)
- (aif it (ref self '__prepare__)
- (it self name parents)
- (make-hash-table)))
-
-(define (hashforeach a b) (values))
-
-(define (new-class meta name parents dict kw)
- (aif it (ref meta '__new__)
- (apply it name parents dict kw)
- (let* ((goops (pylist-ref dict '__goops__))
- (p (kwclass->class kw meta))
- (class (make-p p)))
- (slot-set! class 'procedure
- (lambda x
- (create-object class meta goops x)))
- (if (hash-table? dict)
- (hash-for-each
- (lambda (k v) k (set class k v))
- dict)
- (hashforeach
- (lambda (k v) k (set class k v))
- dict))
- (let((mro (ref class '__mro__)))
- (if (pair? mro)
- (let ((p (car mro)))
- (aif it (ref p '__init_subclass__)
- (apply it class #f kw)
- #f))))
- (set class '__mro__ (cons class (ref class '__mro__)))
- class)))
-
-(define (type- meta name parents dict keys)
- (let ((class (new-class meta name parents dict keys)))
- (aif it (ref meta '__init__)
- (it name parents dict keys)
- #f)
- class))
-
-(define (create-class meta name parents gen-methods . keys)
- (let ((dict (gen-methods (get-dict meta name keys))))
- (aif it (ref meta '__class__)
- (aif it (find-in-class (ref meta '__class__) '__call__ #f)
- (apply (it meta 'class) name parents dict keys)
- (type- meta name parents dict keys))
- (type- meta name parents dict keys))))
-
-(define (create-object class meta goops x)
- (with-fluids ((*make-class* #t))
- (aif it #f ;(ref meta '__call__)
- (apply it x)
- (let ((obj (aif it (find-in-class class '__new__ #f)
- ((it class 'object))
- (make-object class meta goops))))
- (aif it (ref obj '__init__)
- (apply it x)
- #f)
- (slot-set! obj 'procedure
- (lambda x
- (aif it (ref obj '__call__)
- (apply it x)
- (error "not a callable object"))))
- obj))))
-
-(define (make-object class meta goops)
- (let ((obj (make-p goops)))
- (set obj '__class__ class)
- obj))
-
-;; Make an empty pf object
-(define (make-p <x>)
- (let ((r (make <x>)))
- (cond
- ((is-a? r <pf>)
- (slot-set! r 'h vlist-null)
- (slot-set! r 'size 0)
- (slot-set! r 'n 0))
- ((is-a? r <p>)
- (slot-set! r 'h (make-hash-table)))
- (else
- (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
- r)))
- r))
-
-
-(define-syntax-rule (hif it (k h) x y)
- (let ((a (vhash-assq k h)))
- (if (pair? a)
- (let ((it (cdr a)))
- x)
- y)))
-
-(define-syntax-rule (cif (it h) (k cl) x y)
- (let* ((h (slot-ref cl 'h))
- (a (vhash-assq k h)))
- (if (pair? a)
- (let ((it (cdr a)))
- x)
- y)))
-
-(define-syntax-rule (mrefx x key l)
- (let ()
- (define (end)
- (if (null? l)
- #f
- (car l)))
-
- (define (parents li)
- (let lp ((li li))
- (if (pair? li)
- (let ((p (car li)))
- (cif (it h) (key p)
- it
- (lp (cdr li))))
- fail)))
-
- (cif (it h) (key x)
- it
- (hif cl ('__class__ h)
- (cif (it h) (key cl)
- it
- (hif p ('__mro__ h)
- (let ((r (parents p)))
- (if (eq? r fail)
- (end)
- r))
- (end)))
- (end)))))
-
-(define *refkind* (make-fluid 'object))
-
-(define-method (find-in-class (klass <p>) key fail)
- (hash-ref (slot-ref klass 'h) key fail))
-
-(define-method (find-in-class (klass <pf>) key fail)
- (let ((r (vhash-assoc key (slot-ref klass 'h))))
- (if r
- (cdr r)
- fail)))
-
-(define-syntax-rule (find-in-class-and-parents klass key fail)
- (kif r (find-in-class klass key fail)
- r
- (aif parents (find-in-class klass '__mro__ #f)
- (let lp ((parents parents))
- (if (pair? parents)
- (kif r (find-in-class (car parents) key fail)
- r
- (lp (cdr parents)))
- fail))
- fail)))
-
-(define-syntax-rule (mrefx klass key l)
- (let ()
- (define (end) (if (pair? l) (car l) #f))
- (fluid-set! *refkind* 'object)
- (kif it (find-in-class klass key fail)
- it
- (begin
- (fluid-set! *refkind* 'class)
- (aif klass (find-in-class klass '__class__ #f)
- (kif it (find-in-class-and-parents klass key fail)
- it
- (end))
- (end))))))
-
-(define not-implemented (cons 'not 'implemeneted))
-
-(define-syntax-rule (prop-ref xx x)
- (let ((y xx)
- (r x))
- (if (and (is-a? r <property>) (not (pyclass? y)))
- ((slot-ref r 'get) y)
- r)))
-
-(define-syntax-rule (mrefx-py x key l)
- (let ((xx x))
- (prop-ref
- xx
- (let* ((g (mrefx xx '__fget__ '(#t)))
- (f (if g
- (if (eq? g #t)
- (aif it (mrefx xx '__getattribute__ '())
- (begin
- (mset xx '__fget__ it it)
- it)
- (begin
- (if (mc?)
- (mset xx '__fget__ it it))
- #f))
- g)
- #f)))
- (if (or (not f) (eq? f not-implemented))
- (mrefx xx key l)
- (catch #t
- (lambda () ((f xx (fluid-ref *refkind*)) key))
- (lambda x
- (mrefx xx key l))))))))
-
-
-(define-syntax-rule (mref x key l)
- (let ((xx x))
- (let ((res (mrefx xx key l)))
- (if (and (not (struct? res)) (procedure? res))
- (res xx (fluid-ref *refkind*))
- res))))
-
-(define-syntax-rule (mref-py x key l)
- (let ((xx x))
- (let ((res (mrefx-py xx key l)))
- (if (and (not (struct? res)) (procedure? res))
- (res xx (fluid-ref *refkind*))
- res))))
-
-(define-method (ref x key . l) (if (pair? l) (car l) #f))
-(define-method (ref (x <pf> ) key . l) (mref x key l))
-(define-method (ref (x <p> ) key . l) (mref x key l))
-(define-method (ref (x <pyf>) key . l) (mref-py x key l))
-(define-method (ref (x <py> ) key . l) (mref-py x key l))
-
-(define-method (rawref (x <pf> ) key . l) (mref x key l))
-(define-method (rawref (x <p> ) key . l) (mref x key l))
-
-
-(define-method (set (f <procedure>) key val)
- (set-procedure-property! f key val))
-
-(define-method (ref (f <procedure>) key . l)
- (aif it (assoc key (procedure-properties f))
- (cdr it)
- (if (pair? l) (car l) #f)))
-
-
-;; the reshape function that will create a fresh new pf object with less size
-;; this is an expensive operation and will only be done when we now there is
-;; a lot to gain essentially tho complexity is as in the number of set
-(define (reshape x)
- (let ((h (slot-ref x 'h))
- (m (make-hash-table))
- (n 0))
- (define h2 (vhash-fold (lambda (k v s)
- (if (hash-ref m k #f)
- s
- (begin
- (hash-set! m k #t)
- (set! n (+ n 1))
- (vhash-consq k v s))))
- vlist-null
- h))
- (slot-set! x 'h h2)
- (slot-set! x 'size n)
- (slot-set! x 'n n)
- (values)))
-
-;; on object x add a binding that key -> val
-(define-method (mset (x <pf>) key rval val)
- (let ((h (slot-ref x 'h))
- (s (slot-ref x 'size))
- (n (slot-ref x 'n)))
- (slot-set! x 'size (+ 1 s))
- (let ((r (vhash-assoc key h)))
- (when (not r)
- (slot-set! x 'n (+ n 1)))
- (slot-set! x 'h (vhash-cons key val h))
- (when (> s (* 2 n))
- (reshape x))
- (values))))
-
-(define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
-
-(define-method (mset (x <p>) key rval val)
- (begin
- (hash-set! (slot-ref x 'h) key val)
- (values)))
-
-(define *make-class* (make-fluid #f))
-(define (mc?) (not (fluid-ref *make-class*)))
-
-(define-syntax-rule (mset-py x key rval val)
- (let* ((xx x)
- (v (mref xx key (list fail))))
- (if (or (eq? v fail)
- (not (and (is-a? v <property>)
- (not (pyclass? xx)))))
- (let* ((g (mrefx xx '__fset__ '(#t)))
- (f (if g
- (if (eq? g #t)
- (aif it (mrefx xx '__setattr__ '())
- (begin
- (mset xx '__fset__ it it)
- it)
- (begin
- (if (mc?)
- (mset xx '__fset__ it it))
- #f))
- g)
- #f)))
- (if (or (eq? f not-implemented) (not f))
- (mset xx key val val)
- (catch #t
- (lambda () ((f xx (fluid-ref *refkind*)) key rval))
- (lambda x (mset xx key val val)))))
- ((slot-ref v 'set) xx val))))
-
-(define-syntax-rule (mklam (mset a ...) val)
- (if (and (procedure? val)
- (not (pyclass? val))
- (not (pytype? val))
- (if (is-a? val <p>)
- (ref val '__call__)
- #t))
- (if (procedure-property val 'py-special)
- (mset a ... val val)
- (mset a ... val (object-method val)))
- (mset a ... val val)))
-
-(define-method (set (x <pf>) key val) (mklam (mset x key) val))
-(define-method (set (x <p>) key val) (mklam (mset x key) val))
-(define-method (set (x <pyf>) key val) (mklam (mset-py x key) val))
-(define-method (set (x <py>) key val) (mklam (mset-py x key) val))
-
-(define-method (rawset (x <pf>) key val) (mklam (mset x key) val))
-(define-method (rawset (x <p>) key val) (mklam (mset x key) val))
-
-;; mref will reference the value of the key in the object x, an extra default
-;; parameter will tell what the fail object is else #f if fail
-;; if there is no found binding in the object search the class and
-;; the super classes for a binding
-
-;; call a function as a value of key in x with the object otself as a first
-;; parameter, this is pythonic object semantics
-(define-syntax-rule (mk-call mcall mref)
- (define-syntax-rule (mcall x key l)
- (apply (mref x key '()) l)))
-
-(mk-call mcall mref)
-(mk-call mcall-py mref-py)
-
-(define-method (call (x <pf>) key . l) (mcall x key l))
-(define-method (call (x <p>) key . l) (mcall x key l))
-(define-method (call (x <pyf>) key . l) (mcall-py x key l))
-(define-method (call (x <py>) key . l) (mcall-py x key l))
-
-
-;; make a copy of a pf object
-(define-syntax-rule (mcopy x)
- (let ((r (make-p (ref x '__goops__))))
- (slot-set! r 'h (slot-ref x 'h))
- (slot-set! r 'size (slot-ref x 'size))
- (slot-set! r 'n (slot-ref x 'n))
- r))
-
-(define-syntax-rule (mcopy- x)
- (let* ((r (make-p (ref x '__goops__)))
- (h (slot-ref r 'h)))
- (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
- r))
-
-(define-method (copy (x <pf>)) (mcopy x))
-(define-method (copy (x <p> )) (mcopy- x))
-
-;; make a copy of a pf object
-(define-syntax-rule (mtr r x)
- (begin
- (slot-set! r 'h (slot-ref x 'h ))
- (slot-set! r 'size (slot-ref x 'size))
- (slot-set! r 'n (slot-ref x 'n ))
- (values)))
-
-(define-syntax-rule (mtr- r x)
- (begin
- (slot-set! r 'h (slot-ref x 'h))
- (values)))
-
-
-(define-method (tr (r <pf>) (x <pf>)) (mtr r x))
-(define-method (tr (r <p> ) (x <p> )) (mtr- r x))
-
-
-;; with will execute thunk and restor x to it's initial state after it has
-;; finished note that this is a cheap operatoin because we use a functional
-;; datastructure
-(define-syntax-rule (mwith x thunk)
- (let ((old (mcopy x)))
- (let ((r (thunk)))
- (slot-set! x 'h (slot-ref old 'h))
- (slot-set! x 'size (slot-ref old 'size))
- (slot-set! x 'n (slot-ref old 'n))
- r)))
-
-(define-syntax-rule (mwith- x thunk)
- (let ((old (mcopy- x)))
- (let ((r (thunk)))
- (slot-set! x 'h (slot-ref old 'h))
- r)))
-
-
-
-;; a functional set will return a new object with the added binding and keep
-;; x untouched
-(define-method (fset (x <pf>) key val)
- (let ((x (mcopy x)))
- (mset x key val val)
- x))
-
-(define-method (fset (x <p>) key val)
- (let ((x (mcopy- x)))
- (mset x key val val)
- x))
-
-(define (fset-x obj l val)
- (let lp ((obj obj) (l l) (r '()))
- (match l
- (()
- (let lp ((v val) (r r))
- (if (pair? r)
- (lp (fset (caar r) (cdar r) v) (cdr r))
- v)))
- ((k . l)
- (lp (ref obj k #f) l (cons (cons obj k) r))))))
-
-
-
-
-
-;; a functional call will keep x untouched and return (values fknval newx)
-;; e.g. we get both the value of the call and the new version of x with
-;; perhaps new bindings added
-(define-method (fcall (x <pf>) key . l)
- (let* ((y (mcopy x))
- (r (mcall y key l)))
- (if (eq? (slot-ref x 'h) (slot-ref y 'h))
- (values r x)
- (values r y))))
-
-(define-method (fcall (x <p>) key . l)
- (let ((x (mcopy x)))
- (values (mcall x key l)
- x)))
-
-;; this shows how we can override addition in a pythonic way
-
-;; lets define get put pcall etc so that we can refer to an object like
-;; e.g. (put x.y.z 1) (pcall x.y 1)
-
-(define-syntax-rule (cross x k f set)
- (call-with-values (lambda () f)
- (lambda (r y)
- (if (eq? x y)
- (values r x)
- (values r (set x k y))))))
-
-(define-syntax-rule (cross! x k f _) f)
-
-(define-syntax mku
- (syntax-rules ()
- ((_ cross set setx f (key) (val ...))
- (setx f key val ...))
- ((_ cross set setx f (k . l) val)
- (cross f k (mku cross set setx (ref f k) l val) set))))
-
-(define-syntax-rule (mkk pset setx set cross)
- (define-syntax pset
- (lambda (x)
- (syntax-case x ()
- ((_ f val (... ...))
- (let* ((to (lambda (x)
- (datum->syntax #'f (string->symbol x))))
- (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
- (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
- (cdr l)))
- (h (to (car l))))
- #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
-
-(mkk put fset fset cross)
-(mkk put! set set cross!)
-(mkk pcall! call fset cross!)
-(mkk pcall fcall fset cross)
-(mkk get ref fset cross!)
-
-;; it's good to have a null object so we don't need to construct it all the
-;; time because it is functional we can get away with this.
-(define null (make-p <pf>))
-
-(define (filter-parents l)
- (let lp ((l l))
- (if (pair? l)
- (if (is-a? (car l) <p>)
- (cons (car l) (lp (cdr l)))
- (lp (cdr l)))
- '())))
-
-(define (kw->class kw meta)
- (if (memq #:functional kw)
- (if (memq #:fast kw)
- <pf>
- (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
- <pyf>
- <pf>))
- (if (memq #:fast kw)
- (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
- <pf>
- <p>)
- (cond
- ((is-a? meta <pyf>)
- <pyf>)
- ((is-a? meta <py>)
- <py>)
- ((is-a? meta <pf>)
- <pf>)
- ((is-a? meta <p>)
- <p>)
- (else
- <py>)))))
-
-
-(define (defaulter d)
- (if d
- (cond
- ((is-a? d <pyf>)
- <pyf>)
- ((is-a? d <py>)
- <py>)
- ((is-a? d <pf>)
- <pf>)
- ((is-a? d <p>)
- <p>)
- (else
- d))
- <py>))
-
-(define (kwclass->class kw default)
- (if (memq #:functionalClass kw)
- (if (memq #:fastClass kw)
- <pf>
- (if (memq #:pyClass kw)
- <pyf>
- (if (or (is-a? default <py>) (is-a? default <pyf>))
- <pyf>
- <pf>)))
- (if (memq #:mutatingClass kw)
- (if (memq #:fastClass kw)
- <p>
- (if (memq #:pyClass kw)
- <py>
- (if (or (is-a? default <py>) (is-a? default <pyf>))
- <py>
- <p>)))
- (if (memq #:fastClass kw)
- (if (or (is-a? default <pf>) (is-a? default <pyf>))
- <pf>
- <p>)
- (if (memq #:pyClass kw)
- (if (or (is-a? default <pf>) (is-a? default <pyf>))
- <pyf>
- <py>)
- (defaulter default))))))
-
-(define object #f)
-(define (make-p-class name supers.kw methods)
- (define kw (cdr supers.kw))
- (define supers (car supers.kw))
- (define goopses (map (lambda (sups)
- (aif it (ref sups '__goops__ #f)
- it
- sups))
- supers))
- (define parents (let ((p (filter-parents supers)))
- (if (null? p)
- (if object
- (list object)
- '())
- p)))
-
- (define meta (aif it (memq #:metaclass kw)
- (car it)
- (if (null? parents)
- type
- (let* ((p (car parents))
- (m (ref p '__class__))
- (mro (reverse (ref m '__mro__))))
- (let lp ((l (cdr parents))
- (max mro)
- (min mro))
- (if (pair? l)
- (let* ((p (car l))
- (meta (ref p '__class__))
- (mro (ref meta '__mro__)))
- (let lp2 ((max max) (mr (reverse mro)))
- (if (and (pair? max) (pair? mr))
- (if (eq? (car max) (car mr))
- (lp2 (cdr max) (cdr mr))
- (error
- "need a common lead for meta"))
- (if (pair? max)
- (if (< (length mro) (length min))
- (lp (cdr l) max mro)
- (lp (cdr l) max min))
- (lp (cdr l) mro min)))))
- (car (reverse min))))))))
-
- (define goops (make-class (append goopses (list (kw->class kw meta)))
- '() #:name name))
-
- (define (gen-methods dict)
- (methods dict)
- (pylist-set! dict '__goops__ goops)
- (pylist-set! dict '__class__ meta)
- (pylist-set! dict '__fget__ #t)
- (pylist-set! dict '__fset__ #t)
- (pylist-set! dict '__name__ name)
- (pylist-set! dict '__parents__ parents)
- (pylist-set! dict '__class__ meta)
- (pylist-set! dict '__mro__ (get-mro parents))
- dict)
-
- (with-fluids ((*make-class* #t))
- (create-class meta name parents gen-methods kw)))
-
-
-;; Let's make an object essentially just move a reference
-
-;; the make class and defclass syntactic sugar
-(define-syntax mk-p-class
- (lambda (x)
- (syntax-case x ()
- ((_ name parents (ddef dname dval) ...)
- (with-syntax (((ddname ...)
- (map (lambda (dn)
- (datum->syntax
- #'name
- (string->symbol
- (string-append
- (symbol->string
- (syntax->datum #'name))
- "-"
- (symbol->string
- (syntax->datum dn))))))
- #'(dname ...)))
- (nname (datum->syntax
- #'name
- (string->symbol
- (string-append
- (symbol->string
- (syntax->datum #'name))
- "-goops-class")))))
- (%add-to-warn-list (syntax->datum #'nname))
- (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
- #'(ddname ...))
- #'(let ()
- (define name
- (letruc ((dname dval) ...)
- (make-p-class 'name
- parents
- (lambda (dict)
- (pylist-set! dict 'dname dname)
- ...
- (values)))))
-
- (begin
- (module-define! (current-module) 'ddname (ref name 'dname))
- (name-object ddname))
- ...
-
- (module-define! (current-module) 'nname (ref name '__goops__))
- (name-object nname)
- (name-object name)
- name))))))
-
-(define-syntax-rule (def-p-class name . l)
- (define name (mk-p-class name . l)))
-
-(define (get-class o)
- (cond
- ((is-a? o <p>)
- o)
- (else
- (error "not a pyclass"))))
-
-(define (get-type o)
- (cond
- ((is-a? o <pyf>)
- 'pyf)
- ((is-a? o <py>)
- 'py)
- ((is-a? o <pf>)
- 'pf)
- ((is-a? o <p>)
- 'p)
- (else
- 'none)))
-
-(define (print o l)
- (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
- (define port (if (pair? l) (car l) #t))
- (format port "~a"
- (aif it (if (pyclass? o)
- #f
- (if (pyobject? o)
- (ref o '__repr__)
- #f))
- (format
- #f "~a(~a)<~a>"
- p (get-type o) (it))
- (format
- #f "~a(~a)<~a>"
- p (get-type o) (ref o '__name__ 'Annonymous)))))
-
-(define-method (write (o <p>) . l) (print o l))
-(define-method (display (o <p>) . l) (print o l))
-
-(define (arglist->pkw l)
- (let lp ((l l) (r '()))
- (if (pair? l)
- (let ((x (car l)))
- (if (keyword? x)
- (cons (reverse r) l)
- (lp (cdr l) (cons x r))))
- (cons (reverse r) '()))))
-
-(define-syntax-rule (define-python-class name (parents ...) code ...)
- (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
-
-
-(define-syntax make-python-class
- (lambda (x)
- (syntax-case x ()
- ((_ name (parents ...) code ...)
- #'(let* ((cl (mk-p-class name
- (arglist->pkw (list parents ...))
- code ...)))
- cl)))))
-
-
-(define (kind x)
- (and (is-a? x <p>)
- (aif it (find-in-class x '__goops__ #f)
- (if (is-a? (make it) (ref type '__goops__))
- 'type
- 'class)
- 'object)))
-
-(define (pyobject? x) (eq? (kind x) 'object))
-(define (pyclass? x) (eq? (kind x) 'class))
-(define (pytype? x) (eq? (kind x) 'type))
-
-(define (mark-fkn tag f)
- (set-procedure-property! f 'py-special tag)
- f)
-
-(define (object-method f)
- (letrec ((self
- (mark-fkn 'object
- (lambda (x kind)
- (if (eq? kind 'object)
- f
- (lambda z (apply f x z)))))))
- self))
-
-(define (class-method f)
- (letrec ((self
- (mark-fkn 'class
- (lambda (x kind)
- (if (eq? kind 'object)
- (let ((klass (ref x '__class__)))
- (lambda z (apply f klass z)))
- (lambda z (apply f x z)))))))
- self))
-
-(define (static-method f)
- (letrec ((self
- (mark-fkn 'static
- (lambda (x kind) f))))
- self))
-
-
-(define-syntax-parameter
- *class* (lambda (x) (error "*class* not parameterized")))
-(define-syntax-parameter
- *self* (lambda (x) (error "*class* not parameterized")))
-
-(define *super* (list 'super))
-
-(define (not-a-super) 'not-a-super)
-(define (py-super class obj)
- (define (make cl parents)
- (let ((c (make-p <p>))
- (o (make-p <p>)))
- (set c '__super__ #t)
- (set c '__mro__ parents)
- (set c '__getattribute__ (lambda (self key . l)
- (aif it (ref c key)
- (if (procedure? it)
- (if (eq? (procedure-property
- it
- 'py-special)
- 'class)
- (it cl)
- (it obj))
- it)
- (error "no attribute"))))
- (set o '__class__ c)
- o))
-
- (call-with-values
- (lambda ()
- (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
- (if (pair? l)
- (if (eq? class (car l))
- (let ((r (cdr l)))
- (if (pair? r)
- (values (car r) r)
- (values #f #f)))
- (lp (cdr l)))
- (values #f #f))))
- make))
-
-
-
-(define-syntax py-super-mac
- (syntax-rules ()
- ((_)
- (py-super *class* *self*))
- ((_ class self)
- (py-super class self))))
-
-(define (pp x)
- (pretty-print (syntax->datum x))
- x)
-
-(define-syntax letruc
- (lambda (x)
- (syntax-case x ()
- ((_ ((x v) ...) code ...)
- (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
- (if (pair? a)
- (let* ((x (car a))
- (s (syntax->datum x)))
- (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
- (r (list (car b))))
- (if (pair? a2)
- (if (eq? (syntax->datum a2) s)
- (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
- (lp2 (cdr a2) (cdr b2)
- (cons (car a2) a3)
- (cons (car b2) b3)
- r))
- (lp (reverse a3) (reverse b3)
- (cons
- (list x #`(let* #,(map (lambda (v) (list x v))
- (reverse r)) #,x))
- u)))))
- #`(letrec #,(reverse u) code ...)))))))
-
-
-
-
-(define-method (py-init (o <p>) . l)
- (apply (ref o '__init__) l))
-
-(define mk-tree
- (case-lambda
- ((root)
- (vector root '()))
- ((root hist) (vector root hist))))
-
-(define (geth t) (vector-ref t 1))
-(define (getr t) (vector-ref t 0))
-(define (tree-ref t) (car (getr t)))
-
-(define (nxt tree)
- (define (dive r h)
- (let ((x (car r)))
- (if (pair? x)
- (dive (car r) (cons (cdr r) h))
- (mk-tree r h))))
-
- (define (up r h)
- (if (null? r)
- (if (pair? h)
- (up (car h) (cdr h))
- #f)
- (let ((x (car r)))
- (if (pair? x)
- (dive r h)
- (mk-tree r h)))))
-
- (let ((r (getr tree)) (h (geth tree)))
- (cond
- ((pair? r)
- (let ((r (cdr r)))
- (if (pair? r)
- (let ((x (car r)))
- (if (pair? x)
- (dive x (cons (cdr r) h))
- (mk-tree r h)))
- (if (pair? h)
- (up (car h) (cdr h))
- #f))))
- (else
- (if (pair? h)
- (up (car h) (cdr h))
- #f)))))
-
-(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
-
-(define (find-tree o tree)
- (if tree
- (let ((x (tree-ref tree)))
- (if (eq? o x)
- #t
- (find-tree o (nxt tree))))
- #f))
-
-(define (get-mro parents)
- (if (null? parents)
- parents
- (get-mro0 parents)))
-
-(define (get-mro0 parents)
- (define tree (mk-tree parents))
- (let lp ((tree tree) (r '()))
- (if tree
- (let ((x (tree-ref tree))
- (n (nxt tree)))
- (if (find-tree x n)
- (lp n r)
- (lp n (cons x r))))
- (reverse r))))
-
-(define-method (py-equal? (x <p>) y)
- (aif it (ref x '__eq__)
- (it y)
- (next-method)))
-
-(define-method (py-equal? y (x <p>))
- (aif it (ref x '__eq__)
- (it y)
- (next-method)))
-
-(define-method (py-equal? x y) ((@ (guile) equal?) x y))
-
-(define (equal? x y) (or (eq? x y) (py-equal? x y)))
-
-(define type #f)
-(set! type
- (make-python-class type ()
- (define __call__
- (case-lambda
- ((meta obj)
- (ref obj '__class__ 'None))
- ((meta name bases dict . keys)
- (type- meta name bases dict keys))))))
-(set type '__class__ type)
-
-(set! object (make-python-class object ()))
-
-(name-object type)
-(name-object object)
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 10:27:01 +0000