improved class handling
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 6 Sep 2017 21:10:26 +0000 (23:10 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 6 Sep 2017 21:10:26 +0000 (23:10 +0200)
modules/language/python/compile.scm
modules/oop/pf-objects.scm

index 151e0c2ac8661229e34d27bcd63ed63f060b6661..565fdcfe387be35633152a2ad24a9e5532f32600 100644 (file)
@@ -3,6 +3,23 @@
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
+(define-syntax clear-warning-data
+  (lambda (x)
+    (pr 'clear)
+    (set! (@@ (system base message) %dont-warn-list) '())
+    #f))
+
+(define-syntax dont-warn
+  (lambda (x)
+    (syntax-case x ()
+      ((_ d)
+       #t
+       (begin
+         (set! (@@ (system base message) %dont-warn-list)
+           (cons (syntax->datum #'d)
+                 (@@ (system base message) %dont-warn-list)))
+         #f)))))
+
 (define-syntax call
   (syntax-rules ()
     ((_ (f) . l) (f . l))))
                                (() v)))
                ',(exp vs las) ,u)))))))
 
-             
-     
+(define is-class? (make-fluid #f))
+
 (define (exp vs x)
   (match (pr x)
+    
+    ((#:power (x) () . #f)
+     (exp vs x))
     ((#:power x () . #f)
      (exp vs x))
-
+    
+    
     ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
-    ((#:power vf ((and trailer (#:identifier _ . _)) ...
-                  (#:arglist (args ...) #f #f)) . #f)
-     (let ((args (map (g vs exp) args)))
-       (match vf
-         ((#:f (#:identifier f . _) e)
-          (let ((obj  (gensym "obj"))
-                (l    (gensym "l")))
-            '(call-with-values (lambda () (fcall (,(exp vs e)
-                                                  ,@(map (g vd exp) trailer))
-                                                 ,@args))
-               (lambda (,obj . ,l)
-                 `(set! ,(string->symbol f) ,obj)
-                 (apply 'values ,l)))))
-         (x
-          `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
-                                                
+    ((#:power vf trailer . #f)
+     (let lp ((e (exp vs vf)) (trailer trailer))
+       (match trailer
+         (()
+          e)
+         ((#f)          
+          (list e))
+         ((x . trailer)
+          (match (pr x)
+            ((#:identifier . _)
+             (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
+            ((#:arglist args #f #f)
+             (lp `(,e ,@(map (g vs exp) args)) trailer))
+            (_ (error "unhandled trailer")))))))
+                                                    
     ((#:identifier x . _)
      (string->symbol x))
 
-    ((#:string x)
+    ((#:string #f x)
      x)
     
     (((and x (or #:+ #:- #:* #:/)) . l)
                 (,lp))))))
 
     ((#:classdef (#:identifier class . _) parents defs)
-     (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* ((class   (string->symbol class))
-              (parents (match parents
-                         (#f
-                          '())
-                         ((#:arglist args . _)
-                          (map (g vs exp) args))))
-              (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 (,(O 'wrap)
-                          (,(O kind)
-                           ,class
-                           ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
-                          #:const
-                          ,(match (exp vs defs)
-                             ((begin . l)
-                              l)
-                             (l l))
-                          #:dynamic
-                          ()))))))
+     (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* ((class   (string->symbol class))
+                (parents (match parents
+                           (#f
+                            '())
+                           ((#:arglist args . _)
+                            (map (g vs exp) args))))
+                (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 (,(O 'wrap)
+                            (,(O kind)
+                             ,class
+                             ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
+                             #:const
+                             ,(match (exp vs defs)
+                                (('begin . l)
+                                 l)
+                                ((('begin . l))
+                               l)
+                                (l l))
+                             #:dynamic
+                             ())))))))
                           
        
     
              #f #f)
             #f
             code)
-     (let* ((f  (string->symbol f))
+     (let* ((c? (fluid-ref is-class?))
+            (f  (string->symbol f))
             (r  (gensym "return"))
             (as (map (lambda (x) (match x
                                   ((((#:identifier x . _) . #f) #f)
             (vs (union as vs))
             (ns (scope code vs))
             (df (defs code '()))
+            (ex (gensym "ex"))
             (ls (diff (diff ns vs) df)))
-       
-       `(define ,f (lambda (,@as)
-                     (,(C 'with-return) ,r
-                      (let ,(map (lambda (x) (list x #f)) ls)
-                        ,(with-fluids ((return r))
-                           (exp ns code))))))))
+       (with-fluids ((is-class? #f))
+         (if c?
+             `(define ,f (letrec ((,f
+                                   (case-lambda
+                                     ((,ex ,@as)
+                                      (,f ,@as))
+                                     ((,@as)
+                                      (,(C 'with-return) ,r
+                                       (let ,(map (lambda (x) (list x #f)) ls)
+                                         ,(with-fluids ((return r))
+                                            (exp ns code))))))))
+                           ,f))
+
+             `(define ,f (lambda (,@as)
+                           (,(C 'with-return) ,r
+                            (let ,(map (lambda (x) (list x #f)) ls)
+                              ,(with-fluids ((return r))
+                                 (exp ns code))))))))))
      
     ((#:global . _)
      '(values))
     ((#:expr-stmt l (#:assign u))
      (cond
       ((= (length l) (length u))
-       (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
+       (if (= (length l) 1)
+           (make-set vs (car l) (exp vs (car u)))
+           (cons 'begin
+                 (map make-set
+                      (map (lambda x vs) l)
+                      l
+                      (map (g vs exp) u)))))
       ((= (length u) 1)
        (let ((vars (map (lambda (x) (gensym "v")) l)))
          `(call-with-values (lambda () (exp vs (car u)))
                   (exp '() x))
                 arglist))
 
-         `((,(G 'define-module) (language python module ,@args)))))
+         `((,(G 'define-module)
+            (language python module ,@args)))))
       (x '())))
   
   (if (pair? start)
   (let ((globs (get-globals x)))
     `(begin
        ,@start
+       ,(C 'clear-warning-data)
+       (set! (@@ (system base message) %dont-warn-list) '())
        ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
        ,@(map (g globs exp) x))))
 
              code))))))
 
 (define-syntax-rule (var v)
-  (if (defined? 'v)
-      (values)
-      (define! 'v #f)))
+  (begin
+    (dont-warn v)
+    (if (defined? 'v)
+        (values)
+        (define! 'v #f))))
 
index 0c54bd4ef1527e4b93d3f2eec6ab8704b2f99d89..ecb94f6e33a24f4df8b36bf18142f547e76d6e3e 100644 (file)
@@ -90,7 +90,7 @@ explicitly tell it to not update etc.
                          (let ((parent (car parents)))
                            (let ((r (lp (slot-ref parent 'h))))
                              (if (eq? r fail)
-                                 (lp (cdr parents))
+                                 (lpp (cdr parents))
                                  r)))
                          fail))
                    fail)
@@ -136,7 +136,14 @@ explicitly tell it to not update etc.
 (define-method (ref (x <p>  )  key . l) (mref-    x key l))
 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 (define-method (ref (x <py> )  key . l) (mref-py- x key l))
-
+(define-method (ref x key . l)
+  (define (end)   (if (pair? l) (car l) #f))
+  (if (procedure? x)
+      (aif it (procedure-property x 'pyclass)
+           (apply ref it key l)
+           (end))
+      (end)))
+      
 
 
 ;; the reshape function that will create a fresh new pf object with less size
@@ -459,7 +466,8 @@ explicitly tell it to not update etc.
                                           #'(supers (... ...)))))
            #'(let ((sups supers) (... ...))
                (define class dynamic)
-               (define name (make-class (list sups (... ...) <p>) '()))
+               (define name (make-class (list (ref sups '__goops__ #f)
+                                              (... ...) <p>) '()))
                
                (set! class
                  (union- const