  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();")))

")))))
XXX not really correct
XXX this will not unwind, but at least decrease the counter
 bind arguments to temporaries
 set argument variables to temporaries
 normal argument?
 missing arguments?
 rest argument?
 set any surplus args to undefined
 does not return
  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(\"" 

(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))
		  (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 ()
	      (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)))
	       (for-each
		(lambda (t a)
		  (let ((r (walk a #f loc)))
		    (emit nl "var " t " = " r ";")))
		temps args)
	       (let loop ((ll loop-llist) (temps temps))
			       (emit nl (car ll) " = undefined;")
			       (loop (cdr ll) '()))
			      (else
			       (emit nl (car ll) " = " (car temps) ";")
			       (loop (cdr ll) (cdr temps)))))
			(emit nl ll " = SPOCK.list(")
			(emit-list temps)
			(emit ");"))
		       (else
			(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 ");")
    (for-each
     (lambda (top)
       (let ((t (walk top #f #f)))
	 (emit nl "SPOCK.run(" t ");")))
     toplambdas)
    (emit nl "SPOCK.flush();")))
