)
'pf)
((is-a? o )
'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
) . l) (print o l))
(define-method (display (o
) . 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
(syntax-parameterize ((*class* (lambda (x) #'name)))
(mk-p-class name (arglist->pkw (list parents ...)) code ...))))
(define-syntax-rule (define-python-class-noname name (parents ...) code ...)
(define name
(syntax-parameterize ((*class* (lambda (x) #'name)))
(mk-p-class-noname 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
)
(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-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)
(if (or (pyclass? obj) (pytype? obj))
cl
(let ((c (make-p
))
(o (make-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 (if (or (pytype? obj) (pyclass? obj))
obj
(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
) . 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 '__bases__))))
(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
) y)
(aif it (ref x '__eq__)
(it y)
(next-method)))
(define-method (py-equal? y (x
))
(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 (subclasses self)
(aif it (ref self '__zubclasses__)
(let ((h (make-hash-table)))
(let lp0 ((it it))
(let lp ((l (hash-fold
(lambda (k v s)
(hash-set! h k #t)
(cons k s))
'() it)))
(if (pair? l)
(begin
(lp0 (car l))
(lp (cdr l))))))
(hash-fold (lambda (k v s) (cons k s)) '() h))
'()))
(set! type
(make-python-class type ()
(define __new__ new-class0)
(define __init_subclass__ (lambda x (values)))
(define ___zub_classes__ (make-weak-key-hash-table))
(define __subclasses__ subclasses)
(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 ()
(define __subclasses__ subclasses)
(define __weakref__ (lambda (self) self))))
(name-object type)
(name-object object)