From e86c78681c37db0db830770dafb0fe42a6c968ac Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Wed, 20 Sep 2017 23:29:40 +0200
Subject: the python def is now working

---
 modules/language/python/def.scm | 101 +++++++++++++++++++++-------------------
 1 file changed, 53 insertions(+), 48 deletions(-)

(limited to 'modules/language/python/def.scm')

diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm
index d149348..a9aa692 100644
--- a/modules/language/python/def.scm
+++ b/modules/language/python/def.scm
@@ -1,5 +1,7 @@
 (define-module (language python def)
-  #:export (def))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-11)
+  #:export (def lam))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 (define (fold lam s l)
@@ -7,74 +9,77 @@
       (lam (car l) (fold lam s (cdr l)))
       s))
 
+(define-syntax-rule (take-1 ww* kw s v)
+  (if (null? ww*)
+      (values ww*
+              (aif it (hash-ref kw s #f)
+                   (begin
+                     (hash-remove! kw s)
+                     it)
+                   v))
+      (begin
+        (hash-remove! kw s)
+        (values (cdr ww*) (car ww*)))))
 
-(define-syntax def
-  (lambda (x)
-    (define (get-akw l)
-      (let lp ((l l) (args '()) (kw (make-hash-table)))
-        (match l
-          (((? keyword? k) v . l)
-           (hash-set! kw k v)
-           (lp l args kw))
-          ((x . l)
-           (lp l (cons x args) k))
-          (()
-           (values (reverse args) kw)))))
+(define (get-akw l)
+  (let lp ((l l) (args '()) (kw (make-hash-table)))
+    (match l
+      (((? keyword? k) v . l)
+       (hash-set! kw k v)
+       (lp l args kw))
+      ((x . l)
+       (lp l (cons x args) kw))
+      (()
+       (values (reverse args) kw)))))
 
+(define-syntax lam
+  (lambda (x)
     (define-syntax-rule (mk get-as (k v s) x y z w)
       (define get-as
         (lambda (a s)
           (syntax-case a (= * **)
-            ((= k v) #'x)
-            ((**  k) #'y)
-            ((*   k) #'z)          
-            (k       #'w)))))
+            ((= k v) x)
+            ((**  k) y)
+            ((*   k) z)          
+            (k       w)))))
 
-    (mk get-as (k v s)  s                    s           s           (cons k s))
-    (mk get-kw (k v s)  s                    (cons k s)  s           s         )
-    (mk get-ww (k v s)  s                    s           (cons k s)  s         )
-    (mk get-kv (k v s)  (cons (cons k v) s)  s           s           s         )
+    (mk get-as (k v s)
+        s                       s            s            (cons #'k s))
+    (mk get-kw (k v s)
+        s                       (cons #'k s) s            s           )
+    (mk get-ww (k v s)
+        s                       s            (cons #'k s) s           )
+    (mk get-kv (k v s)
+        (cons (cons #'k #'v) s) s            s            s           )
 
     (define (->kw x) (symbol->keyword (syntax->datum x)))
-
-    (define-syntax-rule (take-1 ww* kw s v)
-      (if (null? ww*)
-          (values ww*
-                  (aif it (hash-ref kw s #f)
-                       (begin
-                         (remove-hash! kw s)
-                         it)
-                       v))
-          (begin
-            (remove-hash! kw s)
-            (values (cdr ww) (car ww)))))
     
     (syntax-case x ()
-      ((_ f (arg ...) code ...)
+      ((_ (arg ...) code ...)
        (let* ((as  (fold get-as '() #'(arg ...)))
               (kw  (fold get-kw '() #'(arg ...)))
               (ww  (fold get-ww '() #'(arg ...)))
               (kv  (fold get-kv '() #'(arg ...))))
          (if (and-map null? (list kw ww kv))
-             #`(define f (lambda #,as code ....))
-             (with-syntax ((l       (datum->syntax #'f  (gensym "l")))
-                           (kw      (if (null? kw)
-                                        (datum->syntax #'f (gensym "kw"))
+             #`(lambda #,as code ...)
+             (with-syntax ((kw      (if (null? kw)
+                                        (datum->syntax x (gensym "kw"))
                                         (car kw)))
                            (ww      (if (null? ww)
-                                        (datum->syntax #'f (gensym "ww"))
-                                        (car ww)))                           
+                                        (datum->syntax x (gensym "ww"))
+                                        (car ww)))
                            ((k ...) (map car kv))
                            ((s ...) (map ->kw (map car kv)))
                            ((v ...) (map cdr kv)))
-               #`(define f                   
-                   (lambda* (#,@as . l)                     
-                     (call-with-values (get-akv l)
-                       (lambda (ww* kw)
-                         (let-values* (((ww* k) (take-1 ww* kw s v))
-                                       ...)
-                           (let ((ww ww*))
-                             code ...)))))))))))))
+              #`(lambda* (#,@as . l)                     
+                   (call-with-values (lambda () (get-akw l))
+                     (lambda (ww* kw)
+                       (let*-values (((ww* k) (take-1 ww* kw s v))
+                                     ...)
+                         (let ((ww ww*))
+                           code ...))))))))))))
+
+(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
                                               
                                  
                                  
-- 
cgit v1.2.3