1 files changed, 80 insertions, 0 deletions
diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm
new file mode 100644
index 0000000..d149348
--- /dev/null
+++ b/modules/language/python/def.scm
@@ -0,0 +1,80 @@
+(define-module (language python def)
+  #:export (def))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+(define (fold lam s l)
+  (if (pair? l)
+      (lam (car l) (fold lam s (cdr l)))
+      s))
+
+
+(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-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)))))
+
+    (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 ...)
+       (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"))
+                                        (car kw)))
+                           (ww      (if (null? ww)
+                                        (datum->syntax #'f (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 ...)))))))))))))
+                                              
+                                 
+