spook

codegen.scm (7444B)

---

 ;;;; codegen.scm - code-generation for JS target
 
 
 (define (generate-header state)
   (let ((seal (test-option 'seal state)))
     (emit "/* CODE GENERATED BY SPOCK " spock-version " */")
     (when seal
       (emit "\n(function() {"))
     (when (test-option 'runtime state)
       (emit "\n")
       (read-library
        state
        (cond ((test-option 'debug state) "spock-runtime-debug.js")
 	     (else "spock-runtime.js"))
        copy-file-data))
     (let ((namespace (test-option 'namespace state)))
       (when namespace
 	(emit "\n" namespace " = SPOCK.module(\"" 
 	      namespace "\");")))))
 
 (define (generate-trailer state)
   (when (test-option 'seal state)
     (emit "\n})();"))
   (emit "\n/* END OF GENERATED CODE */\n"))
 
 (define (generate-code toplambdas state)
   (let ((nl "\n")
 	(loop-llist #f)
 	(debug-mode (test-option 'debug state))
 	(namespace (test-option 'namespace state)))
     (define (indent thunk)
       (let ((nlold nl))
 	(set! nl (string-append nl " "))
 	(let ((x (thunk)))
 	  (set! nl nlold)
 	  x)))
     (define (constant c)
       (with-output-to-string
 	(lambda ()
 	  (cond ((or (number? c) (string? c))
 		 (write c))
 		((char? c)
 		 (emit "new SPOCK.Char(")
 		 (write (string c))
 		 (emit ")"))
 		((boolean? c)
 		 (emit (if c "true" "false")))
 		((null? c) (emit "null"))
 		((symbol? c)
 		 (emit "SPOCK.intern(")
 		 (write (symbol->string c))
 		 (emit ")"))
 		((pair? c)
 		 (emit "new SPOCK.Pair(")
 		 (emit (constant (car c)))
 		 (emit ", ")
 		 (emit (constant (cdr c)))
 		 (emit ")"))
 		((vector? c)
 		 (emit "[")
 		 (unless (zero? (vector-length c))
 		   (emit (constant (vector-ref c 0)))
 		   (for-each
 		    (lambda (x)
 		      (emit ", ")
 		      (emit (constant x)))
 		    (cdr (vector->list c))))
 		 (emit "]"))
 		(else (fail "bad constant" c))))))
     (define (walk x dest loc)
       (match x
 	(('quote c)
 	 (if (or (number? c) (string? c) (boolean? c))
 	     (constant c)
 	     (let ((t1 (temp)))
 	       (emit nl "var " t1 " = ")
 	       (emit (constant c))
 	       (emit ";")
 	       t1)))
 	((? symbol?) x)
 	(('set! v x)
 	 (let ((t (walk x v loc)))
 	   (emit nl v " = " t ";\t// set! " v)
 	   'undefined))
 	(('lambda llist body)
 	 (let ((t1 (temp)))
 	   (match-let (((vars rest) (parse-llist llist)))
 	     (emit nl "var " t1 " = function " 
 		   ;(if (and debug-mode dest) (identifier dest) "")  <- gives trouble on IE
 		   "(")
 	     (emit-list vars)
 	     (emit ") {")
 	     (indent 
 	      (lambda ()
 		(when dest (emit "\t// " dest))
 		(when (and (pair? llist) (pair? (cdr llist))) ;XXX not really correct
 		  (emit nl "var r = SPOCK.count(arguments" 
 			(if (and debug-mode dest)
 			    (string-append ", " (constant (stringify dest)))
 			    "")
 			");")
 		  (emit nl "if(r) return r;"))
 		(when rest
 		  (emit nl "var " rest " = SPOCK.rest(arguments, "  (- (length vars) 1))
 		  (when (and debug-mode dest)
 		    (emit ", '" dest "'"))
 		  (emit ");"))
 		(fluid-let ((loop-llist #f))
 		  (walk body #f dest))))
 	     (emit nl "};")
 	     t1)))
 	(('%void) 'undefined)
 	(('%void? x)
 	 (let ((t (temp))
 	       (tx (walk x #f loc)))
 	   (emit nl "var " t " = " tx " === undefined;")
 	   t))
 	(('let (('%unused x)) body)
 	 (walk x #f loc)
 	 (walk body #f loc))
 	(('let ((v x)) body)
 	 (let ((t (walk x v loc)))
 	   (emit nl "var " v " = " t ";")
 	   (walk body v loc)))
 	(('if x y z)
 	 (let* ((t (temp))
 		(x (walk x #f loc)))
 	   (emit nl "var " t ";" nl "if(" x " !== false) {")
 	   (indent
 	    (lambda ()
 	      (let ((y (walk y dest loc)))
 		(unless (eq? y 'undefined) (emit nl t " = " y ";")))))
 	   (emit nl "}" nl "else {")
 	   (indent
 	    (lambda ()
 	      (let ((z (walk z dest loc)))
                 (unless (eq? z 'undefined) (emit nl t " = " z ";")))))
 	   (emit nl "}")
 	   t))
 	(('%host-ref name) name)
 	(('%host-set! name x)
 	 (let ((t (walk x #f loc)))
 	   (emit nl name " = " t)
 	   'undefined))
 	(('%property-ref name)
 	 (let ((t (temp))
 	       (k (temp "k")))
 	   (emit nl "var " t " = function(" k ", x) { return " k
 		 "(x." name "); }")
 	   t))
 	(('%property-ref name x)
 	 (let ((t (temp))
 	       (ta (walk x #f loc)))
 	   (emit nl "var " t " = " ta "." name ";")
 	   t))
 	(('%property-set! name x y)
 	 (let ((tx (walk x #f loc))
 	       (ty (walk y #f loc)))
 	   (emit nl tx "." name " = " ty ";")
 	   ty))
 	(('%check type x)
 	 (let ((t (temp))
 	       (tx (walk x dest loc)))
 	   (emit nl "var " t " = SPOCK.check(" tx ", ")
 	   (if (pair? type)
 	       (emit (car type))
 	       (emit "'" type "'"))
 	   (when (and loc debug-mode)
 	     (emit ", " (constant (stringify loc))))
 	   (emit ");")
 	   t))
 	(('%code code ...)
 	 (for-each (cut emit nl <>) code)
 	 'undefined)
 	(('%native-lambda code ...)
 	 (let ((t (temp)))
 	   (emit nl "var " t " = function(K) {")
 	   (indent
 	    (lambda ()
 	      ;;XXX this will not unwind, but at least decrease the counter
 	      (emit nl "SPOCK.count(arguments")
 	      (if dest
 		  (emit ", '" dest "');")
 		  (emit ");"))
 	      (for-each (cut emit nl <>) code)))
 	   (emit nl "};")
 	   t))
 	(('%inline name args ...)
 	 (let ((t (temp))
 	       (ta (map (cut walk <> #f loc) args)))
 	   (emit nl "var " t " = ")
 	   (cond ((pair? name)
 		  (for-each
 		   (lambda (x)
 		     (if (number? x)
 			 (emit "(" (list-ref ta (- x 1)) ")")
 			 (emit " " x " ")))
 		   name))
 		 ((char=? #\. (string-ref (stringify name) 0))
 		  (emit (car ta) name "(")
 		  (emit-list (cdr ta))
 		  (emit ")"))
 		 (else 
 		  (emit name "(")
 		  (emit-list ta)
 		  (emit ")")))
 	   (emit ";")
 	   t))
 	(('%new arg1 args ...)
 	 (let ((t1 (temp))
 	       (t2 (walk arg1 #f loc))
 	       (ta (map (cut walk <> #f loc) args)))
 	   (emit nl "var " t1 " = new " t2 "(")
 	   (emit-list ta)
 	   (emit ");")
 	   t1))
 	(('%global-ref v)
 	 (if namespace
 	     (string-append namespace "." (identifier v))
 	     (identifier v)))
 	(('%global-set! v x)
 	 (let ((t (walk x v loc)))
 	   (emit nl (if namespace (string-append namespace ".") "") 
 		 (identifier v) " = " t ";\t// set! " v)
 	   'undefined))
 	(('%loop llist body)
 	 (emit nl "loop: while(true) {")
 	 (fluid-let ((loop-llist llist))
 	   (let ((r (indent (cut walk body #f loc))))
 	     (emit nl "}")
 	     r)))
 	(('%continue op k args ...)
 	 (if loop-llist
 	     (let ((temps (map (lambda _ (temp)) args)))
 	       ;; bind arguments to temporaries
 	       (for-each
 		(lambda (t a)
 		  (let ((r (walk a #f loc)))
 		    (emit nl "var " t " = " r ";")))
 		temps args)
 	       ;; set argument variables to temporaries
 	       (let loop ((ll loop-llist) (temps temps))
 		 (cond ((pair? ll)	 ; normal argument?
 			(cond ((null? temps) ; missing arguments?
 			       (emit nl (car ll) " = undefined;")
 			       (loop (cdr ll) '()))
 			      (else
 			       (emit nl (car ll) " = " (car temps) ";")
 			       (loop (cdr ll) (cdr temps)))))
 		       ((symbol? ll)	; rest argument?
 			(emit nl ll " = SPOCK.list(")
 			(emit-list temps)
 			(emit ");"))
 		       (else
 			;; set any surplus args to undefined
 			(for-each
 			 (lambda (t) (emit nl t " = undefined;"))
 			 temps))))
 	       (emit nl "continue loop;")
 	       'undefined)
 	     (walk (cdr x) dest loc)))
 	((op args ...)
 	 (let* ((to (walk op #f loc))
 		(ta (map (cut walk <> #f loc) args))
 		(t (temp)))
 	   (emit nl "return " to "(")
 	   (emit-list ta)
 	   (emit ");")
 	   'undefined))))		; does not return
     (for-each
      (lambda (top)
        (let ((t (walk top #f #f)))
 	 (emit nl "SPOCK.run(" t ");")))
      toplambdas)
     (emit nl "SPOCK.flush();")))