summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--modules/language/python/compile.scm214
-rw-r--r--modules/oop/pf-objects.scm14
2 files changed, 142 insertions, 86 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 151e0c2..565fdcf 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -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))))
@@ -131,34 +148,37 @@
(() 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)
@@ -214,57 +234,60 @@
(,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
+ ())))))))
@@ -371,7 +394,8 @@
#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)
@@ -380,13 +404,26 @@
(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))
@@ -406,7 +443,13 @@
((#: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)))
@@ -460,7 +503,8 @@
(exp '() x))
arglist))
- `((,(G 'define-module) (language python module ,@args)))))
+ `((,(G 'define-module)
+ (language python module ,@args)))))
(x '())))
(if (pair? start)
@@ -469,6 +513,8 @@
(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))))
@@ -548,7 +594,9 @@
code))))))
(define-syntax-rule (var v)
- (if (defined? 'v)
- (values)
- (define! 'v #f)))
+ (begin
+ (dont-warn v)
+ (if (defined? 'v)
+ (values)
+ (define! 'v #f))))
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 0c54bd4..ecb94f6 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -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
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 12:17:33 +0000