rose-ash/lib/lua/transpile.sx

(define
  lua-tx-loop-guard
  (fn (body-sx)
    (list
      (make-symbol "guard")
      (list (make-symbol "e")
        (list
          (list (make-symbol "lua-break-sentinel?") (make-symbol "e"))
          nil))
      body-sx)))

(define
  lua-tx
  (fn
    (node)
    (cond
      ((= node nil) nil)
      ((not (= (type-of node) "list")) node)
      (else (lua-tx-dispatch (first node) node)))))

(define
  lua-tx-dispatch
  (fn
    (tag node)
    (cond
      ((= tag (quote lua-num)) (nth node 1))
      ((= tag (quote lua-str)) (nth node 1))
      ((= tag (quote lua-nil)) nil)
      ((= tag (quote lua-true)) true)
      ((= tag (quote lua-false)) false)
      ((= tag (quote lua-name)) (make-symbol (nth node 1)))
      ((= tag (quote lua-vararg)) (make-symbol "__varargs"))
      ((= tag (quote lua-paren)) (list (make-symbol "lua-first") (lua-tx (nth node 1))))
      ((= tag (quote lua-binop)) (lua-tx-binop node))
      ((= tag (quote lua-unop)) (lua-tx-unop node))
      ((= tag (quote lua-call)) (lua-tx-call node))
      ((= tag (quote lua-method-call)) (lua-tx-method-call node))
      ((= tag (quote lua-field)) (lua-tx-field node))
      ((= tag (quote lua-index)) (lua-tx-index node))
      ((= tag (quote lua-table)) (lua-tx-table node))
      ((= tag (quote lua-function)) (lua-tx-function node))
      ((= tag (quote lua-block)) (lua-tx-block node))
      ((= tag (quote lua-local)) (lua-tx-local node))
      ((= tag (quote lua-assign)) (lua-tx-assign node))
      ((= tag (quote lua-if)) (lua-tx-if node))
      ((= tag (quote lua-while)) (lua-tx-while node))
      ((= tag (quote lua-repeat)) (lua-tx-repeat node))
      ((= tag (quote lua-for-num)) (lua-tx-for-num node))
      ((= tag (quote lua-for-in)) (lua-tx-for-in node))
      ((= tag (quote lua-do)) (lua-tx-do node))
      ((= tag (quote lua-break)) (list (make-symbol "raise") (list (make-symbol "list") (list (make-symbol "quote") (make-symbol "lua-brk")))))
      ((= tag (quote lua-return)) (lua-tx-return node))
      ((= tag (quote lua-call-stmt)) (lua-tx (nth node 1)))
      ((= tag (quote lua-local-function)) (lua-tx-local-function node))
      ((= tag (quote lua-function-decl)) (lua-tx-function-decl node))
      (else (error (str "lua-transpile: unknown node " tag))))))

(define
  lua-tx-binop
  (fn
    (node)
    (let
      ((op (nth node 1))
        (a (lua-tx (nth node 2)))
        (b (lua-tx (nth node 3))))
      (cond
        ((= op "+") (list (make-symbol "lua-add") a b))
        ((= op "-") (list (make-symbol "lua-sub") a b))
        ((= op "*") (list (make-symbol "lua-mul") a b))
        ((= op "/") (list (make-symbol "lua-div") a b))
        ((= op "%") (list (make-symbol "lua-mod") a b))
        ((= op "^") (list (make-symbol "lua-pow") a b))
        ((= op "..") (list (make-symbol "lua-concat") a b))
        ((= op "==") (list (make-symbol "lua-eq") a b))
        ((= op "~=") (list (make-symbol "lua-neq") a b))
        ((= op "<") (list (make-symbol "lua-lt") a b))
        ((= op "<=") (list (make-symbol "lua-le") a b))
        ((= op ">") (list (make-symbol "lua-gt") a b))
        ((= op ">=") (list (make-symbol "lua-ge") a b))
        ((= op "and")
          (list
            (make-symbol "let")
            (list (list (make-symbol "_la") a))
            (list
              (make-symbol "if")
              (list (make-symbol "lua-truthy?") (make-symbol "_la"))
              b
              (make-symbol "_la"))))
        ((= op "or")
          (list
            (make-symbol "let")
            (list (list (make-symbol "_la") a))
            (list
              (make-symbol "if")
              (list (make-symbol "lua-truthy?") (make-symbol "_la"))
              (make-symbol "_la")
              b)))
        (else (error (str "lua-transpile: unknown binop " op)))))))

