diff options
Diffstat (limited to 'modules/language/python/def.scm')
-rw-r--r-- | modules/language/python/def.scm | 80 |
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 ...))))))))))))) + + + |