summaryrefslogtreecommitdiff
path: root/modules/oop
diff options
context:
space:
mode:
Diffstat (limited to 'modules/oop')
-rw-r--r--modules/oop/pf-objects.scm328
1 files changed, 200 insertions, 128 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index d42865f..64ad776 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -17,7 +17,7 @@
py-super-mac py-super py-equal?
*class* *self* pyobject? pytype?
type object pylist-set! pylist-ref tr
- resolve-method-g rawref rawset
+ resolve-method-g rawref rawset py-dict
))
#|
@@ -34,6 +34,26 @@ The datastructure is functional but the objects mutate. So one need to
explicitly tell it to not update etc.
|#
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define (pk-obj o)
+ (pk 'start-pk-obj)
+ (let ((h (slot-ref o 'h)))
+ (hash-for-each (lambda (k v) (pk k)) h)
+ (pk 'finished-obj)
+ (aif cl (hash-ref h '__class__)
+ (if (is-a? cl <p>)
+ (if (hash-table? (slot-ref cl 'h))
+ (hash-for-each (lambda (k v)
+ (if (member k '(__name__ __qualname__))
+ (pk k v)
+ (pk k)))
+ (slot-ref cl 'h))
+ (pk 'no-hash-table))
+ (pk 'no-class))
+ (pk 'false-class)))
+ (pk 'end-pk-obj))
+
(define fail (cons 'fail '()))
(define-syntax-rule (kif it p x y)
@@ -52,7 +72,6 @@ explicitly tell it to not update etc.
(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
@@ -88,6 +107,27 @@ explicitly tell it to not update etc.
(define-method (rawset (o <procedure>) key val)
(set-procedure-property! o key val))
+(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-)
+ (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-))
+ (kif r (find-in-class klass key fail)
+ r
+ fail-)))
+
+(define-inlinable
+ (ficap klass key fail) (find-in-class-and-parents klass key fail))
+
(define (mk-getter-object f)
(lambda (obj cls)
(if (pytype? obj)
@@ -95,10 +135,10 @@ explicitly tell it to not update etc.
(if (pyclass? obj)
(if (pytype? cls)
(lambda x (apply f obj x))
- (lambda x (apply f x)))
+ f)
(if (pyclass? cls)
(lambda x (apply f obj x))
- (lambda x (apply f x)))))))
+ f)))))
(define (mk-getter-class f)
(lambda (obj cls)
@@ -158,20 +198,17 @@ explicitly tell it to not update etc.
(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-class0 meta name parents dict . kw)
(let* ((goops (pylist-ref dict '__goops__))
- (p (kwclass->class kw meta))
+ (p (kwclass->class kw meta))
(class (make-p p)))
+ (pk 'new-class0)
(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))
@@ -194,7 +231,7 @@ explicitly tell it to not update etc.
class))
(define (new-class meta name parents dict kw)
- (aif it (ref meta '__new__)
+ (aif it (and meta (ficap meta '__new__ #f))
(apply it meta name parents dict kw)
(apply new-class0 meta name parents dict kw)))
@@ -205,31 +242,55 @@ explicitly tell it to not update etc.
#f)
class))
-(define (create-class meta name parents gen-methods . keys)
- (let ((dict (gen-methods (get-dict meta name keys))))
+
+(define (the-create-object class x)
+ (let* ((meta (ref class '__class__))
+ (goops (ref class '__goops__))
+ (obj (aif it (ficap class '__new__ #f)
+ (it)
+ (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 (create-object class meta goops x)
+ (with-fluids ((*make-class* #t))
+ (aif it (ficap meta '__call__ #f)
+ (apply it class x)
+ (the-create-object class x))))
+
+(define type-call
+ (lambda (class . l)
+ (if (pytype? class)
+ (apply (case-lambda
+ ((meta obj)
+ (ref obj '__class__ 'None))
+ ((meta name bases dict . keys)
+ (type- meta name bases dict keys)))
+ class l)
+ (the-create-object class l))))
+
+(define (get-dict self name parents)
+ (aif it (and self (ficap self '__prepare__ #f))
+ (it self name parents)
+ (make-hash-table)))
+
+(define (create-class meta name parents gen-methods keys)
+ (let ((dict (gen-methods (get-dict meta name parents))))
(aif it (ref meta '__class__)
- (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+ (aif it (find-in-class it '__call__ #f)
(apply it meta 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
- (apply it x)
- (let ((obj (aif it (find-in-class class '__new__ #f)
- (it)
- (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)
@@ -272,6 +333,11 @@ explicitly tell it to not update etc.
(f obj class)
it)))
+(define-inlinable (gokx obj class it)
+ (aif f (rawref it '__get__)
+ (f obj class)
+ it))
+
(define *location* (make-fluid #f))
(define-syntax-rule (mrefx x key l)
(let ()
@@ -304,30 +370,12 @@ explicitly tell it to not update etc.
(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 (cdr 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! *location* klass)
- (kif it (find-in-class klass key fail)
+ (kif it (find-in-class-and-parents klass key fail)
it
(aif klass (find-in-class klass '__class__ #f)
(begin
@@ -341,26 +389,17 @@ explicitly tell it to not update etc.
(define-syntax-rule (mrefx-py x key l)
(let ((xx x))
- (let* ((g (mrefx xx '__fget__ '(#t)))
- (f (if g
- (if (eq? g #t)
- (aif it (mrefx xx '__getattribute__ '())
- (let ((f (gox xx it)))
- (rawset xx '__fget__ it)
- f)
- (begin
- (if (mc?)
- (rawset xx '__fget__ #f))
- #f))
- g)
- #f)))
- (if (or (not f) (eq? f not-implemented))
- (gox xx (mrefx xx key l))
- (catch #t
- (lambda ()
- (f xx key))
- (lambda x
- (gox xx (mrefx xx key l))))))))
+ (let* ((f (aif it (or (mrefx xx '__getattribute__ '())
+ (mrefx xx '__getattr__ '()))
+ (gox xx it)
+ #f)))
+ (if (or (not f) (eq? f not-implemented))
+ (gox xx (mrefx xx key l))
+ (catch #t
+ (lambda ()
+ (f xx key))
+ (lambda x
+ (gox xx (mrefx xx key l))))))))
(define-syntax-rule (mref x key l)
@@ -372,7 +411,15 @@ explicitly tell it to not update etc.
(let ((res (mrefx-py xx key l)))
res)))
-(define-method (ref x key . l) (if (pair? l) (car l) #f))
+(define-method (ref x key . l)
+ (cond
+ ((eq? x 'None)
+ (apply ref NoneObj key l))
+ ((pair? l)
+ (car l))
+ (else
+ #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))
@@ -712,28 +759,32 @@ explicitly tell it to not update etc.
((name supers.kw methods)
(make-p-class name "" supers.kw methods))
((name doc supers.kw methods)
- (define kw (cdr supers.kw))
- (define supers (car supers.kw))
+ (define s.kw supers.kw)
+ (define kw (cdr s.kw))
+ (define supers (car s.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)))
+ p))
+
+ (define cparents (if (null? parents)
+ (if object
+ (list object)
+ '())
+ parents))
(define meta (aif it (memq #:metaclass kw)
(cadr it)
- (if (null? parents)
+ (if (null? cparents)
type
- (let* ((p (car parents))
+ (let* ((p (car cparents))
(m (ref p '__class__))
(mro (reverse (ref m '__mro__ '()))))
- (let lp ((l (cdr parents))
+ (let lp ((l (cdr cparents))
(max mro)
(min mro))
(if (pair? l)
@@ -753,7 +804,8 @@ explicitly tell it to not update etc.
(lp (cdr l) mro min)))))
(car (reverse min))))))))
- (define goops (make-class (append goopses (list (kw->class kw meta)))
+ (define goops (make-class (append goopses
+ (list (kw->class kw meta)))
'() #:name name))
(define (make-module)
@@ -766,33 +818,42 @@ explicitly tell it to not update etc.
(map symbol->string (cdddr l))
".")
l)))
-
+
(define (gen-methods dict)
+ (define (filt-bases x)
+ (let lp ((x x))
+ (if (pair? x)
+ (let ((y (car x)))
+ (if (is-a? y <p>)
+ (cons y (lp (cdr x)))
+ (lp (cdr x))))
+ '())))
+
(methods dict)
(pylist-set! dict '__goops__ goops)
(pylist-set! dict '__class__ meta)
(pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
(pylist-set! dict '__module__ (make-module))
- (pylist-set! dict '__bases__ parents)
+ (pylist-set! dict '__bases__ (filt-bases parents))
(pylist-set! dict '__fget__ #t)
(pylist-set! dict '__fset__ #t)
(pylist-set! dict '__name__ name)
(pylist-set! dict '__qualname__ name)
(pylist-set! dict '__class__ meta)
- (pylist-set! dict '__mro__ (get-mro parents))
+ (pylist-set! dict '__mro__ (get-mro cparents))
(pylist-set! dict '__doc__ doc)
dict)
(let ((cl (with-fluids ((*make-class* #t))
- (create-class meta name parents gen-methods kw))))
+ (create-class meta name parents gen-methods kw))))
(aif it (ref meta '__init_subclass__)
- (let lp ((ps parents))
+ (let lp ((ps cparents))
(if (pair? ps)
(let ((super (car ps)))
(it cl super)
(lp (cdr ps)))))
#f)
-
+
cl))))
@@ -867,8 +928,8 @@ explicitly tell it to not update etc.
(lambda (x)
(syntax-case x ()
((_ name parents ((ddef dname dval) ...) body)
- #'(mk-p-class name parents "" (ddef dname dval) ...))
- ((_ name parents doc (ddef dname dval) ...)
+ #'(mk-p-class2 name parents "" ((ddef dname dval) ...) body))
+ ((_ name parents doc ((ddef dname dval) ...) body)
(with-syntax (((ddname ...)
(map (lambda (dn)
(datum->syntax
@@ -894,13 +955,13 @@ explicitly tell it to not update etc.
#'(let ()
(define name
(letruc ((dname (make-up dval)) ...)
- body
- (make-p-class 'name doc
- parents
- (lambda (dict)
- (pylist-set! dict 'dname dname)
- ...
- (values)))))
+ body
+ (make-p-class 'name doc
+ parents
+ (lambda (dict)
+ (pylist-set! dict 'dname dname)
+ ...
+ (values)))))
(begin
(module-define! (current-module) 'ddname (ref name 'dname))
@@ -1001,11 +1062,15 @@ explicitly tell it to not update etc.
code ...)))
cl)))))
-
+(define type-goops #f)
(define (kind x)
+ (if (not type-goops) (set! type-goops (ref type '__goops__)))
(and (is-a? x <p>)
(aif it (find-in-class x '__goops__ #f)
- (if (is-a? (make it) (ref type '__goops__))
+ (if (or
+ (not type-goops)
+ (eq? it type-goops)
+ (member it (class-subclasses type-goops)))
'type
'class)
'object)))
@@ -1028,25 +1093,23 @@ explicitly tell it to not update etc.
(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 <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)))
+ (if (not cl)
+ #f
+ (if (or (pyclass? obj) (pytype? obj))
+ cl
+ (let ((c (make-p <py>))
+ (o (make-p <py>)))
+ (set c '__class__ type)
+ (set c '__mro__ (cons c parents))
+ (set c '__getattribute__ (lambda (self key . l)
+ (aif it (ficap c key #f)
+ (if (procedure? it)
+ (gokx obj cl it)
+ it)
+ (error "no attribute"))))
+ (set c '__name__ "**super**")
+ (set o '__class__ c)
+ o))))
(call-with-values
(lambda ()
@@ -1222,17 +1285,16 @@ explicitly tell it to not update etc.
(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))))))
+ (define __call__ type-call)
+ (define mro (lambda (self) (ref self '__mro__)))))
+
(set type '__class__ type)
(set! object (make-python-class object ()
- (define __subclasses__ subclasses)
- (define __weakref__ (lambda (self) self))))
+ (define __init__ (lambda x (values)))
+ (define __subclasses__ subclasses)
+ (define __weakref__ (lambda (self) self))))
+
(name-object type)
(name-object object)
@@ -1242,4 +1304,14 @@ explicitly tell it to not update etc.
it
(next-method)))
-
+
+(define-method (py-dict (o <p>))
+ (aif it (ref o '__dict__)
+ it
+ (slot-ref o 'h)))
+
+(define-python-class NoneObj ()
+ (define __new__
+ (lambda x 'None)))
+
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 08:22:07 +0000