(define
  lua-tx-unop
  (fn
    (node)
    (let
      ((op (nth node 1)) (e (lua-tx (nth node 2))))
      (cond
        ((= op "-") (list (make-symbol "lua-neg") e))
        ((= op "not")
          (list (make-symbol "not") (list (make-symbol "lua-truthy?") e)))
        ((= op "#") (list (make-symbol "lua-len") e))
        (else (error (str "lua-transpile: unknown unop " op)))))))

(define
  lua-tx-call
  (fn
    (node)
    (let
      ((fn-ast (nth node 1)) (args (nth node 2)))
      (cons
        (make-symbol "lua-call")
        (cons (lua-tx fn-ast) (map lua-tx args))))))

(define
  lua-tx-method-call
  (fn
    (node)
    (let
      ((obj (lua-tx (nth node 1)))
        (name (nth node 2))
        (args (nth node 3)))
      (let
        ((tmp (make-symbol "__obj")))
        (list
          (make-symbol "let")
          (list (list tmp obj))
          (cons
            (make-symbol "lua-call")
            (cons
              (list (make-symbol "lua-get") tmp name)
              (cons tmp (map lua-tx args)))))))))

(define
  lua-tx-field
  (fn
    (node)
    (list (make-symbol "lua-get") (lua-tx (nth node 1)) (nth node 2))))

(define
  lua-tx-index
  (fn
    (node)
    (list
      (make-symbol "lua-get")
      (lua-tx (nth node 1))
      (lua-tx (nth node 2)))))

(define
  lua-tx-table
  (fn
    (node)
    (let
      ((fields (rest node)))
      (cons (make-symbol "lua-make-table") (map lua-tx-table-field fields)))))

(define
  lua-tx-table-field
  (fn
    (f)
    (cond
      ((= (first f) (quote lua-pos))
        (list (make-symbol "list") "pos" (lua-tx (nth f 1))))
      ((= (first f) (quote lua-kv))
        (list
          (make-symbol "list")
          "kv"
          (lua-tx (nth f 1))
          (lua-tx (nth f 2))))
      (else (error "lua-transpile: unknown table field")))))

(define
  lua-tx-function-bindings
  (fn
    (params i)
    (if
      (>= i (len params))
      (list)
      (cons
        (list
          (make-symbol (nth params i))
          (list (make-symbol "lua-arg") (make-symbol "__args") i))
        (lua-tx-function-bindings params (+ i 1))))))

(define
  lua-tx-function-varargs-binding
  (fn (n)
    (list
      (make-symbol "__varargs")
      (list (make-symbol "lua-varargs") (make-symbol "__args") n))))

(define
  lua-tx-function-arg-binding
  (fn (n)
    (list
      (make-symbol "arg")
      (list (make-symbol "lua-varargs-arg-table") (make-symbol "__args") n))))

(define
  lua-tx-function-guard
  (fn (body-sx)
    (list
      (make-symbol "guard")
      (list (make-symbol "e")
        (list
          (list (make-symbol "lua-return-sentinel?") (make-symbol "e"))
          (list (make-symbol "lua-return-value") (make-symbol "e"))))
      body-sx)))

(define
  lua-tx-function
  (fn
    (node)
    (let
      ((params (nth node 1))
        (is-vararg (nth node 2))
        (body (nth node 3)))
      (cond
        ((and (= (len params) 0) (not is-vararg))
          (list
            (make-symbol "fn")
            (list (make-symbol "&rest") (make-symbol "__args"))
            (lua-tx-function-guard (lua-tx body))))
        (else
          (let
            ((bindings (lua-tx-function-bindings params 0)))
            (let
              ((all-bindings
                 (if is-vararg
                     (append bindings
                       (list
                         (lua-tx-function-varargs-binding (len params))
                         (lua-tx-function-arg-binding (len params))))
                     bindings)))
              (list
                (make-symbol "fn")
                (list (make-symbol "&rest") (make-symbol "__args"))
                (lua-tx-function-guard
                  (list
                    (make-symbol "let")
                    all-bindings
                    (lua-tx body)))))))))))

