;;;; 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)))
		(emit nl t " = " y ";"))))
	   (emit nl "}" nl "else {")
	   (indent
	    (lambda ()
	      (let ((z (walk z dest loc)))
		(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();")))