source: project/release/4/spock/trunk/codegen.scm @ 23521

Last change on this file since 23521 was 23521, checked in by felix winkelmann, 10 years ago

spock 0.05: compiled code runs somewhat on IE; slightly more verbose setup-script

File size: 7.1 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 "SPOCK.count(arguments" 
98                        (if (and debug-mode dest)
99                            (string-append ", " (constant (stringify dest)))
100                            "")
101                        ");"))
102                (when rest
103                  (emit nl "var " rest " = SPOCK.rest(arguments, "  (- (length vars) 1))
104                  (when (and debug-mode dest)
105                    (emit ", '" dest "'"))
106                  (emit ");"))
107                (fluid-let ((loop-llist #f))
108                  (walk body #f dest))))
109             (emit nl "};")
110             t1)))
111        (('%void) 'undefined)
112        (('%void? x)
113         (let ((t (temp))
114               (tx (walk x #f loc)))
115           (emit nl "var " t " = " tx " === undefined;")
116           t))
117        (('let (('%unused x)) body)
118         (walk x #f loc)
119         (walk body #f loc))
120        (('let ((v x)) body)
121         (let ((t (walk x v loc)))
122           (emit nl "var " v " = " t ";")
123           (walk body v loc)))
124        (('if x y z)
125         (let* ((t (temp))
126                (x (walk x #f loc)))
127           (emit nl "var " t ";" nl "if(" x " !== false) {")
128           (indent
129            (lambda ()
130              (let ((y (walk y dest loc)))
131                (emit nl t " = " y ";"))))
132           (emit nl "}" nl "else {")
133           (indent
134            (lambda ()
135              (let ((z (walk z dest loc)))
136                (emit nl t " = " z ";"))))
137           (emit nl "}")
138           t))
139        (('%host-ref name) name)
140        (('%host-set! name x)
141         (let ((t (walk x #f loc)))
142           (emit nl name " = " t)
143           'undefined))
144        (('%property-ref name)
145         (let ((t (temp))
146               (k (temp "k")))
147           (emit nl "var " t " = function(" k ", x) { return " k
148                 "(x." name "); }")
149           t))
150        (('%property-ref name x)
151         (let ((t (temp))
152               (ta (walk x #f loc)))
153           (emit nl "var " t " = " ta "." name ";")
154           t))
155        (('%property-set! name x y)
156         (let ((tx (walk x #f loc))
157               (ty (walk y #f loc)))
158           (emit nl tx "." name " = " ty ";")
159           ty))
160        (('%check type x)
161         (let ((t (temp))
162               (tx (walk x dest loc)))
163           (emit nl "var " t " = SPOCK.check(" tx ", ")
164           (if (pair? type)
165               (emit (car type))
166               (emit "'" type "'"))
167           (when (and loc debug-mode)
168             (emit ", " (constant (stringify loc))))
169           (emit ");")
170           t))
171        (('%code code ...)
172         (for-each (cut emit nl <>) code)
173         'undefined)
174        (('%native-lambda code ...)
175         (let ((t (temp)))
176           (emit nl "var " t " = function(K) {")
177           (indent
178            (lambda ()
179              (emit nl "SPOCK.count(arguments")
180              (if dest
181                  (emit ", '" dest "');")
182                  (emit ");"))
183              (for-each (cut emit nl <>) code)))
184           (emit nl "};")
185           t))
186        (('%inline name args ...)
187         (let ((t (temp))
188               (ta (map (cut walk <> #f loc) args)))
189           (emit nl "var " t " = ")
190           (cond ((pair? name)
191                  (for-each
192                   (lambda (x)
193                     (if (number? x)
194                         (emit "(" (list-ref ta (- x 1)) ")")
195                         (emit " " x " ")))
196                   name))
197                 ((char=? #\. (string-ref (stringify name) 0))
198                  (emit (car ta) name "(")
199                  (emit-list (cdr ta))
200                  (emit ")"))
201                 (else
202                  (emit name "(")
203                  (emit-list ta)
204                  (emit ")")))
205           (emit ";")
206           t))
207        (('%new arg1 args ...)
208         (let ((t1 (temp))
209               (t2 (walk arg1 #f loc))
210               (ta (map (cut walk <> #f loc) args)))
211           (emit nl "var " t1 " = new " t2 "(")
212           (emit-list ta)
213           (emit ");")
214           t1))
215        (('%global-ref v)
216         (if namespace
217             (string-append namespace "." (identifier v))
218             (identifier v)))
219        (('%global-set! v x)
220         (let ((t (walk x v loc)))
221           (emit nl (if namespace (string-append namespace ".") "") 
222                 (identifier v) " = " t ";\t// set! " v)
223           'undefined))
224        (('%loop llist body)
225         (emit nl "loop: while(true) {")
226         (fluid-let ((loop-llist llist))
227           (let ((r (indent (cut walk body #f loc))))
228             (emit nl "}")
229             r)))
230        (('%continue op k args ...)
231         (if loop-llist
232             (let ((temps (map (lambda _ (temp)) args)))
233               ;; bind arguments to temporaries
234               (for-each
235                (lambda (t a)
236                  (let ((r (walk a #f loc)))
237                    (emit nl "var " t " = " r ";")))
238                temps args)
239               ;; set argument variables to temporaries
240               (let loop ((ll loop-llist) (temps temps))
241                 (cond ((pair? ll)       ; normal argument?
242                        (cond ((null? temps) ; missing arguments?
243                               (emit nl (car ll) " = undefined;")
244                               (loop (cdr ll) '()))
245                              (else
246                               (emit nl (car ll) " = " (car temps) ";")
247                               (loop (cdr ll) (cdr temps)))))
248                       ((symbol? ll)    ; rest argument?
249                        (emit nl ll " = SPOCK.list(")
250                        (emit-list temps)
251                        (emit ");"))
252                       (else
253                        ;; set any surplus args to undefined
254                        (for-each
255                         (lambda (t) (emit nl t " = undefined;"))
256                         temps))))
257               (emit nl "continue loop;")
258               'undefined)
259             (walk (cdr x) dest loc)))
260        ((op args ...)
261         (let* ((to (walk op #f loc))
262                (ta (map (cut walk <> #f loc) args))
263                (t (temp)))
264           (emit nl "return " to "(")
265           (emit-list ta)
266           (emit ");")
267           'undefined))))               ; does not return
268    (for-each
269     (lambda (top)
270       (let ((t (walk top #f #f)))
271         (emit nl "SPOCK.run(" t ");")))
272     toplambdas)
273    (emit nl "SPOCK.flush();")))
Note: See TracBrowser for help on using the repository browser.