1 ;;;; File: "parser.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
4 ;;;; All Rights Reserved.
8 (let ((x (parse-top expr env)))
10 (parse 'value #f env))
14 (let ((r (make-seq #f x)))
15 (for-each (lambda (y) (node-parent-set! y r)) x)
20 (cond ((and (pair? expr)
21 (eq? (car expr) 'define-macro))
23 (cons (cons (caadr expr)
24 (eval `(lambda ,(cdadr expr) . ,(cddr expr))))
28 (eq? (car expr) 'begin))
29 (parse-top-list (cdr expr) env))
31 (eq? (car expr) 'hide))
32 (parse-top-hide (cadr expr) (cddr expr) env))
34 (eq? (car expr) 'rename))
35 (parse-top-rename (cadr expr) (cddr expr) env))
37 (eq? (car expr) 'define))
39 (if (pair? (cadr expr))
43 (if (pair? (cadr expr))
44 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
46 (let* ((var2 (env-lookup env var))
47 (val2 (parse 'value val env))
48 (r (make-def #f (list val2) var2)))
49 (node-parent-set! val2 r)
50 (var-defs-set! var2 (cons r (var-defs var2)))
53 (list (parse 'value expr env))))))
55 (define parse-top-list
58 (append (parse-top (car lst) env)
59 (parse-top-list (cdr lst) env))
62 (define parse-top-hide
63 (lambda (renamings body env)
66 (env-extend-renamings env renamings))
68 ;; (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
72 (define parse-top-rename
73 (lambda (renamings body env)
75 (env-extend-renamings env renamings))))
78 (lambda (use expr env)
79 (cond ((self-eval? expr)
80 (make-cst #f '() expr))
82 (let* ((var (env-lookup env expr))
83 (r (make-ref #f '() var)))
84 (var-refs-set! var (cons r (var-refs var)))
85 (if (not (var-global? var))
86 (let* ((unbox (parse 'value '#%unbox env))
87 (app (make-call #f (list unbox r))))
88 (node-parent-set! r app)
89 (node-parent-set! unbox app)
93 (assq (car expr) *macros*))
94 => (lambda (p) (parse use (apply (cdr p) (cdr expr)) env)))
96 (eq? (car expr) 'set!))
97 (let ((var (env-lookup env (cadr expr))))
99 (let* ((val (parse 'value (caddr expr) env))
100 (r (make-set #f (list val) var)))
101 (node-parent-set! val r)
102 (var-sets-set! var (cons r (var-sets var)))
104 (let* ((body (parse 'value (caddr expr) env))
105 (ref (make-ref #f '() var))
106 (bs (make-ref #f '() (env-lookup env '#%box-set!)))
107 (r (make-call #f (list bs ref body))))
108 (node-parent-set! body r)
109 (node-parent-set! ref r)
110 (node-parent-set! bs r)
111 (var-sets-set! var (cons r (var-sets var)))
114 (eq? (car expr) 'quote))
115 (make-cst #f '() (cadr expr)))
117 (eq? (car expr) 'if))
118 (let* ((a (parse 'test (cadr expr) env))
119 (b (parse use (caddr expr) env))
120 (c (if (null? (cdddr expr))
122 (parse use (cadddr expr) env)))
123 (r (make-if #f (list a b c))))
124 (node-parent-set! a r)
125 (node-parent-set! b r)
126 (node-parent-set! c r)
129 (eq? (car expr) 'lambda))
130 (let* ((pattern (cadr expr))
131 (ids (extract-ids pattern))
132 ;; parent children params rest? entry-label
133 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
134 (new-env (env-extend env ids r))
135 (body (parse-body (cddr expr) new-env))
139 (let ((v (env-lookup new-env id)))
140 (if (mutable-var? v) (list v) '())))
145 (map (lambda (id) (env-lookup new-env id))
147 (node-children-set! r (list body))
148 (node-parent-set! body r)
150 (let* ((prc (make-prc #f (list body) mut-vars #f #f))
151 (new-vars (map var-id mut-vars))
152 (tmp-env (env-extend env new-vars r))
159 (cons '#%box (cons id '()))
162 ;; (lambda (a b) (set! a b))
163 ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a)))
164 (for-each (lambda (var) (var-defs-set! var (list prc)))
166 (for-each (lambda (n) (node-parent-set! n app))
167 (cdr (node-children app)))
168 (node-parent-set! prc app)
170 (map (lambda (id) (env-lookup tmp-env id))
172 (node-children-set! r (list app))
173 (node-parent-set! body prc)
176 (eq? (car expr) 'letrec))
177 (let ((ks (map car (cadr expr)))
178 (vs (map cadr (cadr expr))))
181 (cons (map (lambda (k) (list k #f)) ks)
182 (append (map (lambda (k v) (list 'set! k v))
187 (eq? (car expr) 'begin))
188 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
189 (r (make-seq #f exprs)))
190 (for-each (lambda (x) (node-parent-set! x r)) exprs)
193 (eq? (car expr) 'let))
194 (if (symbol? (cadr expr))
196 `(letrec ((,(cadr expr) (lambda ,(map car (caddr expr)) .
198 (,(cadr expr) . ,(map cadr (caddr expr))))
202 (cons (map car (cadr expr))
204 (map cadr (cadr expr)))
207 (eq? (car expr) 'let*))
208 (if (null? (cadr expr))
210 (cons 'let (cdr expr))
214 (list (list (caar (cadr expr))
215 (cadar (cadr expr))))
217 (cons (cdr (cadr expr))
221 (eq? (car expr) 'and))
222 (cond ((null? (cdr expr))
234 (cons 'and (cddr expr))
238 (eq? (car expr) 'or))
239 (cond ((null? (cdr expr))
252 (cons 'or (cddr expr)))
258 (list (list v (cadr expr)))
262 (cons 'or (cddr expr)))))
264 ;; primitive substitution here
265 ;; TODO do this optimization in the following pass instead of at parse time ?
267 (assoc (car expr) substitute-primitives))
271 (cons (cdr prim) (cdr expr))
273 ;; binary arthimetic operations can use primitives directly
275 (= (length (cdr expr)) 2)
276 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
280 (cons (cdr prim) (cdr expr))
284 '(quote quasiquote unquote unquote-splicing lambda if
285 set! cond and or case let let* letrec begin do define
287 (compiler-error "the compiler does not implement the special form" (car expr)))
289 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
290 (r (make-call #f exprs)))
291 (for-each (lambda (x) (node-parent-set! x r)) exprs)
294 (compiler-error "unknown expression" expr)))))
298 (parse 'value (cons 'begin exprs) env)))
310 (cons (car pattern) (extract-ids (cdr pattern)))
311 (if (symbol? pattern)
315 (define has-rest-param?
318 (has-rest-param? (cdr pattern))
321 (define (adjust-unmutable-references! node)
322 '(pretty-print (list unmut: (node->expr node)))
323 (if (and (call? node)
325 (ref? (car (node-children node)))
327 (eq? '#%unbox (var-id (ref-var (car (node-children node)))))
329 (ref? (cadr (node-children node)))
331 (not (mutable-var? (ref-var (cadr (node-children node)))))
332 '(display "unmut! "))
333 (let* ((parent (node-parent node)) (child (cadr (node-children node))))
334 (node-parent-set! child parent)
336 (node-children-set! parent
337 (map (lambda (c) (if (eq? c node) child c))
338 (node-children parent))))
340 (begin (for-each (lambda (n) (adjust-unmutable-references! n))
341 (node-children node))