(define
  lua-tx-block
  (fn
    (node)
    (let
      ((stmts (rest node)))
      (cond
        ((= (len stmts) 0) nil)
        ((= (len stmts) 1) (lua-tx (first stmts)))
        (else (cons (make-symbol "begin") (map lua-tx stmts)))))))

(define
  lua-tx-local
  (fn
    (node)
    (let
      ((names (nth node 1)) (exps (nth node 2)))
      (cond
        ((= (len names) 1)
          (list
            (make-symbol "define")
            (make-symbol (first names))
            (if
              (> (len exps) 0)
              (list (make-symbol "lua-first") (lua-tx (first exps)))
              nil)))
        ((= (len exps) 0)
          (cons (make-symbol "begin") (lua-tx-local-pairs names exps 0)))
        (else (lua-tx-multi-local names exps))))))

(define
  lua-tx-local-pairs
  (fn
    (names exps i)
    (if
      (>= i (len names))
      (list)
      (cons
        (list
          (make-symbol "define")
          (make-symbol (nth names i))
          (if (< i (len exps)) (lua-tx (nth exps i)) nil))
        (lua-tx-local-pairs names exps (+ i 1))))))

(define
  lua-tx-assign
  (fn
    (node)
    (let
      ((lhss (nth node 1)) (rhss (nth node 2)))
      (cond
        ((= (len lhss) 1)
          (lua-tx-single-assign
            (first lhss)
            (list (make-symbol "lua-first") (lua-tx (first rhss)))))
        ((= (len rhss) 0)
          (cons (make-symbol "begin") (lua-tx-assign-pairs lhss rhss 0)))
        (else (lua-tx-multi-assign lhss rhss))))))

(define
  lua-tx-assign-pairs
  (fn
    (lhss rhss i)
    (if
      (>= i (len lhss))
      (list)
      (cons
        (lua-tx-single-assign
          (nth lhss i)
          (if (< i (len rhss)) (lua-tx (nth rhss i)) nil))
        (lua-tx-assign-pairs lhss rhss (+ i 1))))))

(define
  lua-tx-single-assign
  (fn
    (lhs rhs)
    (cond
      ((= (first lhs) (quote lua-name))
        (list (make-symbol "set!") (make-symbol (nth lhs 1)) rhs))
      ((= (first lhs) (quote lua-field))
        (list
          (make-symbol "lua-set!")
          (lua-tx (nth lhs 1))
          (nth lhs 2)
          rhs))
      ((= (first lhs) (quote lua-index))
        (list
          (make-symbol "lua-set!")
          (lua-tx (nth lhs 1))
          (lua-tx (nth lhs 2))
          rhs))
      (else (error "lua-transpile: bad assignment target")))))

(define
  lua-tx-if-body
  (fn (body)
    (list (make-symbol "let") (list) body)))

(define
  lua-tx-if
  (fn
    (node)
    (let
      ((cnd (lua-tx (nth node 1)))
        (then-body (lua-tx-if-body (lua-tx (nth node 2))))
        (elseifs (nth node 3))
        (else-body (nth node 4)))
      (if
        (and (= (len elseifs) 0) (= else-body nil))
        (list
          (make-symbol "when")
          (list (make-symbol "lua-truthy?") cnd)
          then-body)
        (lua-tx-if-cond cnd then-body elseifs else-body)))))

(define
  lua-tx-if-cond
  (fn
    (cnd then-body elseifs else-body)
    (let
      ((clauses (cons (list (list (make-symbol "lua-truthy?") cnd) then-body) (map lua-tx-elseif elseifs))))
      (cons
        (make-symbol "cond")
        (if
          (= else-body nil)
          clauses
          (append
            clauses
            (list (list (make-symbol "else") (lua-tx-if-body (lua-tx else-body))))))))))

