applicable structs used
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 15 Sep 2017 22:25:48 +0000 (00:25 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 15 Sep 2017 22:25:48 +0000 (00:25 +0200)
modules/language/python/compile.scm
modules/language/python/exceptions.scm
modules/language/python/spec.scm
modules/oop/pf-objects.scm
python.diff

index e74b9f211b2acdce8d6525387c316ed854957099..c3158158e36345c4bb9b489d4840c39cb6440651 100644 (file)
                                  '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))))
index 52ce80781548777a0e77c168272c9c44c8bc1167..1bbec08179c79e329b953f65edafc1cfff975835 100644 (file)
        (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__))))))
 
 
index 0cfb83afe2b7adbc88d47825a97e2e4607ead823..155de877b0dea9274d95e45c8df76489c7ef4f8f 100644 (file)
@@ -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))
index c036144c3c2fe7abb7fdbca60e772c3edea01cb4..50ea9836ba3ffabe4eac400214bb61df7af9b637 100644 (file)
@@ -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__))))
index aa2ffd7f888e6f7c0afa61fc4654ab9c54b7a8a4..ec71cf7e38a219695558d351298625dde754b730 100644 (file)
@@ -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