diff options
Diffstat (limited to 'modules')
| -rw-r--r-- | modules/language/python/compile.scm | 91 | ||||
| -rw-r--r-- | modules/language/python/module/python.scm | 23 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 412 |
3 files changed, 246 insertions, 280 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 49c6a64..a040c7d 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -406,6 +406,21 @@ (() '())))) +(define (kw->li dict) + (for ((k v : dict) (l '())) + (cons* v (symbol->keyword (string->symbol k)) l) + #:final + (reverse 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 l) '())))) + (define (get-addings vs x) (match x (() '()) @@ -436,12 +451,17 @@ `(#:fast-id ,it ',tag) `(#:identifier ',tag)))))) - ((#:arglist args apply #f) + ((#:arglist args apply kw) (call-with-values (lambda () (get-kwarg vs args)) (lambda (args kwarg) - (if apply - `(#:apply ,@args ,@kwarg - ,`(,(L 'to-list) ,(exp vs apply))) + (if (or kw apply) + `(#:apply ,@args ,@kwarg + ,`(,(L 'to-list) + (,(G 'append) + (if apply (exp vs apply) ''()) + (if kw + '(,(C 'kw->li) (exp vs kw)) + ''())))) `(#:call ,@args ,@kwarg))))) ((#:subscripts (n #f #f)) @@ -729,69 +749,34 @@ ((_ . l) (cons 'begin (map (g vs exp) l)))) (#:classdef - ((_ (#:identifier class . _) parents defs) + ((_ class parents defs) (with-fluids ((is-class? #t)) (let () - (define (filt l) - (reverse - (fold (lambda (x s) - (match x - ((or 'fast 'functional) s) - (x (cons x s)))) - '() l))) - (define (is-functional l) - (fold (lambda (x pred) - (if pred - pred - (match x - ('functional #t) - (_ #f)))) - #f l)) - (define (is-fast l) - (fold (lambda (x pred) - (if pred - pred - (match x - ('fast #t) - (_ #f)))) - #f l)) - (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) - (class (string->symbol class)) + (class (exp vs class)) (parents (match parents (() - '()) + (cons '() '())) (#f - '()) - ((#:arglist args . _) - (map (g vs exp) args)))) + (cons '() '())) + ((#:arglist . _) + (get-addings vs (list parents))))) (is-func (is-functional parents)) - (is-fast (is-fast parents)) - (kind (if is-func - (if is-fast - 'mk-pf-class - 'mk-pyf-class) - (if is-fast - 'mk-p-class - 'mk-py-class))) (parents (filt parents))) `(define ,class (,(C 'class-decor) ,decor (,(C 'with-class) ,class - (,(O kind) + (,(mk-p-class ,class - ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) - #:const - () - #:dynamic - ,(match (filter-defs (exp vs defs)) - (('begin . l) - l) - ((('begin . l)) - l) - (l l))))))))))) + (,(C 'ref-x) ,(C 'arglist->pkw) ,@parents) + ,@(match (filter-defs (exp vs defs)) + (('begin . l) + l) + ((('begin . l)) + l) + (l l)))))))))))) (#:scm ((_ (#:string _ s)) (with-input-from-string s read))) diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 296a304..2c08f55 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -42,7 +42,7 @@ set all any bin callable reversed chr classmethod staticmethod divmod enumerate filter format - getattr hasattr hex isinstance + getattr hasattr hex isinstance issubclass iter map sum id input oct ord pow super sorted zip)) @@ -108,13 +108,20 @@ (define (hasattr a b) (let ((r (refq a (symbol->string b) miss))) (not (eq? r miss)))) - -(define (isinstance o cl) - (if (pair? cl) - (or - (isinstance o (car cl)) - (isinstance o (cdr cl))) - (is-a? o cl))) + +(define-method (issubclass (sub <p>) (cls <p>)) + (aif it (ref cl '__subclasscheck__) + (it sub) + (is-a? (ref sub '__goops__) (ref cls '__goops__)))) + +(define-method (isinstance (o <p>) (cl <p>)) + (aif it (ref cl '__instancecheck__) + (it o) + (if (pair? cl) + (or + (isinstance o (car cl)) + (isinstance o (cdr cl))) + (is-a? (ref (ref o '__class__) '__goops__) cl))) (define iter (case-lambda 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)) |