(define
  lua-tx-elseif
  (fn
    (pair)
    (list
      (list (make-symbol "lua-truthy?") (lua-tx (first pair)))
      (lua-tx-if-body (lua-tx (nth pair 1))))))

(define
  lua-tx-while
  (fn
    (node)
    (let
      ((cnd (lua-tx (nth node 1))) (body (lua-tx (nth node 2))))
      (list
        (make-symbol "let")
        (list)
        (list
          (make-symbol "define")
          (make-symbol "_while_loop")
          (list
            (make-symbol "fn")
            (list)
            (list
              (make-symbol "when")
              (list (make-symbol "lua-truthy?") cnd)
              (list
                (make-symbol "begin")
                body
                (list (make-symbol "_while_loop"))))))
        (lua-tx-loop-guard (list (make-symbol "_while_loop")))))))

(define
  lua-tx-repeat
  (fn
    (node)
    (let
      ((body (lua-tx (nth node 1))) (cnd (lua-tx (nth node 2))))
      (list
        (make-symbol "let")
        (list)
        (list
          (make-symbol "define")
          (make-symbol "_repeat_loop")
          (list
            (make-symbol "fn")
            (list)
            (list
              (make-symbol "begin")
              body
              (list
                (make-symbol "when")
                (list
                  (make-symbol "not")
                  (list (make-symbol "lua-truthy?") cnd))
                (list (make-symbol "_repeat_loop"))))))
        (lua-tx-loop-guard (list (make-symbol "_repeat_loop")))))))

(define
  lua-tx-for-num
  (fn
    (node)
    (let
      ((name (nth node 1))
        (start (lua-tx (nth node 2)))
        (stop (lua-tx (nth node 3)))
        (step-ast (nth node 4))
        (body (lua-tx (nth node 5))))
      (let
        ((step (if (= step-ast nil) 1 (lua-tx step-ast))))
        (list
          (make-symbol "let")
          (list
            (list (make-symbol "_for_stop") stop)
            (list (make-symbol "_for_step") step))
          (list (make-symbol "define") (make-symbol name) start)
          (list
            (make-symbol "define")
            (make-symbol "_for_loop")
            (list
              (make-symbol "fn")
              (list)
              (list
                (make-symbol "when")
                (list
                  (make-symbol "lua-for-continue?")
                  (make-symbol name)
                  (make-symbol "_for_stop")
                  (make-symbol "_for_step"))
                (list
                  (make-symbol "begin")
                  body
                  (list
                    (make-symbol "set!")
                    (make-symbol name)
                    (list
                      (make-symbol "+")
                      (make-symbol name)
                      (make-symbol "_for_step")))
                  (list (make-symbol "_for_loop"))))))
          (lua-tx-loop-guard (list (make-symbol "_for_loop"))))))))

(define lua-tx-do (fn (node) (list (make-symbol "let") (list) (lua-tx (nth node 1)))))

(define
  lua-tx-return
  (fn
    (node)
    (let
      ((exps (nth node 1)))
      (let
        ((val
          (cond
            ((= (len exps) 0) nil)
            ((= (len exps) 1) (lua-tx (first exps)))
            (else
              (list
                (make-symbol "lua-pack-return")
                (cons (make-symbol "list") (lua-tx-multi-args exps 0)))))))
        (list
          (make-symbol "raise")
          (list (make-symbol "list") (list (make-symbol "quote") (make-symbol "lua-ret")) val))))))

(define
  lua-tx-local-function
  (fn
    (node)
    (let
      ((name (nth node 1)) (func (nth node 2)))
      (list (make-symbol "define") (make-symbol name) (lua-tx func)))))

