diff options
| -rw-r--r-- | modules/language/python/compile.scm | 25 | ||||
| -rw-r--r-- | modules/language/python/exceptions.scm | 9 | ||||
| -rw-r--r-- | modules/language/python/spec.scm | 4 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 150 | ||||
| -rw-r--r-- | python.diff | 15 |
5 files changed, 106 insertions, 97 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index e74b9f2..c315815 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -361,19 +361,18 @@ 'mk-p-class 'mk-py-class))) (parents (filt parents))) - `(define ,class (,(O 'wrap) ,class - (,(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 - ()))))))) + `(define ,class (,(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 + ())))))) ((#:import ((() nm) . #f)) `(use-modules (language python module ,(exp vs nm)))) diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm index 52ce807..1bbec08 100644 --- a/modules/language/python/exceptions.scm +++ b/modules/language/python/exceptions.scm @@ -19,12 +19,11 @@ (set self 'str str)))) (define __repr__ - (lambda (self . l) - (define port (if (pair? l) (car l) #f)) - (aif it (ref self 'str) - (format port "<~s: ~a>" + (lambda (self) + (aif it (ref self 'str #f) + (format #f "~a:~a" (ref self '__name__) it) - (format port "<~s>" + (format #f "~a" (ref self '__name__)))))) diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm index 0cfb83a..155de87 100644 --- a/modules/language/python/spec.scm +++ b/modules/language/python/spec.scm @@ -29,7 +29,9 @@ (define-language python #:title "python" #:reader (lambda (port env) - (cc port (read-string port))) + (if (not (fluid-ref (@@ (system base compile) %in-compile))) + (cc port (read-line port)) + (cc port (read-string port)))) #:compilers `((tree-il . ,compile-tree-il)) #:decompilers `((tree-il . ,decompile-tree-il)) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index c036144..50ea983 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -5,12 +5,11 @@ #:export (set ref make-pf <p> <py> <pf> <pyf> call with copy fset fcall make-p put put! pcall pcall! get fset-x - mk wrap def-pf-class mk-pf-class make-pf-class 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 + define-python-class get-type )) #| Python object system is basically syntactic suger otop of a hashmap and one @@ -27,24 +26,56 @@ explicitly tell it to not update etc. |# (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-class <p> () h) +(define-class <p> (<applicable-struct>) h) (define-class <pf> (<p>) size n) ; the pf object consist of a functional ; hashmap it's size and number of live ; object (define-class <py> (<p>)) (define-class <pyf> (<pf>)) +(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)) + + ((is-a? x <p>) + (let ((r (ref x '__const__)) + (h (make-hash-table))) + (hash-set! h '__class__ x) + (slot-set! o 'h h)) + o)))) + +(define (make-pyclass x) + (letrec ((class (make x))) + (slot-set! class 'procedure + (lambda x + (let ((obj (mk class))) + (aif it (ref obj '__init__) + (apply it x) + (values)) + obj))) + class)) + ;; Make an empty pf object (define (make-pf) - (define r (make <pf>)) + (define r (make-pyclass <pf>)) (slot-set! r 'h vlist-null) (slot-set! r 'size 0) (slot-set! r 'n 0) r) (define (make-p) - (define r (make <p>)) + (define r (make-pyclass <p>)) (slot-set! r 'h (make-hash-table)) r) @@ -125,7 +156,7 @@ explicitly tell it to not update etc. (if (eq? r fail) (aif class (hash-ref h '__class__) (ret (find-in-class (slot-ref class 'h))) - fail) + (end)) r)))) (define not-implemented (cons 'not 'implemeneted)) @@ -160,16 +191,7 @@ 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 ;; this is an expensive operation and will only be done when we now there is ;; a lot to gain essentially tho complexity is as in the number of set @@ -277,7 +299,7 @@ explicitly tell it to not update etc. ;; make a copy of a pf object (define-syntax-rule (mcopy x) - (let ((r (make <pf>))) + (let ((r (make-pyclass <pf>))) (slot-set! r 'h (slot-ref x 'h)) (slot-set! r 'size (slot-ref x 'size)) (slot-set! r 'n (slot-ref x 'n)) @@ -468,7 +490,7 @@ explicitly tell it to not update etc. hy hx)) - (define out (make <pf>)) + (define out (make-pyclass <pf>)) (slot-set! out 'h h) (slot-set! out 'n n) (slot-set! out 'size s) @@ -500,24 +522,24 @@ explicitly tell it to not update etc. (define class dynamic) (define name (make-class (list sups (... ...) <pf>) '())) - (put! class.__const__ - (union const - (let lp ((sup (list sups (... ...)))) - (if (pair? sup) - (union (ref (car sup) '__const__ null) - (lp (cdr sup))) - null)))) - - (reshape (get class.__const__ null)) + (define __const__ + (union const + (let lp ((sup (list sups (... ...)))) + (if (pair? sup) + (union (ref (car sup) '__const__ null) + (lp (cdr sup))) + null)))) - (put! class.__goops__ name) - (put! class.__name__ 'name) - (put! class.__parents__ (list sups (... ...))) + (reshape __const__) + (set class '__const__ __const__) + (set class '__goops__ name) + (set class '__name__ 'name) + (set class '__parents__ (list sups (... ...))) - (put! class.__const__.__name__ (cons 'name 'obj)) - (put! class.__const__.__class__ class) - (put! class.__const__.__parents__ (list sups (... ...))) - (put! class.__const__.__goops__ name) + (set __const__ '__name__ 'name) + (set __const__ '__class__ class) + (set __const__ '__parents__ (list sups (... ...))) + (set __const__ '__goops__ name) class))))))) (mk-pf make-pf-class <pf>) @@ -554,23 +576,6 @@ explicitly tell it to not update etc. (mk-p make-py-class <py>) ;; Let's make an object essentially just move a reference -(define-method (mk (x <pf>) . l) - (let ((r (ref x '__const__)) - (o (make (ref x '__goops__)))) - (slot-set! o 'h (slot-ref r 'h)) - (slot-set! o 'size (slot-ref r 'size)) - (slot-set! o 'n (slot-ref r 'n)) - (apply (ref o '__init__ (lambda x (error "no init fkn"))) o l) - o)) - - -(define-method (mk (x <p>) . l) - (let ((o (make (ref x '__goops__))) - (h (make-hash-table))) - (slot-set! o 'h h) - (hash-set! h '__class__ x) - (apply (ref o '__init__ (lambda x (error "no init fkn"))) l) - o)) ;; the make class and defclass syntactic sugar (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class) @@ -608,20 +613,12 @@ explicitly tell it to not update etc. (define-syntax-rule (def-py-class name . l) (define name (mk-py-class name . l))) -(define-syntax-rule (wrap name class) - (let* ((c class) - (name (lambda x (apply mk c x)))) - (set-procedure-property! name 'pyclass c) - name)) - (define (get-class o) (cond - ((procedure? o) - (aif it (procedure-property o 'pyclass) - it - (error "not an object ~a" o))) + ((is-a? o <p>) + o) (else - (class-of o)))) + (error "not a pyclass")))) (define (get-type o) (cond @@ -637,23 +634,26 @@ explicitly tell it to not update etc. 'none))) (define (print o l) + (define p1 (if (pyclass? o) "Class" "Object")) + (define p2 (if (pyclass? o) "Class" "Object")) (define port (if (pair? l) (car l) #t)) - (format port - (aif it (ref o '__repr__) - (it) - (format #f - "~a:~a" (get-type o) (ref o '__name__ 'None))))) + (format port "~a" + (aif it (ref o '__repr__ #f) + (format + #f "~a(~a)<~a>" p1 (get-type o) (it)) + (format + #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None))))) (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 - (wrap name - (mk-py-class name parents - #:const - (code ...) - #:dynamic - ())))) + (mk-py-class name parents + #:const + (code ...) + #:dynamic + ()))) + +(define (pyclass? x) + (and (is-a? x <p>) (not (ref x '__class__)))) diff --git a/python.diff b/python.diff index aa2ffd7..ec71cf7 100644 --- a/python.diff +++ b/python.diff @@ -1,8 +1,8 @@ diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm -index c110512f0..d5d63a9e0 100644 +index c110512f0..83a3b479d 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm -@@ -132,9 +132,30 @@ +@@ -132,14 +132,38 @@ (and (false-if-exception (ensure-directory (dirname f))) f)))) @@ -26,7 +26,9 @@ index c110512f0..d5d63a9e0 100644 + default))) + default)) + -+ ++ ++(define %in-compile (make-fluid #f)) ++ (define* (compile-file file #:key (output-file #f) - (from (current-language)) @@ -34,6 +36,13 @@ index c110512f0..d5d63a9e0 100644 (to 'bytecode) (env (default-environment from)) (opts '()) + (canonicalization 'relative)) +- (with-fluids ((%file-port-name-canonicalization canonicalization)) ++ (with-fluids ((%in-compile #t) ++ (%file-port-name-canonicalization canonicalization)) + (let* ((comp (or output-file (compiled-file-name file) + (error "failed to create path for auto-compiled file" + file))) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 979291c1e..c0d639235 100644 --- a/module/system/base/message.scm |