diff options
Diffstat (limited to 'modules/oop')
| -rw-r--r-- | modules/oop/pf-objects.scm | 412 |
1 files changed, 193 insertions, 219 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index f768027..a72d360 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -5,11 +5,8 @@ #:replace (equal?) #:export (set ref make-pf <p> <py> <pf> <pyf> <property> call with copy fset fcall make-p put put! - pcall pcall! get fset-x pyclass? refq - def-pf-class mk-pf-class make-pf-class + pcall pcall! get fset-x pyclass? refq def-p-class mk-p-class make-p-class - def-pyf-class mk-pyf-class make-pyf-class - def-py-class mk-py-class make-py-class define-python-class get-type py-class object-method class-method static-method py-super-mac py-super py-equal? @@ -39,74 +36,116 @@ explicitly tell it to not update etc. (define-class <property> () get set del) -(define (mk x) - (letrec ((o (make (ref x '__goops__)))) - (slot-set! o 'procedure - (lambda x - (apply - (ref o '__call__ (lambda x (error "no __call__ method"))) - x))) - (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)) +(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)) - 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-method (get-dict (self <pyf>) name parents) + (aif it (ref self '__prepare__) + (it self name parents) + (make (kwclass->class kw <pyf>)))) + +(define-method (get-dict (self <py>) name parents) + (aif it (ref self '__prepare__) + (it self name parents) + (make (kwclass->class kw <py>)))) (define-method (get-dict (self <pf>) name parents) - (aif it (find-in-class self '__prepare__ #f) + (aif it (ref self '__prepare__) (it self name parents) - (make <pf>))) + (make (kwclass->class kw <pf>)))) (define-method (get-dict (self <p>) name parents) - (aif it (find-in-class self '__prepare__ #f) + (aif it (ref self '__prepare__) (it self name parents) - (make <p>))) + (make (kwclass->class kw <p>)))) + -(define-method (new-class (self <p>) name parents dict) +(define (new-class meta name parents dict keys) (aif it (ref self '__new__) - (it self name parents dict) - (let ((class (make (ref dict '__goops__)))) + (apply it name parents dict keys) + (let* ((goops (ref dict '__goops__)) + (p (kwclass->class kw meta)) + (class (make p))) (slot-set! class 'procedure - (aif it (ref self '__call__) - (lambda x (apply __call__ x)) - (lambda x - (let ((obj (py-make-obj class))) - (aif it (ref obj '__init__) - (apply it x) - (values)) - obj))) - class) - (cond - ((is-a? dict <pf>) - (slot-set! class 'h dict)) - ((is-a? dict <p>) - (slot-set! class 'h (slot-ref dict 'h))) - (else - (slot-set! class 'h dict)))))) - -(define (create-class meta name parents gen-methods keys) - (let ((dict (gen-methds (get-dict meta name keys)))) - (aif it (find-in-class (ref meta '__class__) '__call__ #f) - ((it meta 'object) meta name parents keywords) - (let ((class (aif it (find-in-class meta '__new__ #f) - ((it meta 'object) meta name parents dict keys) - (new-class meta name parents dict keys)))) - (aif it (find-in-class meta '__init__) - ((it meta 'object) name parents - - + (lambda x + (create-object class meta goops x))) + (cond + ((eq? p <pf>) + (cond + ((is-a? dict <pf>) + (slot-set! class 'h (slot-ref dict 'h)) + (slot-set! class 'n (slot-ref dict 'n)) + (slot-set! class 'size (slot-ref dict 'size))) + (else + (error "funtional class creation needs functional dicts")))) + + ((eq? p <p>) + (cond + ((is-a? dict <pf>) + (slot-set! class 'h dict)) + ((is-a? dict <p>) + (slot-set! class 'h (slot-ref dict 'h))) + (else + (slot-set! class 'h dict))))) + + (let lp ((ps parents)) + (if (pair? ps) + (let ((p (car ps))) + (aif it (ref p '__init_subclass__) + (apply it class #f keys) + #f) + (lp (cdr ps))))) + class))) + +(define (create-class meta name parents gen-methods . keys) + (let ((dict (gen-methods (get-dict meta name keys)))) + (aif it (ref (ref meta '__class__) '__call__) + (apply it 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-object class meta goops x) + (aif it (ref meta '__call__) + (apply it x) + (let ((obj (aif it (ref class __new__) + (it) + (make-object class meta goops)))) + (aif it (ref obj '__init__) + (apply it x) + #f) + (slot-set! '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 goops))) + (mk-p/pf obj) + (set obj '__class__ class) + obj)) + + - ;; Make an empty pf object (define* (make-pf #:optional (class <pf>)) (define r (make-pyclass class)) @@ -493,93 +532,6 @@ explicitly tell it to not update etc. ;; time because it is functional we can get away with this. (define null (make-pf)) -;; append the bindings in x in front of y + some optimizations -(define (union x y) - (define hx (slot-ref x 'h)) - (define hy (slot-ref y 'h)) - (define n (slot-ref x 'n)) - (define s (slot-ref x 'size)) - (define m (make-hash-table)) - - (define h - (vhash-fold - (lambda (k v st) - (if (vhash-assq k hy) - (begin - (set! s (+ s 1)) - (vhash-consq k v st)) - (if (hash-ref m k) - s - (begin - (set! n (+ n 1)) - (set! s (+ s 1)) - (hash-set! m k #t) - (vhash-consq k v st))))) - hy - hx)) - - (define out (make-pyclass <pf>)) - (slot-set! out 'h h) - (slot-set! out 'n n) - (slot-set! out 'size s) - out) - -(define (union- class x y) - (define hx (slot-ref x 'h)) - (define hy (slot-ref y 'h)) - (define out (make-p class)) - (define h (slot-ref out 'h)) - (hash-for-each (lambda (k v) (hash-set! h k v)) hy) - (hash-for-each (lambda (k v) (hash-set! h k v)) hx) - out) - - -;; make a class. A class add some meta information to allow for multiple -;; inherritance and add effectively static data to the object the functional -;; datastructure show it's effeciency now const is data that will not change -;; and bindings that are added to all objects. Dynamic is the mutating class -;; information. supers is a list of priorities -(define-syntax-rule (mk-pf make-pf-class <pf>) - (define-syntax make-pf-class - (lambda (x) - (syntax-case x () - ((_ name const dynamic (supers (... ...))) - (with-syntax (((sups (... ...)) (generate-temporaries - #'(supers (... ...))))) - #'(let ((sups supers) (... ...)) - (define name (make-class (list sups (... ...) <pf>) '())) - (define class (dynamic name)) - (define __const__ - (union const - (let lp ((sup (filter-parents - (list sups (... ...))))) - (if (pair? sup) - (union (ref (car sup) '__const__ null) - (lp (cdr sup))) - null)))) - - (reshape __const__) - (set class '__class__ #f) - (set class '__fget__ #t) - (set class '__fset__ #t) - (set class '__const__ __const__) - (set class '__goops__ name) - (set class '__name__ 'name) - (set class '__parents__ (filter-parents - (list sups (... ...)))) - (set class '__mro__ (get-mro class)) - (set class '__goops__ name) - (set __const__ '__name__ 'name) - (set __const__ '__goops__ class) - (set __const__ '__parents__ (filter-parents - (list sups (... ...)))) - (set __const__ '__goops__ name) - - class))))))) - -(mk-pf make-pf-class <pf>) -(mk-pf make-pyf-class <pyf>) - (define (filter-parents l) (let lp ((l l)) (if (pair? l) @@ -588,75 +540,91 @@ explicitly tell it to not update etc. (lp (cdr l))) '()))) -(define-syntax-rule (mk-p make-p-class <p>) - (define-syntax make-p-class - (lambda (x) - (syntax-case x () - ((_ name const dynamic (supers (... ...))) - (with-syntax (((sups (... ...)) (generate-temporaries - #'(supers (... ...))))) - #'(let ((sups supers) (... ...)) - (define name (make-class (list - (if (is-a? sups <p>) - (aif it (ref sups '__goops__ #f) - it - sups) - sups) - (... ...) <p>) '())) - - (define class (dynamic <p>)) - (set class '__class__ #f) - (set class '__fget__ #t) - (set class '__fset__ #t) - (set class '__name__ 'name) - (set class '__goops__ name) - (set class '__parents__ (filter-parents (list sups (... ...)))) - (set class '__mro__ (get-mro class)) - class))))))) - -(mk-p make-p-class <p>) -(mk-p make-py-class <py>) +(define (kw->class kw) + (if (memq #:functional kw) + (if (memq #:fast kw) + <pf> + <pyf>) + (if (memq #:fast kw) + <p> + <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>) + default))))) + +(define (make-p-class name supers methods kw) + (define goopses (map (lambda (sups) + (aif it (ref sups '__goops__ #f) + it + sups) + sups) + supers)) + + (define goops (make-class + (append goopses + (list (kw->class kw))))) + + (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))) + (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-rule (mk-p/f make-pf mk-pf-class make-pf-class) - (define-syntax-rule (mk-pf-class name (parents (... ...)) - #:const - ((sdef mname sval) (... ...)) - #:dynamic - ((ddef dname dval) (... ...))) +(define-syntax-rule (mk-p-class name + parents + (kw ...) + (ddef dname dval) + ...) (let () (define name - (letruc ((mname sval) (... ...) (dname dval) (... ...)) - (make-pf-class name - (let ((s (make-pf))) - (set s 'mname mname) (... ...) - s) - (lambda (class) - (let ((d (make-pf class))) - (set d 'dname dname) (... ...) - d)) - (parents (... ...))))) + (letruc ((dname dval) (... ...)) + (make-p-class name + parents + (lambda (dict) + (let ((d (make-pf class))) + (set d 'dname dname) (... ...) + d)))) + name))) -(mk-p/f make-pf mk-pf-class make-pf-class) -(mk-p/f make-p mk-p-class make-p-class) -(mk-p/f make-pf mk-pyf-class make-pyf-class) -(mk-p/f make-p mk-py-class make-py-class) - -(define-syntax-rule (def-pf-class name . l) - (define name (mk-pf-class name . l))) - -(define-syntax-rule (def-p-class name . l) +(define-syntax-rule (def-p-class name . l) (define name (mk-p-class name . l))) -(define-syntax-rule (def-pyf-class name . l) - (define name (mk-pyf-class name . l))) - -(define-syntax-rule (def-py-class name . l) - (define name (mk-py-class name . l))) - (define (get-class o) (cond ((is-a? o <p>) @@ -688,24 +656,30 @@ explicitly tell it to not update etc. (format #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None))))) -(define-method (write (o <p>) . l) (print o l)) +(define-method (write (o <p>) . l) (print o l)) (define-method (display (o <p>) . l) (print o l)) -(define-syntax-rule (define-python-class name parents code ...) - (define name - (mk-py-class name parents - #:const - () - #:dynamic - (code ...)))) +(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 l) '())))) + +(define-syntax-rule (define-python-class name (parents ...) code ...) + (define name (mk-py-class name (arglist->pkw (list parents ...)) code ...))) (define (pyclass? x) (and (is-a? x <p>) - (if (ref x '__class__) - #f - (if (ref x '__super__) - 'super - #t)))) + (if (is-a? x type) + #f + (if it (ref x '__class__) + (if (is-a? it type) + #t + #f))) + #f)) (define-method (py-class (o <p>)) (ref o '__class__ 'type)) |