#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:replace (equal?)
- #:export (set ref make-p
f <p> <py> <pf> <pyf> <property>
- call with copy fset fcall make-p put put!
- pcall pcall! get fset-x pyclass? refq
+ #: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* type pyobject? pytype?
- type object
+ *class* *self* pyobject? pytype?
+ type object pylist-set! pylist-ref
))
#|
Python object system is basically syntactic suger otop of a hashmap and one
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>) h)
+(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 <property> () get set del)
-(define (mk-p/pf o)
- (cond
- ((is-a? x <pf>)
- (let ((r (ref x '__const__)))
- (slot-set! o 'h (slot-ref r 'h))
- (slot-set! o 'size (slot-ref r 'size))
- (slot-set! o 'n (slot-ref r 'n))
- o))
-
- ((is-a? x <p>)
- (let ((r (ref x '__const__))
- (h (make-hash-table)))
- (hash-set! h '__class__ x)
- (slot-set! o 'h h)))
- (else #f))
- (values))
-
(define (get-dict self name parents)
(aif it (ref self '__prepare__)
(it self name parents)
(define (hashforeach a b) (values))
-(define (new-class meta name parents dict keys)
- (aif it (ref self '__new__)
- (apply it name parents dict keys)
- (let* ((goops (ref dict '__goops__))
- (p (kwclass->class kw meta))
- (class (make p)))
+(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)))
- (set class '__class__ meta)
- (if (hashtable? dict)
+ (if (hash-table? dict)
(hash-for-each
(lambda (k v) (set class k v))
dict)
(if (pair? mro)
(let ((p (car mro)))
(aif it (ref p '__init_subclass__)
- (apply it class #f keys)
+ (apply it class #f kw)
#f))))
+ (set class '__mro__ (cons class (ref class '__mro__)))
class)))
(define (type- meta name parents dict keys)
(define (create-class meta name parents gen-methods . keys)
(let ((dict (gen-methods (get-dict meta name keys))))
- (aif it (find-in-class (ref meta '__class__) '__call__ #f)
- (apply (it meta 'object) name parents dict keys)
+ (aif it (ref meta '__class__)
+ (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+ (apply (it meta 'object) name parents dict keys)
+ (type- meta name parents dict keys))
(type- meta name parents dict keys))))
(define (create-object class meta goops x)
- (aif it (ref meta '__call__)
+ (aif it #f ;(ref meta '__call__)
(apply it x)
- (let ((obj (aif it (ref class __new__)
- (it)
+ (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! 'procedure
+ (slot-set! obj 'procedure
(lambda x
(aif it (ref obj '__call__)
(apply it x)
obj)))
(define (make-object class meta goops)
- (let ((obj (make goops)))
- (mk-p/pf obj)
+ (let ((obj (make-p goops)))
(set obj '__class__ class)
obj))
-
-
-
;; Make an empty pf object
-(define* (make-pf #:optional (class <pf>))
- (define r (make-pyclass class))
- (slot-set! r 'h vlist-null)
- (slot-set! r 'size 0)
- (slot-set! r 'n 0)
- r)
-
-(define* (make-p #:optional (class <p>))
- (define r (make-pyclass class))
- (slot-set! r 'h (make-hash-table))
- r)
+(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)))
x)
y)))
-(define fail (cons 'fail '()))
(define-syntax-rule (mrefx x key l)
(let ()
(define (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 (kif it p x y)
- (let ((it p))
- (if (eq? it fail)
- y
- x)))
-
(define-syntax-rule (find-in-class-and-parents klass key fail)
(kif r (find-in-class klass key fail)
r
- (aif parents (hash-ref class-h '__mro__ #f)
+ (aif parents (find-in-class klass '__mro__ #f)
(let lp ((parents parents))
(if (pair? parents)
(kif r (find-in-class (car parents) key fail)
it
(begin
(fluid-set! *refkind* 'class)
- (aif klass (hash-ref h '__class__)
+ (aif klass (find-in-class klass '__class__ #f)
(kif it (find-in-class-and-parents klass key fail)
it
(end))
(let* ((g (mrefx xx '__fget__ '(#t)))
(f (if g
(if (eq? g #t)
- (aif it (mrefx- xx '__getattribute__ '())
+ (aif it (mrefx xx '__getattribute__ '())
(begin
(set xx '__fget__ it)
it)
(let ((res (mrefx xx key l)))
(if (and (not (struct? res)) (procedure? res))
(res xx)
- res)))))
+ 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)
- res)))))
+ 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 <pyf>) key . l) (mref-py x key l))
(define-method (ref (x <py> ) key . l) (mref-py x key l))
-(define-method (refq (x <pf> ) key . l) (mref x key l))
-(define-method (refq (x <p> ) key . l) (mref x key l))
-(define-method (refq (x <pyf>) key . l) (mref-py x key l))
-(define-method (refq (x <py> ) key . l) (mref-py 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
(values)))
;; on object x add a binding that key -> val
-(define--method (mset (x <pf) key val)
+(define-method (mset (x <pf>) key 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-assq key h)))
+ (let ((r (vhash-assoc key h)))
(when (not r)
(slot-set! x 'n (+ n 1)))
- (slot-set! x 'h (vhash-consq key val h))
+ (slot-set! x 'h (vhash-cons key val h))
(when (> s (* 2 n))
(reshape x))
(values))))
(hash-set! (slot-ref x 'h) key val)
(values)))
-(define-method (mset (x <pf>) key val)
- (begin
- (hash-set! (slot-ref x 'h) key val)
- (values)))
-
(define-syntax-rule (mset-py x key val)
- (let* ((h (slot-ref x 'h))
- (v (hash-ref h key fail)))
+ (let* ((v (mref x key (list fail))))
(if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x)))))
(let* ((g (mrefx x '__fset__ '(#t)))
(f (if g
(if (eq? g #t)
- (let ((class (aif it (mref- x '__class__ '())
+ (let ((class (aif it (mref x '__class__ '())
it
x)))
(aif it (mrefx x '__setattr__ '())
;; make a copy of a pf object
(define-syntax-rule (mcopy x)
- (let ((r (make-pyclass <pf>)))
+ (let ((r (make-p (pk (ref (pk 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))
+ (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))
;; 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-pf))
+(define null (make-p <pf>))
(define (filter-parents l)
(let lp ((l l))
(lp (cdr l)))
'())))
-(define (kw->class kw)
+(define (kw->class kw meta)
(if (memq #:functional kw)
(if (memq #:fast kw)
<pf>
- <pyf>)
+ (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
+ <pyf>
+ <pf>))
(if (memq #:fast kw)
- <p>
- <py>)))
+ (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)
<pf>
(if (memq #:pyClass kw)
<pyf>
- (if (or (is-a
default <py>) (is-a default <pyf>))
+ (if (or (is-a
? default <py>) (is-a? default <pyf>))
<pyf>
<pf>)))
(if (memq #:mutatingClass kw)
<p>
(if (memq #:pyClass kw)
<py>
- (if (or (is-a
default <py>) (is-a default <pyf>))
+ (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>))
+ (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>))
+ (if (or (is-a
? default <pf>) (is-a? default <pyf>))
<pyf>
<py>)
- default)))))
-
-(define (make-p-class name supers methods kw)
+ (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)
sups)
supers))
+ (define parents (let ((p (filter-parents supers)))
+ (if (null? p)
+ (if object
+ (list object)
+ '())
+ p)))
- (define goops (make-class
- (append goopses
- (list (kw->class kw)))))
+ (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 parents (filter-parents supers))
- (define meta (aif it (memqq #:metaclass kw) (car it) type))
- (define (gen-methods dict)
- (dynamic dict)
- (set dict '__goops__ goops)
- (set dict '__class__ meta)
- (set dict '__fget__ #t)
- (set dict '__fset__ #t)
- (set dict '__name__ name)
- (set dict '__parents__ parents)
- (set dict '__mro__ (get-mro class)))
+ (define (gen-methods dict)
+ (method 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)
(create-class meta name parents gen-methods kw))
;; the make class and defclass syntactic sugar
(define-syntax-rule (mk-p-class name
parents
- (kw ...)
- (ddef dname dval)
+ (ddef dname dval)
...)
(let ()
(define name
- (letruc ((dname dval) (... ...))
- (make-p-class name
- parents
- (lambda (dict)
- (hash-set! d 'dname dname) (... ...)))))
+ (letruc ((dname dval) ...)
+ (make-p-class 'name
+ parents
+ (lambda (dict)
+ (pylist-set! dict 'dname dname)
+ ...
+ (values)))))
- name)))
+ name))
(define-syntax-rule (def-p-class name . l)
(define name (mk-p-class name . l)))
'none)))
(define (print o l)
- (define p1 (if (pyclass? o) "C" "O"))
- (define p2 (if (pyclass? o) "C" "O"))
+ (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 (ref o '__repr__ #f))
+ (aif it (if (pyclass? o)
+ #f
+ (if (pyobject? o)
+ (ref o '__repr__)
+ #f))
(format
- #f "~a(~a)<~a>" p1 (get-type o) (it))
+ #f "~a(~a)<~a>"
+ p (get-type o) (it))
(format
- #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
+ #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))
(cons (reverse l) '()))))
(define-syntax-rule (define-python-class name (parents ...) code ...)
- (define name (mk-py-class name (arglist->pkw (list parents ...)) code ...)))
+ (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
-(define (pyclass? x)
- (and (is-a? x <p>)
- (if (is-a? x type)
- #f
- (if it (ref x '__class__)
- (if (is-a? it type)
- #t
- #f)))
- #f))
-
-(define (pyobject? x)
- (and (is-a? x <p>)
- (if (is-a? x type)
- #f
- (if it (ref x '__class__)
- (if (is-a? it type)
- #f
- #t)))
- #f))
-
-(define (pytype? x)
+(define-syntax-rule (make-python-class name (parents ...) code ...)
+ (mk-p-class name (arglist->pkw (list parents ...)) code ...))
+
+(define (kind x)
(and (is-a? x <p>)
- (if (is-a? x type)
- #t
- #f)
- #f))
+ (aif it (find-in-class x '__goops__ #f)
+ (if (is-a? (make it) (ref type '__goops__))
+ 'type
+ 'class)
+ 'object)))
-(define-method (py-class (o <p>))
- (ref o '__class__ type))
+(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)
(define (not-a-super) 'not-a-super)
(define (py-super class obj)
(define (make cl parents)
- (let ((c (make-p))
- (o (make-p)))
+ (let ((c (make-p <p>))
+ (o (make-p <p>)))
(set c '__super__ #t)
(set c '__mro__ parents)
(set c '__getattribute__ (lambda (self key . l)
(find-tree o (nxt tree))))
#f))
-(define (get-mro class)
- (define tree (mk-tree (class-to-tree class)))
+(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))))
+ (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__)
(define (equal? x y) (or (eq? x y) (py-equal? x y)))
-(define type 'type)
-(define-python-class type ()
- (define __call__
- (case-lambda
- ((self obj)
- (if (is-a? obj type)
- obj
- (let ((r (ref obj '__class__)))
- (if (is-a? r type)
- r
- (ref r '__class__)))))
- ((self name bases dict . keys)
- (type- meta name parents dict keys)))))
-
+(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)
-(define-python-class object ())
+(set! object (make-python-class object ()))
projects / software / python-on-guile.git / commitdiff