(define
  lua-tx-function-decl
  (fn
    (node)
    (let
      ((target (nth node 1)) (func (nth node 2)))
      (cond
        ((= (first target) (quote lua-name))
          (list
            (make-symbol "define")
            (make-symbol (nth target 1))
            (lua-tx func)))
        ((= (first target) (quote lua-field))
          (list
            (make-symbol "lua-set!")
            (lua-tx (nth target 1))
            (nth target 2)
            (lua-tx func)))
        (else (error "lua-transpile: bad function decl target"))))))

(define lua-transpile (fn (src) (lua-tx (lua-parse src))))

(define
  lua-ret-raise?
  (fn (x)
    (and (= (type-of x) "list")
         (= (len x) 2)
         (= (first x) (make-symbol "raise"))
         (= (type-of (nth x 1)) "list")
         (= (len (nth x 1)) 3)
         (= (first (nth x 1)) (make-symbol "list"))
         (= (type-of (nth (nth x 1) 1)) "list")
         (= (first (nth (nth x 1) 1)) (make-symbol "quote"))
         (= (nth (nth (nth x 1) 1) 1) (make-symbol "lua-ret")))))

(define
  lua-ret-value
  (fn (raise-form) (nth (nth raise-form 1) 2)))

(define
  lua-unwrap-final-return
  (fn (sx)
    (cond
      ((lua-ret-raise? sx) (lua-ret-value sx))
      ((and (= (type-of sx) "list") (> (len sx) 0) (= (first sx) (make-symbol "begin")))
        (let ((items (rest sx)))
          (cond
            ((= (len items) 0) sx)
            (else
              (let ((last-item (nth items (- (len items) 1))))
                (cond
                  ((lua-ret-raise? last-item)
                    (let ((val (lua-ret-value last-item))
                          (prefix (lua-init-before items 0 (- (len items) 1))))
                      (cons (make-symbol "begin") (append prefix (list val)))))
                  (else sx)))))))
      (else sx))))

(define
  lua-has-top-return?
  (fn (node)
    (cond
      ((not (= (type-of node) "list")) false)
      ((= (len node) 0) false)
      ((= (first node) (quote lua-return)) true)
      ((or (= (first node) (quote lua-function))
           (= (first node) (quote lua-local-function))
           (= (first node) (quote lua-function-decl)))
        false)
      (else
        (lua-has-top-return-children? (rest node) 0)))))

(define
  lua-has-top-return-children?
  (fn (children i)
    (cond
      ((>= i (len children)) false)
      ((lua-has-top-return? (nth children i)) true)
      (else (lua-has-top-return-children? children (+ i 1))))))

(define
  lua-eval-ast
  (fn (src)
    (let ((parsed (lua-parse src)))
      (let ((sx (lua-tx parsed)))
        (let ((sx2 (lua-unwrap-final-return sx)))
          (cond
            ((lua-has-top-return? parsed)
              (eval-expr (lua-tx-function-guard sx2)))
            (else
              (eval-expr sx2))))))))

(define
  lua-tx-multi-args
  (fn
    (exps i)
    (cond
      ((>= i (len exps)) (list))
      ((= i (- (len exps) 1))
        (cons (lua-tx (nth exps i)) (lua-tx-multi-args exps (+ i 1))))
      (else
        (cons
          (list (make-symbol "lua-first") (lua-tx (nth exps i)))
          (lua-tx-multi-args exps (+ i 1)))))))

(define
  lua-tx-multi-rhs
  (fn
    (exps)
    (list
      (make-symbol "lua-pack-return")
      (cons (make-symbol "list") (lua-tx-multi-args exps 0)))))

(define
  lua-tx-multi-local
  (fn
    (names exps)
    (let
      ((tmp (make-symbol "__rets")))
      (cons
        (make-symbol "begin")
        (append
          (lua-tx-multi-local-decls names 0)
          (list
            (list
              (make-symbol "let")
              (list (list tmp (lua-tx-multi-rhs exps)))
              (cons
                (make-symbol "begin")
                (lua-tx-multi-local-sets names tmp 0)))))))))

(define
  lua-tx-multi-local-decls
  (fn
    (names i)
    (if
      (>= i (len names))
      (list)
      (cons
        (list (make-symbol "define") (make-symbol (nth names i)) nil)
        (lua-tx-multi-local-decls names (+ i 1))))))

