1 (require (lib "match.ss"))
2 (require (only (lib "1.ss" "srfi") fold))
3 (require (only (lib "13.ss" "srfi") string-contains))
6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;; Match function arguments
11 ;; (def foo (a b c (d 10) (e "foo") (* args) (* kwargs)) ...)
12 (define (match-function-args args)
13 ;; I wish this was a match-lambda ...
14 (define (valid-arg? arg)
21 (when (and (not (null? args)) (valid-arg? (car args)))
22 (set! *args* (append *args* (list (car args))))
23 (set! args (cdr args))
27 (set! *defaults* vals)
28 (set! *args* (append *args* vars)))) args)
29 (values *args* *defaults* *flag*)))
31 (define (not-symbol sym)
35 (string=? (symbol->string s)
40 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44 (@> Add (list (T left) (T right))))
46 ;; fold into multiple forms of (+ A B)
47 ;; eg: (+ a b c d) => (+ (+ (+ a b) c) d)
48 (T (fold (lambda (a b) `(+ ,b ,a))
52 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56 (@> And : (map T nodes)))
61 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62 ;; COMPARISON operators
68 (py/tuple (list (ss->py "==") (T r))))
72 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
73 ;; Variable ASSIGNMENT
75 (('set! (targets ...) value)
79 (unpack-assign-name t))
85 (list (unpack-assign-name target))
89 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 (@> Tuple (map T items)))
96 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;;; (if <exp> (begin ...) else (begin ...)
100 (('if exp ('begin body1 ...) ('begin body2 ...))
102 (list (py/tuple (list (T exp) (@> Stmt (map T body1)))))
103 (@> Stmt (map T body2))))
105 (('if exp ('begin body1 ...))
107 (list (py/tuple (list (T exp) (@> Stmt (map T body1)))))
110 (('if exp body1 body2)
111 (T `(if ,exp (begin ,body1) (begin ,body2))))
115 (list (py/tuple (list (T exp) (@> Stmt (list (T body1))))))
118 (('cond ((and exp (? (not-symbol "else"))) body ...) ...)
121 (py/tuple (list (T e) (@> Stmt (map T b)))))
127 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130 (('for var 'in seq suite ...)
132 (@> AssName var "OP_ASSIGN")
134 (@> Stmt (map T suite))
137 (('while cond body ...)
140 (@> Stmt (map T body))
141 py/none)) ;; TODO: else
147 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
148 ;; FUNCTION definition
150 (('def name (args ...) body ...)
151 (display args)(newline)
153 (lambda () (match-function-args args))
154 (lambda (args defaults flag)
159 (map ss->py args) ;; XXX: @> macro does not do
160 ;; a deep translation of types
163 py/none ;; TODO: doc string
164 (@> Stmt (map T body)))))
171 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 (('class name (bases ...) statements ...)
175 (let ((class (@> Class
176 name bases "DOCSTRING"
177 (@> Stmt (map T statements)))))
178 (filename-hack! class)
182 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
183 ;; PRINT, IMPORT, ....
186 (('print exps ...) ;; ???
187 (@> Printnl (map T exps) py/none))
191 (@> Print (map T exps) py/none))
193 ;;;; (import name1 name2 ...)
195 (@> Import (map (lambda (n)
196 (py/tuple (list (ss->py n) py/none)))
200 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
204 (@> CallFunc (T proc) (map T args)
205 py/none py/none)) ;; TODO: *args, **kwargs
208 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;; CONSTANTS, VARIABLES
211 ;;;; a token -- var, 23, "foobar", 634.34
214 ((symbol? name) (unpack-name name))
215 ((number? name) (@> Const name))
216 ((string? name) (@> Const name))
217 (else (error "invalid exp" name))))))
219 ;; These functions handle names of the forms,
222 ;; generating appropriate AST nodes.
224 ;; XXX: In future, this functionality must become part of the Lisp ``reader''
226 (define (unpack-name name)
227 (let ((name-s (symbol->string name)))
228 (if (dotted-name? name-s)
229 (let ((names (str-split name-s #\.)))
230 (fold (lambda (a b) (@> Getattr b a))
231 (T (string->symbol (car names)))
235 (define (unpack-assign-name name)
236 (let ((name-s (symbol->string name)))
237 (if (dotted-name? name-s)
238 (let* ((names* (str-split name-s #\.))
239 (names (all-but-last names*))
240 (lname (last names*)))
242 (fold (lambda (a b) (@> Getattr b a))
243 (T (string->symbol (car names)))
247 (@> AssName name "OP_ASSIGN"))))
249 (define (all-but-last l)
250 (cond ((null? (cdr l)) null)
251 (else (cons (car l) (all-but-last (cdr l))))))
254 (cond ((null? (cdr l)) (car l))
255 (else (last (cdr l)))))
257 (define (dotted-name? name)
260 (string-contains (symbol->string name) "."))
262 (string-contains name "."))
264 (error "wrong type for `name' --" name))))
266 ;; From http://schemecookbook.org/Cookbook/StringSplit
267 (define (str-split str ch)
268 (let ((len (string-length str)))
276 (cons (substring str a b) '())))
277 ((char=? ch (string-ref str b))
279 (cons "" (split (+ 1 a) (+ 1 b)))
280 (cons (substring str a b)
281 (split (+ 1 b) (+ 1 b)))))
282 (else (split a (+ 1 b)))))))
286 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
287 ;; Python Code Generation
288 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290 (define (write-code-obj co filename filename-pyc)
291 (let ((f (@ (: "__builtin__" 'open) filename-pyc "wb")))
293 (@ (: f 'write) (@ (: "imp" 'get_magic)))
294 (let ((ts (py/int-as-long
295 (@ (: "__builtin__" 'long)
296 (py/getattr (@ (: "os" 'stat)
301 (@ (: "__builtin__" 'chr) n)))
303 (bitwise-and (arithmetic-shift ts (- n)) #xff))
305 (@ (: "marshal" 'dump) co f)
309 (define (read-sexp fileh)
310 (let ((sexp (read fileh)))
311 (if (eof-object? sexp)
313 (cons sexp (read-sexp fileh)))))
316 ;; I do not understand why I have to do this.
317 ;; Modules, Functions, Classes "must" have the `filename' attribute?
318 (define *filename-hack* null)
319 (define (filename-hack! obj)
320 (py/setattr obj "filename" (py/str *filename-hack*)))
322 (define (compile-boa filename filename-pyc)
323 (set! *filename-hack* filename)
324 (call-with-input-file filename
326 (let* ((ast (@> Module "<DOCSTRING>" (@> Stmt (map T (read-sexp i)))))
327 (_ (filename-hack! ast))
328 (c (@ (: "compiler" 'pycodegen 'InteractiveCodeGenerator) ast))
329 (co (@ (: c 'getCode))))
331 (write-code-obj co filename filename-pyc)
332 ;; diassemble it for debugging
333 ;; (@ (: "dis" 'dis) co)
336 ;; Primitive command line options interface.
338 (let ((ARGS '((source 0 "examples/test.boa")
339 (output 1 "test.pyc"))))
342 (if (eq? arg (caar a))
343 (if (< (cadar a) (vector-length argv))
344 (vector-ref argv (cadar a))
348 (compile-boa (cmd-arg 'source) (cmd-arg 'output))