class system refactoring to enable metaclasses

2 files changed, 53 insertions, 61 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