Correctly substitute directory names in 'python' executable.
[software/python-on-guile.git] / modules / language / python / def.scm
1 (define-module (language python def)
2 #:use-module (ice-9 pretty-print)
3 #:use-module (oop pf-objects)
4 #:use-module (language python exceptions)
5 #:use-module (ice-9 match)
6 #:use-module (srfi srfi-11)
7 #:export (def lam py-apply))
8
9 (define e (list 'error))
10 (define-syntax-rule (aif it p x y) (let ((it p)) (if (not (eq? it e)) x y)))
11 (define (fold lam s l)
12 (if (pair? l)
13 (lam (car l) (fold lam s (cdr l)))
14 s))
15
16 (define-syntax-rule (take-1 pww ww* kw s v)
17 (if (not pww)
18 (values ww*
19 (aif it (hash-ref kw s e)
20 (begin
21 (hash-remove! kw s)
22 it)
23 v))
24 (if (pair? ww*)
25 (begin
26 (hash-remove! kw s)
27 (values (cdr ww*) (car ww*)))
28 (values ww*
29 (aif it (hash-ref kw s e)
30 (begin
31 (hash-remove! kw s)
32 it)
33 v)))))
34
35
36 (define (get-akw l)
37 (let lp ((l l) (args '()) (kw (make-hash-table)))
38 (match l
39 (((? keyword? k) v . l)
40 (hash-set! kw k v)
41 (lp l args kw))
42 ((x . l)
43 (lp l (cons x args) kw))
44 (()
45 (values (reverse args) kw)))))
46
47 (define hset! hash-set!)
48
49 (define (pytonize kw)
50 (hash-fold
51 (lambda (k v h)
52 (hset! h (symbol->string (keyword->symbol k)) v)
53 h)
54 (make-hash-table)
55 kw))
56
57 (define-syntax lam
58 (lambda (x)
59 (define-syntax-rule (mk get-as (k v s) x y z w)
60 (define get-as
61 (lambda (a s)
62 (syntax-case a (= * **)
63 ((= k v) x)
64 ((** k) y)
65 ((* k) z)
66 (k w)))))
67
68 (mk get-as (k v s)
69 s s s (cons #'k s))
70 (mk get-kw (k v s)
71 s (cons #'k s) s s )
72 (mk get-ww (k v s)
73 s s (cons #'k s) s )
74 (mk get-kv (k v s)
75 (cons (cons #'k #'v) s) s s s )
76
77 (define (->kw x) (symbol->keyword (syntax->datum x)))
78
79 (syntax-case x (*)
80 ((_ (arg ...) code ...)
81 (let* ((as (fold get-as '() #'(arg ...)))
82 (kw (fold get-kw '() #'(arg ...)))
83 (ww- (fold get-ww '() #'(arg ...)))
84 (kv (fold get-kv '() #'(arg ...))))
85 (if (and-map null? (list kw ww- kv))
86 #`(object-method
87 (lambda (#,@as . u12345678)
88 (if (and (pair? u12345678)
89 (not (keyword? (car u12345678))))
90 (raise (ArgumentError "too many arguments to function")))
91 (let () code ...)))
92 (with-syntax ((kw (if (null? kw)
93 (datum->syntax x (gensym "kw"))
94 (car kw)))
95 (ww (if (null? ww-)
96 (datum->syntax x (gensym "ww"))
97 (car ww-)))
98 ((k ...) (map car kv))
99 ((s ...) (map ->kw (map car kv)))
100 ((v ...) (map cdr kv)))
101 #`(object-method
102 (lambda* (#,@as . l)
103 (call-with-values (lambda () (get-akw l))
104 (lambda (ww* kw)
105 (let*-values (((ww* k) (take-1 #,(null? ww-) ww*
106 kw s v))
107 ...)
108 (let ((ww ww*)
109 (kw (pytonize kw)))
110 (let () code ...))))))))))))))
111
112 (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
113
114 (define to-list #f)
115
116 (define (no x)
117 (and-map
118 (lambda (x)
119 (syntax-case x (* ** =)
120 ((* _) #f)
121 ((** _) #f)
122 ((= a b) #f)
123 (_ #t)))
124 x))
125
126 (define (mk-k x)
127 (if (keyword? x)
128 x
129 (symbol->keyword
130 (if (string? x)
131 (string->symbol x)
132 x))))
133
134 (define (mkw kw) (error "not implemented"))
135
136 (define-syntax m*
137 (syntax-rules (* ** =)
138 ((_ (= a b))
139 (list (symbol->keyword 'a) b))
140 ((_ (* a)) a)
141 ((_ (** kw))
142 (mkw kw))
143 ((_ a) (list a))))
144
145 (define-syntax py-apply
146 (lambda (x)
147 (syntax-case x ()
148 ((_ f a ... (op x))
149 (and (syntax-case #'op (*)
150 (* #t)
151 (_ #f))
152 (and-map (lambda (q)
153 (syntax-case q (* ** =)
154 ((= _ _) #f)
155 ((* _ ) #f)
156 ((** _ ) #f)
157 (_ #t))) #'(a ...)))
158 #'(if (or (null? x) (pair? x))
159 (apply f a ... x)
160 (apply f a ... (to-list x))))
161
162 ((_ f a ...)
163 (if (no #'(a ...))
164 #'(f a ...)
165 #'(apply f (let lp ((l (list (m* a) ...)))
166 (if (pair? l)
167 (append (to-list (car l)) (lp (cdr l)))
168 '()))))))))
169