)
'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 (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
)
(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
))
(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 (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-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 '__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
) 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 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)