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

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