(define
  lua-tx-multi-local-sets
  (fn
    (names tmp i)
    (if
      (>= i (len names))
      (list)
      (cons
        (list
          (make-symbol "set!")
          (make-symbol (nth names i))
          (list (make-symbol "lua-nth-ret") tmp i))
        (lua-tx-multi-local-sets names tmp (+ i 1))))))

(define
  lua-tx-multi-assign
  (fn
    (lhss rhss)
    (let
      ((tmp (make-symbol "__rets")))
      (list
        (make-symbol "let")
        (list (list tmp (lua-tx-multi-rhs rhss)))
        (cons (make-symbol "begin") (lua-tx-multi-assign-pairs lhss tmp 0))))))

(define
  lua-tx-multi-assign-pairs
  (fn
    (lhss tmp i)
    (if
      (>= i (len lhss))
      (list)
      (cons
        (lua-tx-single-assign
          (nth lhss i)
          (list (make-symbol "lua-nth-ret") tmp i))
        (lua-tx-multi-assign-pairs lhss tmp (+ i 1))))))

(define
  lua-tx-for-in-decls
  (fn
    (names i)
    (if
      (>= i (len names))
      (list)
      (cons
        (list (make-symbol "define") (make-symbol (nth names i)) nil)
        (lua-tx-for-in-decls names (+ i 1))))))

(define
  lua-tx-for-in-sets
  (fn
    (names rets-sym i)
    (if
      (>= i (len names))
      (list)
      (cons
        (list
          (make-symbol "set!")
          (make-symbol (nth names i))
          (list (make-symbol "lua-nth-ret") rets-sym i))
        (lua-tx-for-in-sets names rets-sym (+ i 1))))))

(define
  lua-tx-for-in-step-body
  (fn
    (names body v-sym loop-sym first-name)
    (list
      (make-symbol "when")
      (list (make-symbol "not") (list (make-symbol "=") first-name nil))
      (list
        (make-symbol "begin")
        (list (make-symbol "set!") v-sym first-name)
        body
        (list loop-sym)))))

(define
  lua-tx-for-in-loop-body
  (fn
    (names body f-sym s-sym v-sym rets-sym loop-sym first-name)
    (list
      (make-symbol "let")
      (list
        (list
          rets-sym
          (list
            (make-symbol "lua-pack-return")
            (list
              (make-symbol "list")
              (list (make-symbol "lua-call") f-sym s-sym v-sym)))))
      (cons
        (make-symbol "begin")
        (append
          (lua-tx-for-in-sets names rets-sym 0)
          (list (lua-tx-for-in-step-body names body v-sym loop-sym first-name)))))))

(define
  lua-tx-for-in
  (fn
    (node)
    (let
      ((names (nth node 1))
        (exps (nth node 2))
        (body (lua-tx (nth node 3))))
      (let
        ((pack-sym (make-symbol "__for_pack"))
          (f-sym (make-symbol "__for_f"))
          (s-sym (make-symbol "__for_s"))
          (v-sym (make-symbol "__for_var"))
          (rets-sym (make-symbol "__for_rets"))
          (loop-sym (make-symbol "__for_loop"))
          (first-name (make-symbol (first names))))
        (list
          (make-symbol "let")
          (list (list pack-sym (lua-tx-multi-rhs exps)))
          (list
            (make-symbol "let")
            (list
              (list f-sym (list (make-symbol "lua-nth-ret") pack-sym 0))
              (list s-sym (list (make-symbol "lua-nth-ret") pack-sym 1))
              (list v-sym (list (make-symbol "lua-nth-ret") pack-sym 2)))
            (cons
              (make-symbol "begin")
              (append
                (lua-tx-for-in-decls names 0)
                (list
                  (list
                    (make-symbol "define")
                    loop-sym
                    (list
                      (make-symbol "fn")
                      (list)
                      (lua-tx-for-in-loop-body names body f-sym s-sym v-sym rets-sym loop-sym first-name)))
                  (lua-tx-loop-guard (list loop-sym)))))))))))