source: project/release/4/spock/tags/0.9/codegen.scm @ 27390

Last change on this file since 27390 was 27390, checked in by felix winkelmann, 9 years ago

spock 0.9: now with less throwing up

File size: 7.2 KB
Line 
1;;;; codegen.scm - code-generation for JS target
2
3
4(define (generate-header state)
5  (let ((seal (test-option 'seal state)))
6    (emit "/* CODE GENERATED BY SPOCK " spock-version " */")
7    (when seal
8      (emit "\n(function() {"))
9    (when (test-option 'runtime state)
10      (emit "\n")
11      (read-library
12       state
13       (cond ((test-option 'debug state) "spock-runtime-debug.js")
14             (else "spock-runtime.js"))
15       copy-file-data))
16    (let ((namespace (test-option 'namespace state)))
17      (when namespace
18        (emit "\n" namespace " = SPOCK.module(\"" 
19              namespace "\");")))))
20
21(define (generate-trailer state)
22  (when (test-option 'seal state)
23    (emit "\n})();"))
24  (emit "\n/* END OF GENERATED CODE */\n"))
25
26(define (generate-code toplambdas state)
27  (let ((nl "\n")
28        (loop-llist #f)
29        (debug-mode (test-option 'debug state))
30        (namespace (test-option 'namespace state)))
31    (define (indent thunk)
32      (let ((nlold nl))
33        (set! nl (string-append nl " "))
34        (let ((x (thunk)))
35          (set! nl nlold)
36          x)))
37    (define (constant c)
38      (with-output-to-string
39        (lambda ()
40          (cond ((or (number? c) (string? c))
41                 (write c))
42                ((char? c)
43                 (emit "new SPOCK.Char(")
44                 (write (string c))
45                 (emit ")"))
46                ((boolean? c)
47                 (emit (if c "true" "false")))
48                ((null? c) (emit "null"))
49                ((symbol? c)
50                 (emit "SPOCK.intern(")
51                 (write (symbol->string c))
52                 (emit ")"))
53                ((pair? c)
54                 (emit "new SPOCK.Pair(")
55                 (emit (constant (car c)))
56                 (emit ", ")
57                 (emit (constant (cdr c)))
58                 (emit ")"))
59                ((vector? c)
60                 (emit "[")
61                 (unless (zero? (vector-length c))
62                   (emit (constant (vector-ref c 0)))
63                   (for-each
64                    (lambda (x)
65                      (emit ", ")
66                      (emit (constant x)))
67                    (cdr (vector->list c))))
68                 (emit "]"))
69                (else (fail "bad constant" c))))))
70    (define (walk x dest loc)
71      (match x
72        (('quote c)
73         (if (or (number? c) (string? c) (boolean? c))
74             (constant c)
75             (let ((t1 (temp)))
76               (emit nl "var " t1 " = ")
77               (emit (constant c))
78               (emit ";")
79               t1)))
80        ((? symbol?) x)
81        (('set! v x)
82         (let ((t (walk x v loc)))
83           (emit nl v " = " t ";\t// set! " v)
84           'undefined))
85        (('lambda llist body)
86         (let ((t1 (temp)))
87           (match-let (((vars rest) (parse-llist llist)))
88             (emit nl "var " t1 " = function " 
89                   ;(if (and debug-mode dest) (identifier dest) "")  <- gives trouble on IE
90                   "(")
91             (emit-list vars)
92             (emit ") {")
93             (indent 
94              (lambda ()
95                (when dest (emit "\t// " dest))
96                (when (and (pair? llist) (pair? (cdr llist))) ;XXX not really correct
97                  (emit nl "var r = SPOCK.count(arguments" 
98                        (if (and debug-mode dest)
99                            (string-append ", " (constant (stringify dest)))
100                            "")
101                        ");")
102                  (emit nl "if(r) return r;"))
103                (when rest
104                  (emit nl "var " rest " = SPOCK.rest(arguments, "  (- (length vars) 1))
105                  (when (and debug-mode dest)
106                    (emit ", '" dest "'"))
107                  (emit ");"))
108                (fluid-let ((loop-llist #f))
109                  (walk body #f dest))))
110             (emit nl "};")
111             t1)))
112        (('%void) 'undefined)
113        (('%void? x)
114         (let ((t (temp))
115               (tx (walk x #f loc)))
116           (emit nl "var " t " = " tx " === undefined;")
117           t))
118        (('let (('%unused x)) body)
119         (walk x #f loc)
120         (walk body #f loc))
121        (('let ((v x)) body)
122         (let ((t (walk x v loc)))
123           (emit nl "var " v " = " t ";")
124           (walk body v loc)))
125        (('if x y z)
126         (let* ((t (temp))
127                (x (walk x #f loc)))
128           (emit nl "var " t ";" nl "if(" x " !== false) {")
129           (indent
130            (lambda ()
131              (let ((y (walk y dest loc)))
132                (emit nl t " = " y ";"))))
133           (emit nl "}" nl "else {")
134           (indent
135            (lambda ()
136              (let ((z (walk z dest loc)))
137                (emit nl t " = " z ";"))))
138           (emit nl "}")
139           t))
140        (('%host-ref name) name)
141        (('%host-set! name x)
142         (let ((t (walk x #f loc)))
143           (emit nl name " = " t)
144           'undefined))
145        (('%property-ref name)
146         (let ((t (temp))
147               (k (temp "k")))
148           (emit nl "var " t " = function(" k ", x) { return " k
149                 "(x." name "); }")
150           t))
151        (('%property-ref name x)
152         (let ((t (temp))
153               (ta (walk x #f loc)))
154           (emit nl "var " t " = " ta "." name ";")
155           t))
156        (('%property-set! name x y)
157         (let ((tx (walk x #f loc))
158               (ty (walk y #f loc)))
159           (emit nl tx "." name " = " ty ";")
160           ty))
161        (('%check type x)
162         (let ((t (temp))
163               (tx (walk x dest loc)))
164           (emit nl "var " t " = SPOCK.check(" tx ", ")
165           (if (pair? type)
166               (emit (car type))
167               (emit "'" type "'"))
168           (when (and loc debug-mode)
169             (emit ", " (constant (stringify loc))))
170           (emit ");")
171           t))
172        (('%code code ...)
173         (for-each (cut emit nl <>) code)
174         'undefined)
175        (('%native-lambda code ...)
176         (let ((t (temp)))
177           (emit nl "var " t " = function(K) {")
178           (indent
179            (lambda ()
180              ;;XXX this will not unwind, but at least decrease the counter
181              (emit nl "SPOCK.count(arguments")
182              (if dest
183                  (emit ", '" dest "');")
184                  (emit ");"))
185              (for-each (cut emit nl <>) code)))
186           (emit nl "};")
187           t))
188        (('%inline name args ...)
189         (let ((t (temp))
190               (ta (map (cut walk <> #f loc) args)))
191           (emit nl "var " t " = ")
192           (cond ((pair? name)
193                  (for-each
194                   (lambda (x)
195                     (if (number? x)
196                         (emit "(" (list-ref ta (- x 1)) ")")
197                         (emit " " x " ")))
198                   name))
199                 ((char=? #\. (string-ref (stringify name) 0))
200                  (emit (car ta) name "(")
201                  (emit-list (cdr ta))
202                  (emit ")"))
203                 (else
204                  (emit name "(")
205                  (emit-list ta)
206                  (emit ")")))
207           (emit ";")
208           t))
209        (('%new arg1 args ...)
210         (let ((t1 (temp))
211               (t2 (walk arg1 #f loc))
212               (ta (map (cut walk <> #f loc) args)))
213           (emit nl "var " t1 " = new " t2 "(")
214           (emit-list ta)
215           (emit ");")
216           t1))
217        (('%global-ref v)
218         (if namespace
219             (string-append namespace "." (identifier v))
220             (identifier v)))
221        (('%global-set! v x)
222         (let ((t (walk x v loc)))
223           (emit nl (if namespace (string-append namespace ".") "") 
224                 (identifier v) " = " t ";\t// set! " v)
225           'undefined))
226        (('%loop llist body)
227         (emit nl "loop: while(true) {")
228         (fluid-let ((loop-llist llist))
229           (let ((r (indent (cut walk body #f loc))))
230             (emit nl "}")
231             r)))
232        (('%continue op k args ...)
233         (if loop-llist
234             (let ((temps (map (lambda _ (temp)) args)))
235               ;; bind arguments to temporaries
236               (for-each
237                (lambda (t a)
238                  (let ((r (walk a #f loc)))
239                    (emit nl "var " t " = " r ";")))
240                temps args)
241               ;; set argument variables to temporaries
242               (let loop ((ll loop-llist) (temps temps))
243                 (cond ((pair? ll)       ; normal argument?
244                        (cond ((null? temps) ; missing arguments?
245                               (emit nl (car ll) " = undefined;")
246                               (loop (cdr ll) '()))
247                              (else
248                               (emit nl (car ll) " = " (car temps) ";")
249                               (loop (cdr ll) (cdr temps)))))
250                       ((symbol? ll)    ; rest argument?
251                        (emit nl ll " = SPOCK.list(")
252                        (emit-list temps)
253                        (emit ");"))
254                       (else
255                        ;; set any surplus args to undefined
256                        (for-each
257                         (lambda (t) (emit nl t " = undefined;"))
258                         temps))))
259               (emit nl "continue loop;")
260               'undefined)
261             (walk (cdr x) dest loc)))
262        ((op args ...)
263         (let* ((to (walk op #f loc))
264                (ta (map (cut walk <> #f loc) args))
265                (t (temp)))
266           (emit nl "return " to "(")
267           (emit-list ta)
268           (emit ");")
269           'undefined))))               ; does not return
270    (for-each
271     (lambda (top)
272       (let ((t (walk top #f #f)))
273         (emit nl "SPOCK.run(" t ");")))
274     toplambdas)
275    (emit nl "SPOCK.flush();")))
Note: See TracBrowser for help on using the repository browser.