class system refactoring to enable metaclasses
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Oct 2017 22:11:39 +0000 (00:11 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Oct 2017 22:11:39 +0000 (00:11 +0200)
modules/language/python/compile.scm
modules/language/python/module/python.scm
modules/oop/pf-objects.scm

index 49c6a6499eb11a8be3e5b280c3fa54dbf59ab5bf..a040c7de290b385fbd30c3666a5aa1ba8727e63e 100644 (file)
       (()
        '()))))
 
+(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
     (() '())
                           `(#: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))
   ((_ . 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)))
index 296a30445c3aa11afe29f8b2f95a106354e01737..2c08f550570c7a90ec4213afa2a6538c9b00f56d 100644 (file)
@@ -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))
 
 (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
index f7680271b5f7504e85cadd48d3123952a5753c0f..a72d360f314de72df760e4bf5e9b995a5f132a20 100644 (file)
@@ -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))