refactoring scheme macros out from the compilier
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 14 Sep 2017 21:25:49 +0000 (23:25 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 14 Sep 2017 21:25:49 +0000 (23:25 +0200)
modules/language/python/compile.scm
modules/language/python/exceptions.scm [new file with mode: 0644]
modules/language/python/for.scm
modules/language/python/try.scm [new file with mode: 0644]
modules/language/python/yield.scm [new file with mode: 0644]
modules/oop/pf-objects.scm

index 962c8775ed5b6159d693cb5c33dce728d48fac62..e74b9f211b2acdce8d6525387c316ed854957099 100644 (file)
@@ -3,9 +3,12 @@
   #:use-module (ice-9 control)
   #:use-module (oop pf-objects)
   #:use-module (oop goops)
+  #:use-module (language python exceptions)
+  #:use-module (language python yield)
+  #:use-module (language python for)
+  #:use-module (language python try)
   #:use-module (ice-9 pretty-print)
-  #:replace (send)
-  #:export (comp sendException sendClose))
+  #:export (comp))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
@@ -44,6 +47,7 @@
   x)
 
 (define (C x) `(@@ (language python compile) ,x))
+(define (Y x) `(@@ (language python yield) ,x))
 (define (O x) `(@@ (oop pf-objects) ,x))
 (define (G x) `(@ (guile) ,x))
 
 
     (#:True  #t)
     (#:False #f)
-    
+    (#:pass  `(values))
     ((#:while test code . #f)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
                                  'mk-p-class
                                  'mk-py-class)))              
                 (parents (filt parents)))
-           `(define ,class (,(O 'wrap)
-                            (,(O kind)
+           `(define ,class (,(O 'wrap) ,class
+                            (,(O kind) 
                              ,class
                              ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
                              #:const
     ((#:yield args)
      (let ((f (gensym "f")))
        `(begin
-          (set! ,(C 'inhibit-finally) #t)
+          (fluid-set! ,(Y 'in-yield) #t)
           (let ((,f (scm.yield ,@(gen-yargs vs args))))
             (,f)))))
 
                                (lp)))))
                        (lambda e else))))))))))))
     
-
-(define-class <scm-list>   () l)
-(define-class <scm-string> () s i)
-(define-class <yield>      () s k closed)
-  
-(define-method (next (l <scm-list>))
-  (let ((ll (slot-ref l 'l)))
-    (if (pair? ll)
-        (begin
-          (slot-set! l 'l (cdr ll))
-          (car ll))
-        (throw StopIteration))))
-
-(define-method (next (l <scm-string>))
-  (let ((s (slot-ref l 's))
-        (i (slot-ref l 'i)))
-    (if (= i (string-length s))
-        (throw StopIteration)
-        (begin
-          (slot-set! l 'i (+ i 1))
-          (string-ref s i)))))
-
-(define-method (next (l <yield>))
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's)))
-    (if k
-        (k (lambda () 'None))
-        (s))))
-
-(define-method (send (l <yield>) . u)
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if (not c)
-        (if k
-            (k (lambda ()
-                 (if (null? u)
-                     'Null
-                     (apply values u))))
-            (throw 'python (Exception))))))
-
-
-(define-method (sendException (l <yield>) e . ls)
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if (not c)
-        (if k
-            (k (lambda () (throw 'python (apply e ls))))
-            (throw 'python (Exception))))))
-
-(define-method (sendClose (l <yield>))
-  (let ((k (slot-ref l 'k))
-        (s (slot-ref l 's))
-        (c (slot-ref l 'closed)))
-    (if c
-        (values)
-        (if k
-            (catch #t
-              (lambda ()
-                (k (lambda () (throw 'python GeneratorExit)))
-                (slot-set! l 'closed #t)
-                (throw 'python RuntimeError))
-              (lambda (k tag . v)
-                (slot-set! l 'closed #t)
-                (if (eq? tag 'python)
-                    (match v
-                      ((tag . l)
-                       (if (eq? tag GeneratorExit)
-                           (values)
-                           (apply throw 'python tag l))))
-                    (apply throw tag v))))
-            (slot-set! l 'closed #t)))))
-
-(define-method (send (l <p>) . u)
-  (apply (ref l '__send__) u))
-
-(define-method (sendException (l <p>) . u)
-  (apply (ref l '__exception__) u))
-
-(define-method (sendClose (l <p>))
-  ((ref l '__close__)))
-
-(define-method (next (l <p>))
-  ((ref l '__next__)))
-
-
-
-(define-method (wrap-in  (x <p>))
-  (aif it (ref x '__iter__ #f)
-       (it)
-       x))
-
-(define-method (wrap-in x)
-  (cond
-   ((pair? x)
-    (let ((o (make <scm-list>)))
-      (slot-set! o 'l x)
-      o))
-   
-   ((string? x)
-    (let ((o (make <scm-string>)))
-      (slot-set! o 's x)
-      (slot-set! o 'i 0)
-      o))
-   
-   (else
-    x)))
-
-(define yield-prompt (list 'yield))
 (define-syntax def-wrap
   (lambda (x)
     (syntax-case x ()
                            (throw StopIteration))
                          (letrec ((lam
                                    (lambda (k . l)
-                                     (set! inhibit-finally #f)
+                                     (fluid-set! in-yield #f)
                                      (slot-set! obj 'k
                                                 (lambda (a)
                                                   (call-with-prompt
                            lam))))
            obj)))))
                       
-
-                      
 (define-syntax ref-x
   (syntax-rules ()
     ((_ v)
diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm
new file mode 100644 (file)
index 0000000..57690aa
--- /dev/null
@@ -0,0 +1,33 @@
+(define-module (language python exceptions)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:export (StopIteration GeneratorExit RuntimeError
+                          Exception))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define StopIteration 'StopIteration)
+(define GeneratorExit 'GeneratorExit)
+(define RuntimeError  'RuntimeError)
+
+(define-python-class Exception ()
+  (define __init__
+    (case-lambda
+      ((self)
+       (values))
+      ((self str)
+       (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"
+                   (ref self '__name__) it)
+           (format port "~s"
+                   (ref self '__name__))))))
+
+
+
+
+            
index 47f699229e1280363145c7f972fed9cb99d5ae3d..f23ce6e8c0bc83ff9464c2838637046a318e4fc0 100644 (file)
@@ -1,7 +1,12 @@
 (define-module (language python for)
+  #:use-module (language python yield)
   #:use-module (oop pf-objects)
+  #:use-module (language python exceptions)
+  #:use-module (oop goops)
   #:use-module (ice-9 control)
-  #:export (for break))
+  #:export (for break next write))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
 (eval-when (compile eval load)
   (define (generate-temporaries2 x)
                    (lambda q (values)))))))))))
 
 
+(define-class <scm-list>   () l)
+(define-class <scm-string> () s i)
+  
+(define-method (next (l <scm-list>))
+  (let ((ll (slot-ref l 'l)))
+    (if (pair? ll)
+        (begin
+          (slot-set! l 'l (cdr ll))
+          (car ll))
+        (throw StopIteration))))
+
+(define-method (next (l <scm-string>))
+  (let ((s (slot-ref l 's))
+        (i (slot-ref l 'i)))
+    (if (= i (string-length s))
+        (throw StopIteration)
+        (begin
+          (slot-set! l 'i (+ i 1))
+          (string-ref s i)))))
+
+(define-method (next (l <yield>))
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's)))
+    (if k
+        (k (lambda () 'None))
+        (s))))
+
+
+(define-method (next (l <p>))
+  ((ref l '__next__)))
+
+(define-method (wrap-in  (x <p>))
+  (aif it (ref x '__iter__ #f)
+       (it)
+       x))
+
+(define-method (wrap-in x)
+  (cond
+   ((pair? x)
+    (let ((o (make <scm-list>)))
+      (slot-set! o 'l x)
+      o))
+   
+   ((string? x)
+    (let ((o (make <scm-string>)))
+      (slot-set! o 's x)
+      (slot-set! o 'i 0)
+      o))
+   
+   (else
+    x)))
+
+
 #;
 (pk
  (for c ((x : (gen '(1 2 3)))) ((s 0))
diff --git a/modules/language/python/try.scm b/modules/language/python/try.scm
new file mode 100644 (file)
index 0000000..2d10ad2
--- /dev/null
@@ -0,0 +1,94 @@
+(define-module (language python try)
+  #:use-module (language python exceptions)
+  #:use-module (language python yield)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:export (raise try))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define-method (check (class <class> ) obj l) (is-a? obj class))
+(define-method (check (s     <symbol>) obj l) (eq? obj s))
+(define-method (check (p  <procedure>) obj l)
+  (aif it (procedure-property p 'pyclass)
+       (is-a? obj it)
+       (p obj l)))
+  
+(define-syntax compile-error
+  (lambda (x)
+    (syntax-case x ()
+      ((_ x)
+       (error (syntax->datum #'x))))))
+
+(define-syntax check-exception
+  (syntax-rules (and or not)
+    ((_ (or E ...) tag l)
+     (or (check-exception E tag l) ...))
+    ((_ (and E ...) tag l)
+     (and (check-exception E tag l) ...))
+    ((_ (not E) tag l)
+     (not (check-exception E tag l)))
+    ((_ E tag l)
+     (check E tag l))))
+
+(define-syntax handler
+  (syntax-rules ()
+    ((handler ecx)
+     (lambda x
+       (match x
+         ((_ 'python tag . l)
+          (handler ecx tag l))
+         ((k . x)
+          (apply throw x)))))
+    
+    ((handler ((#:except E => lam) . ecx) tag l)
+     (if (check-exception E tag l)
+         (lam tag l)
+         (handler ecx tag l)))
+
+    ((handler ((#:except E code ...) . ecx) tag l)
+     (if (check-exception E tag l)
+         (begin code ...)
+         (handler ecx tag l)))
+
+    ((handler ((#:else code ...)) tag l)
+     (begin code ...))
+
+    ((handler () tag l)
+     (apply throw 'python tag l))
+
+    ((a ...)
+     (compile-error "not a proper python macro try block"))))
+
+    
+    
+(define-syntax try
+  (syntax-rules ()
+    ((try  code exc ... #:finally fin)
+     (dynamic-wind
+       (lambda () #f)
+       (lambda ()
+         (catch #t
+           (lambda () code)
+           (handler (exc ...))))
+       (lambda ()
+         (if (not (fluid-ref in-yield))
+             fin))))
+
+    ((try  code exc ...)
+     (catch #t
+       (lambda () code)
+       (handler (exc ...))))))
+  
+
+(define raise
+  (case-lambda
+    (() (raise Exception))
+    ((x)
+     (if (procedure? x)
+         (if (procedure-property x 'pyclass)
+             (throw 'python (x))
+             (throw 'python x))
+         (throw 'python x)))))
diff --git a/modules/language/python/yield.scm b/modules/language/python/yield.scm
new file mode 100644 (file)
index 0000000..289eb4d
--- /dev/null
@@ -0,0 +1,116 @@
+(define-module (language python yield)
+  #:use-module (oop pf-objects)
+  #:use-module (language python exceptions)
+  #:use-module (oop goops)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:replace (send)
+  #:export (<yield> in-yield yield define-generator
+                    make-generator
+                    sendException sendClose))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define in-yield (make-fluid #f))
+
+(define-syntax-parameter YIELD (lambda (x) #f))
+
+(define-syntax yield
+  (lambda (x)
+    (syntax-case x ()
+      ((_ x ...)
+       #'(begin
+           (fluid-set! in-yield #t)
+           abort-to-prompt YIELD x ...))
+      (x
+       #'(lambda x
+           (fluid-set! in-yield #t)
+           (apply abort-to-prompt YIELD x))))))
+
+(define-syntax-rule (make-generator (args) code ...)
+  (lambda args
+    (let ()
+      (define obj   (make <yield>))
+      (define ab (make-prompt-tag))
+      (syntax-parameterize ((YIELD (lambda x #'ab)))
+        (slot-set! obj 'k #f)
+        (slot-set! obj 'closed #f)
+        (slot-set! obj 's
+                   (lambda ()
+                     (call-with-prompt
+                      ab
+                      (lambda ()
+                        code ...
+                        (slot-set! obj 'closed #t)
+                        (throw StopIteration))
+                      (letrec ((lam
+                                (lambda (k . l)
+                                  (set! in-yield #f)
+                                  (slot-set! obj 'k
+                                             (lambda (a)
+                                               (call-with-prompt
+                                                ab
+                                                (lambda ()
+                                                  (k a))
+                                                lam)))
+                                  (apply values l))))
+                        lam))))
+        ob))))
+
+(define-syntax-rule (define-generator (f . args) code ...)
+  (define f (make-generator args code ...)))
+(define-class <yield>      () s k closed)
+
+(define-method (send (l <yield>) . u)
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if (not c)
+        (if k
+            (k (lambda ()
+                 (if (null? u)
+                     'Null
+                     (apply values u))))
+            (throw 'python (Exception))))))
+
+
+(define-method (sendException (l <yield>) e . ls)
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if (not c)
+        (if k
+            (k (lambda () (throw 'python (apply e ls))))
+            (throw 'python (Exception))))))
+
+(define-method (sendClose (l <yield>))
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if c
+        (values)
+        (if k
+            (catch #t
+              (lambda ()
+                (k (lambda () (throw 'python GeneratorExit)))
+                (slot-set! l 'closed #t)
+                (throw 'python RuntimeError))
+              (lambda (k tag . v)
+                (slot-set! l 'closed #t)
+                (if (eq? tag 'python)
+                    (match v
+                      ((tag . l)
+                       (if (eq? tag GeneratorExit)
+                           (values)
+                           (apply throw tag l))))
+                    (apply throw tag v))))
+            (slot-set! l 'closed #t)))))
+
+(define-method (send (l <p>) . u)
+  (apply (ref l '__send__) u))
+
+(define-method (sendException (l <p>) . u)
+  (apply (ref l '__exception__) u))
+
+(define-method (sendClose (l <p>))
+  ((ref l '__close__)))
index ca9a11b4b98b82f3ad2b782f4e78ced5f47e95ac..c270e1127021a971ddc716b5d160b15905dcea24 100644 (file)
@@ -4,15 +4,14 @@
   #:use-module (ice-9 match)
   #:export (set ref make-pf <p> <py> <pf> <pyf>
                 call with copy fset fcall make-p put put!
-                pcall pcall! get next fset-x
-                mk
+                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
-                StopIteration GeneratorExit RuntimeError
-                Exception))
-
+                define-python-class
+                ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
 this project is inspired by the python object system and what it measn when
@@ -609,69 +608,68 @@ 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 class)
-  (let* ((c   class)
-         (ret (lambda x (apply mk c x))))
-    (set-procedure-property! ret 'pyclass c)
-    ret))
-
-(define (get-class x)
-  (aif it (procedure-property x 'pyclass)
-       it
-       (error "not a class")))
-
-(define StopIteration 'StopIteration)
-(define GeneratorExit 'GeneratorExit)
-(define RuntimeError  'RuntimeError)
-
-(define-method (next (o <p>))
-  (catch StopIteration
-    (lambda () ((ref o '__next__)))
-    (lambda (x) #:nil)))
-       
-
-(define-inlinable (super-obj tag ex)
-  (let* ((classtag (ref tag '__class__ #f))
-         (exid     (ref ex '__goops__ #f)))
-    (let check-class ((tag classtag))
-      (if (and exid (eq? (ref tag '__goops__ #f) exid))
-          #t
-          (let lp ((parents (ref tag '__parents__ '())))
-            (if (pair? parents)
-                (or
-                 (check-class (car parents))
-                 (lp (cdr parents)))
-                #f))))))
-
-(define-inlinable (pyclass? x)
-  (and (procedure? x) (procedure-property x 'pyclass)))
-
-
-(define-method (testex py (tag <p>) (ex <p>) . l)
-  (super-obj tag ex))
-
-(define-method (testex py tag ex l)
-  (if (eq? py 'python)
-      (cond
-       ((pair? ex)
-        (or
-         (testex py tag (car ex) l)
-         (testex py tag (cdr ex) l)))
-       ((pyclass? ex)
-        =>
-        (lambda (cl)
-          (testex py tag cl l)))
-       (else
-        (eq? tag ex)))
-      #f))
-
-
-
-(define Exception
-  (wrap
-   (mk-py-class Exception ()
-                #:const
-                ((define __init__
-                   (lambda (self) (values))))                
-                #:dynamic
-                ())))
+(define-syntax-rule (wrap name class)
+  (let* ((c    class)
+         (name (lambda x (apply mk c x))))
+    (set-procedure-property! name 'pyclass c)
+    name))
+
+(define-method (write (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (display (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (write (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (display (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
+
+(define-method (write (o <pf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
+
+(define-method (display (o <pf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (write (o <py>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
+
+(define-method (display (o <py>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
+
+
+(define-method (write (o <pyf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
+
+(define-method (display (o <pyf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
+
+(define-syntax-rule (define-python-class name parents code ...)
+  (define name
+    (wrap name
+          (mk-py-class name parents
+                       #:const
+                       (code ...)
+                       #:dynamic
+                       ()))))