(define ml-reserved (list "and" "as" "assert" "asr" "begin" "class" "constraint" "do" "done" "downto" "else" "end" "exception" "external" "false" "for" "fun" "function" "functor" "if" "in" "include" "inherit" "initializer" "land" "lazy" "let" "lor" "lsl" "lsr" "lxor" "match" "method" "mod" "module" "mutable" "new" "nonrec" "object" "of" "open" "or" "private" "rec" "sig" "struct" "then" "to" "true" "try" "type" "val" "virtual" "when" "while" "with" "ref" "not" "ignore" "print" "list" "string" "int" "float" "option" "result")) (define ml-renames {:eval-expr "eval_expr" :macro-closure "macro_closure" :*render-fn* "render_fn" :thunk-env "thunk_env" :dict-has? "dict_has" :escape-attr "escape_attr" :thunk-expr "thunk_expr" :get-primitive "get_primitive" :*custom-special-forms* "custom_special_forms" :sx-serialize "sx_serialize" :component-closure "component_closure" :lambda-params "lambda_params" :callable? "is_callable" :island? "is_island" :symbol-name "symbol_name" :string-contains? "string_contains_p" :set-lambda-name! "set_lambda_name" :macro? "is_macro" :true "(Bool true)" :keyword-name "keyword_name" :env-bind! "env_bind" :scope-pop! "scope_pop" :BOOLEAN_ATTRS "boolean_attrs" :expand-macro "expand_macro" :contains? "contains_p" :map-dict "map_dict" :*render-check* "render_check" :macro-body "macro_body" :for-each-indexed "for_each_indexed" :emit! "sx_emit" :context "sx_context" :env-extend "env_extend" :spread? "is_spread" :is-else-clause? "is_else_clause" :component-params "component_params" :dict-delete! "dict_delete" :every? "every_p" :make-component "make_component" :lambda-name "lambda_name" :char-from-code "char_from_code" :spread-attrs "spread_attrs" :component-affinity "component_affinity" :component? "is_component" :call-lambda "call_lambda" :make-thunk "make_thunk" :make-symbol "make_symbol" :dict-get "dict_get" :provide-pop! "provide_pop" :component-body "component_body" :make-spread "make_spread" :emitted "sx_emitted" :provide-push! "provide_push" :make-keyword "make_keyword" :scope-emit! "scope_emit" :register-special-form! "register_special_form" :lambda-body "lambda_body" :escape-string "escape_string" :for-each "for_each" :scope-peek "scope_peek" :make-island "make_island" :string-length "string_length" :nil "Nil" :has-key? "has_key_p" :HTML_TAGS "html_tags" :macro-rest-param "macro_rest_param" :env-has? "env_has" :make-raw-html "make_raw_html" :type-of "type_of" :component-name "component_name" :map-indexed "map_indexed" :render-to-html "render_to_html" :env-set! "env_set" :dict-set! "dict_set" :collected "sx_collected" :clear-collected! "sx_clear_collected" :make-macro "make_macro" :identical? "is_identical" :escape-html "escape_html" :starts-with? "starts_with_p" :make-lambda "make_lambda" :empty? "empty_p" :lambda-closure "lambda_closure" :thunk? "is_thunk" :ends-with? "ends_with_p" :component-has-children? "component_has_children" :VOID_ELEMENTS "void_elements" :env-merge "env_merge" :raw-html-content "raw_html_content" :lambda? "is_lambda" :false "(Bool false)" :parse-float "parse_float" :collect! "sx_collect" :nil? "is_nil" :env-get "env_get" :index-of "index_of" :scope-push! "scope_push" :signal? "is_signal" :macro-params "macro_params" :primitive? "is_primitive" :parse-int "parse_int"}) (define ml-mangle (fn ((name :as string)) (let ((renamed (get ml-renames name))) (if (not (nil? renamed)) renamed (let ((result name)) (let ((result (cond (ends-with? result "?") (str (slice result 0 (- (string-length result) 1)) "_p") (ends-with? result "!") (str (slice result 0 (- (string-length result) 1)) "_b") :else result))) (let ((result (replace result "-" "_"))) (let ((result (replace result "*" "_"))) (if (some (fn (r) (= r result)) ml-reserved) (str result "'") result))))))))) (define ml-runtime-names (list "env-bind!" "env-set!" "env-get" "env-has?" "env-extend" "env-merge" "make-env" "make-lambda" "make-component" "make-island" "make-macro" "make-thunk" "make-symbol" "make-keyword" "set-lambda-name!" "type-of" "symbol-name" "keyword-name" "inspect" "lambda-params" "lambda-body" "lambda-closure" "lambda-name" "component-params" "component-body" "component-closure" "component-has-children?" "component-name" "component-affinity" "macro-params" "macro-rest-param" "macro-body" "macro-closure" "thunk-expr" "thunk-env" "thunk?" "callable?" "lambda?" "component?" "island?" "macro?" "signal?" "primitive?" "nil?" "identical?" "get-primitive" "trampoline" "sx-serialize" "prim-call" "first" "rest" "last" "nth" "cons" "append" "reverse" "flatten" "concat" "len" "get" "empty?" "list?" "dict?" "number?" "string?" "boolean?" "symbol?" "keyword?" "contains?" "has-key?" "starts-with?" "ends-with?" "string-contains?" "odd?" "even?" "zero?" "upper" "upcase" "lower" "downcase" "trim" "split" "join" "replace" "index-of" "substring" "string-length" "char-from-code" "keys" "vals" "assoc" "dissoc" "merge" "dict-set!" "dict-get" "dict-has?" "dict-delete!" "abs" "sqrt" "pow" "floor" "ceil" "round" "min" "max" "clamp" "parse-int" "parse-float" "error" "host-error" "apply" "make-spread" "spread?" "spread-attrs" "map-indexed" "map-dict" "for-each" "for-each-indexed" "cek-call" "cek-run" "sx-call" "sx-apply" "collect!" "collected" "clear-collected!" "context" "emit!" "emitted" "scope-push!" "scope-pop!" "provide-push!" "provide-pop!" "with-island-scope" "register-in-scope" "signal-value" "signal-set-value" "signal-subscribers" "signal-add-sub!" "signal-remove-sub!" "signal-deps" "signal-set-deps" "notify-subscribers" "flush-subscribers" "dispose-computed" "continuation?" "continuation-data" "make-cek-continuation" "callcc-continuation?" "callcc-continuation-data" "make-callcc-continuation" "dynamic-wind-call" "strip-prefix" "component-set-param-types!" "component-file" "component-set-file!" "parse-comp-params" "parse-macro-params" "parse-keyword-args")) (define ml-is-known-name? (fn ((name :as string)) (if (not (nil? (get ml-renames name))) true (if (some (fn (r) (= r name)) ml-runtime-names) true (some (fn (d) (= d name)) _known_defines))))) (define ml-dynamic-globals (list "*render-check*" "*render-fn*")) (define ml-mutable-globals (list "*strict*" "*prim-param-types*")) (define ml-is-mutable-global? (fn (name) (some (fn (g) (= g name)) ml-mutable-globals))) (define ml-is-dyn-global? (fn ((name :as string)) (some (fn (g) (= g name)) ml-dynamic-globals))) (define ml-is-dyn-var? (fn ((name :as string) (set-vars :as list)) (some (fn (v) (= v (str "dyn:" name))) set-vars))) (define ml-quote-string (fn ((s :as string)) (str "\"" (replace (replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\t" "\\t") "\""))) (define ml-is-self-recursive? (fn ((name :as string) body) (ml-scan-for-name name body))) (define ml-scan-for-name (fn ((name :as string) node) (cond (and (= (type-of node) "symbol") (= (symbol-name node) name)) true (list? node) (some (fn (child) (ml-scan-for-name name child)) node) :else false))) (define ml-find-let-bound-names (fn ((body :as list)) (let ((result (list))) (begin (for-each (fn (b) (ml-scan-let-names b result)) body) result)))) (define ml-scan-let-names (fn (node (result :as list)) (when (and (list? node) (not (empty? node))) (let ((head (first node))) (cond (and (= (type-of head) "symbol") (or (= (symbol-name head) "let") (= (symbol-name head) "let*")) (>= (len node) 2) (list? (nth node 1))) (let ((bindings (nth node 1))) (begin (if (and (not (empty? bindings)) (list? (first bindings))) (for-each (fn (b) (when (and (list? b) (>= (len b) 1)) (let ((vname (if (= (type-of (first b)) "symbol") (ml-mangle (symbol-name (first b))) (str (first b))))) (when (not (some (fn (x) (= x vname)) result)) (append! result vname))))) bindings) (let ((i 0)) (for-each (fn (item) (when (= (mod i 2) 0) (let ((vname (if (= (type-of item) "symbol") (ml-mangle (symbol-name item)) (str item)))) (when (not (some (fn (x) (= x vname)) result)) (append! result vname))))) bindings))) (for-each (fn (child) (ml-scan-let-names child result)) (rest (rest node))))) :else (for-each (fn (child) (when (list? child) (ml-scan-let-names child result))) node)))))) (define ml-find-set-targets (fn ((body :as list)) (let ((result (list))) (begin (for-each (fn (b) (ml-scan-set b result)) body) result)))) (define ml-scan-set (fn (node (result :as list)) (when (and (list? node) (not (empty? node))) (let ((head (first node))) (cond (and (= (type-of head) "symbol") (= (symbol-name head) "set!") (>= (len node) 2)) (let ((var-name (if (= (type-of (nth node 1)) "symbol") (symbol-name (nth node 1)) (str (nth node 1))))) (let ((mangled (ml-mangle var-name))) (when (not (some (fn (x) (= x mangled)) result)) (append! result mangled)))) (and (= (type-of head) "symbol") (= (symbol-name head) "append!") (>= (len node) 2) (= (type-of (nth node 1)) "symbol")) (let ((var-name (symbol-name (nth node 1)))) (let ((mangled (ml-mangle var-name))) (when (not (some (fn (x) (= x mangled)) result)) (append! result mangled)))) :else (for-each (fn (child) (when (list? child) (ml-scan-set child result))) node)))))) (define ml-expr (fn (expr) (ml-expr-inner expr (list)))) (define ml-expr-inner (fn (expr (set-vars :as list)) (cond (= (type-of expr) "boolean") (if expr "(Bool true)" "(Bool false)") (nil? expr) "Nil" (number? expr) (if (string-contains? (str expr) ".") (str "(Number " (str expr) ")") (str "(Number " (str expr) ".0)")) (string? expr) (str "(String " (ml-quote-string expr) ")") (= (type-of expr) "symbol") (let ((mangled (ml-mangle (symbol-name expr)))) (if (ml-is-mutable-global? (symbol-name expr)) (str "!" mangled "ref") (if (some (fn (c) (= c mangled)) set-vars) (str "!" mangled) mangled))) (= (type-of expr) "keyword") (str "(String " (ml-quote-string (keyword-name expr)) ")") (= (type-of expr) "dict") (ml-emit-dict-native expr set-vars) (list? expr) (if (empty? expr) "[]" (ml-emit-list expr set-vars)) :else (str "(* ??? *) " (str expr))))) (define ml-emit-dict-native (fn ((d :as dict) (set-vars :as list)) (let ((items (keys d))) (if (and (= (len items) 5) (some (fn (k) (= k "control")) items) (some (fn (k) (= k "phase")) items) (some (fn (k) (= k "kont")) items)) (str "(CekState { cs_control = " (ml-expr-inner (get d "control") set-vars) "; cs_env = " (ml-expr-inner (get d "env") set-vars) "; cs_kont = " (ml-expr-inner (get d "kont") set-vars) "; cs_phase = " (let ((p (get d "phase"))) (if (= (type-of p) "string") (ml-quote-string p) (str "(match " (ml-expr-inner p set-vars) " with String s -> s | _ -> \"\")"))) "; cs_value = " (ml-expr-inner (get d "value") set-vars) " })") (if (and (some (fn (k) (= k "type")) items) (= (type-of (get d "type")) "string")) (let ((frame-type (get d "type")) (ef (fn (field) (if (some (fn (k) (= k field)) items) (ml-expr-inner (get d field) set-vars) "Nil")))) (str "(CekFrame { cf_type = " (ml-quote-string frame-type) "; cf_env = " (ef "env") "; cf_name = " (if (= frame-type "if") (ef "else") (ef "name")) "; cf_body = " (if (= frame-type "if") (ef "then") (ef "body")) "; cf_remaining = " (ef "remaining") "; cf_f = " (ef "f") "; cf_args = " (cond (some (fn (k) (= k "evaled")) items) (ef "evaled") (some (fn (k) (= k "args")) items) (ef "args") :else "Nil") "; cf_results = " (cond (some (fn (k) (= k "results")) items) (ef "results") (some (fn (k) (= k "raw-args")) items) (ef "raw-args") :else "Nil") "; cf_extra = " (cond (some (fn (k) (= k "ho-type")) items) (ef "ho-type") (some (fn (k) (= k "scheme")) items) (ef "scheme") (some (fn (k) (= k "indexed")) items) (ef "indexed") (some (fn (k) (= k "value")) items) (ef "value") (some (fn (k) (= k "phase")) items) (ef "phase") (some (fn (k) (= k "has-effects")) items) (ef "has-effects") (some (fn (k) (= k "match-val")) items) (ef "match-val") (some (fn (k) (= k "current-item")) items) (ef "current-item") (some (fn (k) (= k "update-fn")) items) (ef "update-fn") (some (fn (k) (= k "head-name")) items) (ef "head-name") :else "Nil") "; cf_extra2 = " (cond (some (fn (k) (= k "emitted")) items) (ef "emitted") (some (fn (k) (= k "effect-list")) items) (ef "effect-list") (some (fn (k) (= k "first-render")) items) (ef "first-render") :else "Nil") " })")) (str "(let _d = Hashtbl.create " (str (round (len items))) " in " (join "; " (map (fn (k) (str "Hashtbl.replace _d " (ml-quote-string k) " " (ml-expr-inner (get d k) set-vars))) items)) "; Dict _d)")))))) (define ml-emit-list (fn (expr (set-vars :as list)) (let ((head (first expr)) (args (rest expr))) (if (not (= (type-of head) "symbol")) (if (list? head) (str "(cek_call (" (ml-expr-inner head set-vars) ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") (str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]")) (let ((op (symbol-name head))) (cond (or (= op "fn") (= op "lambda")) (ml-emit-fn expr set-vars) (or (= op "let") (= op "let*")) (ml-emit-let expr set-vars) (= op "if") (let ((cond-e (ml-expr-inner (nth args 0) set-vars)) (then-e (ml-expr-inner (nth args 1) set-vars)) (else-e (if (>= (len args) 3) (ml-expr-inner (nth args 2) set-vars) "Nil"))) (str "(if sx_truthy (" cond-e ") then " then-e " else " else-e ")")) (= op "when") (ml-emit-when expr set-vars) (= op "cond") (ml-emit-cond args set-vars) (or (= op "case") (= op "match")) (ml-emit-case args set-vars) (= op "and") (ml-emit-and args set-vars) (= op "or") (ml-emit-or args set-vars) (= op "not") (str "(Bool (not (sx_truthy (" (ml-expr-inner (first args) set-vars) "))))") (or (= op "do") (= op "begin")) (ml-emit-do args set-vars) (= op "list") (str "(List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "dict") (ml-emit-dict-call args set-vars) (= op "quote") (ml-emit-quote (first args)) (= op "set!") (let ((var-name (symbol-name (first args)))) (if (ml-is-mutable-global? var-name) (str "(" (ml-mangle var-name) "ref := " (ml-expr-inner (nth args 1) set-vars) "; Nil)") (let ((mangled (ml-mangle var-name))) (str "(" mangled " := " (ml-expr-inner (nth args 1) set-vars) "; Nil)")))) (= op "str") (str "(String (sx_str [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") (= op "error") (str "(raise (Eval_error (value_to_str " (ml-expr-inner (first args) set-vars) ")))") (= op "+") (str "(prim_call \"+\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "-") (str "(prim_call \"-\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "*") (str "(prim_call \"*\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "/") (str "(prim_call \"/\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "mod") (str "(prim_call \"mod\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "=") (str "(prim_call \"=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "!=") (str "(prim_call \"!=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "<") (str "(prim_call \"<\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op ">") (str "(prim_call \">\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "<=") (str "(prim_call \"<=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op ">=") (str "(prim_call \">=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "apply") (str "(sx_apply " (ml-expr-inner (first args) set-vars) " " (ml-expr-inner (nth args 1) set-vars) ")") (= op "for-each") (ml-emit-for-each args set-vars) (= op "map") (ml-emit-ho-form "List.map" "(fun _x -> " ")" "List" args set-vars) (= op "map-indexed") (ml-emit-ho-indexed args set-vars) (= op "filter") (ml-emit-ho-form "List.filter" "(fun _x -> sx_truthy (" "))" "List" args set-vars) (= op "reduce") (ml-emit-reduce args set-vars) (= op "some") (ml-emit-ho-form "List.exists" "(fun _x -> sx_truthy (" "))" "Bool" args set-vars) (= op "every?") (ml-emit-ho-form "List.for_all" "(fun _x -> sx_truthy (" "))" "Bool" args set-vars) (= op "map-dict") (ml-emit-map-dict args set-vars) (= op "append!") (let ((target (nth args 0)) (item-expr (ml-expr-inner (nth args 1) set-vars))) (if (and (= (type-of target) "symbol") (some (fn (v) (= v (ml-mangle (symbol-name target)))) set-vars)) (let ((mangled (ml-mangle (symbol-name target)))) (str "(" mangled " := sx_append_b !" mangled " " item-expr "; Nil)")) (str "(sx_append_b " (ml-expr-inner target set-vars) " " item-expr ")"))) (= op "dict-set!") (str "(sx_dict_set_b " (ml-expr-inner (nth args 0) set-vars) " " (ml-expr-inner (nth args 1) set-vars) " " (ml-expr-inner (nth args 2) set-vars) ")") (= op "env-bind!") (str "(env_bind " (ml-expr-inner (nth args 0) set-vars) " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) ")" " " (ml-expr-inner (nth args 2) set-vars) ")") (= op "env-set!") (str "(env_set " (ml-expr-inner (nth args 0) set-vars) " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) ")" " " (ml-expr-inner (nth args 2) set-vars) ")") (= op "set-lambda-name!") (str "(set_lambda_name " (ml-expr-inner (nth args 0) set-vars) " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) "))") (or (= op "slice") (= op "concat") (= op "range") (= op "sort") (= op "merge") (= op "round") (= op "min") (= op "max") (= op "substring") (= op "assoc") (= op "dissoc") (= op "append") (= op "flatten") (= op "unique") (= op "zip") (= op "take") (= op "drop") (= op "chunk-every") (= op "zip-pairs") (= op "format") (= op "replace") (= op "split") (= op "join") (= op "index-of") (= op "dict") (= op "keys") (= op "vals") (= op "has-key?") (= op "contains?") (= op "starts-with?") (= op "ends-with?") (= op "string-contains?") (= op "string-length")) (str "(prim_call " (ml-quote-string op) " [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") (= op "inc") (str "(prim_call \"inc\" [" (ml-expr-inner (first args) set-vars) "])") (= op "dec") (str "(prim_call \"dec\" [" (ml-expr-inner (first args) set-vars) "])") :else (let ((callee (ml-mangle op))) (if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op)) (str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") (if (empty? args) (str "(" callee " ())") (str "(" callee " " (join " " (map (fn (x) (str "(" (ml-expr-inner x set-vars) ")")) args)) ")")))))))))) (define ml-emit-fn-bare (fn (expr (set-vars :as list)) (let ((params (nth expr 1)) (body (rest (rest expr))) (param-strs (ml-collect-params params)) (body-set-vars (ml-find-set-targets body)) (let-bound (ml-find-let-bound-names body))) (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) (all-set-vars (append set-vars body-set-vars)) (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) body-set-vars))) (if (empty? body-set-vars) (if (= (len body) 1) (str "(fun " params-str " -> " (ml-expr-inner (first body) all-set-vars) ")") (str "(fun " params-str " -> " (ml-emit-do body all-set-vars) ")")) (let ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) (body-str (if (= (len body) 1) (ml-expr-inner (first body) all-set-vars) (ml-emit-do body all-set-vars)))) (str "(fun " params-str " -> " ref-decls body-str ")"))))))) (define ml-emit-fn (fn (expr (set-vars :as list)) (let ((params (nth expr 1)) (param-strs (ml-collect-params params)) (n (len param-strs)) (bare (ml-emit-fn-bare expr set-vars))) (if (= n 0) (str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))") (let ((match-pat (str "[" (join "; " param-strs) "]")) (call-args (join " " param-strs))) (str "(NativeFn (\"\\206\\187\", fun _args -> match _args with " match-pat " -> " bare " " call-args " | _ -> Nil))")))))) (define ml-collect-params (fn ((params :as list)) (ml-collect-params-loop params 0 (list)))) (define ml-collect-params-loop (fn ((params :as list) (i :as number) (result :as list)) (if (>= i (len params)) result (let ((p (nth params i))) (cond (and (= (type-of p) "symbol") (= (symbol-name p) "&key")) (ml-collect-params-loop params (+ i 1) result) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (ml-collect-params-loop params (+ i 2) result) (and (= (type-of p) "list") (= (len p) 3) (= (type-of (nth p 1)) "keyword") (= (keyword-name (nth p 1)) "as")) (ml-collect-params-loop params (+ i 1) (append result (ml-mangle (symbol-name (first p))))) (= (type-of p) "symbol") (ml-collect-params-loop params (+ i 1) (append result (ml-mangle (symbol-name p)))) :else (ml-collect-params-loop params (+ i 1) (append result (str p)))))))) (define ml-emit-let (fn (expr (set-vars :as list)) (let ((bindings (nth expr 1)) (body (rest (rest expr)))) (let ((parsed (ml-parse-bindings-full bindings set-vars))) (let ((dyn-additions (reduce (fn (acc b) (let ((vname (first b)) (is-fn (nth b 2))) (if is-fn acc (append acc (str "dyn:" vname))))) (list) parsed))) (let ((body-set-vars (append set-vars dyn-additions))) (let ((binding-strs (map (fn (b) (let ((vname (first b)) (vval (nth b 1))) (if (some (fn (sv) (= sv vname)) set-vars) (str "let " vname " = ref (" vval ") in") (str "let " vname " = " vval " in")))) parsed)) (body-str (if (= (len body) 1) (ml-expr-inner (first body) body-set-vars) (ml-emit-do body body-set-vars)))) (str "(" (join " " binding-strs) " " body-str ")")))))))) (define ml-is-fn-expr? (fn (expr) (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol") (or (= (symbol-name (first expr)) "fn") (= (symbol-name (first expr)) "lambda"))))) (define ml-parse-bindings-full (fn (bindings (set-vars :as list)) (if (and (list? bindings) (not (empty? bindings))) (if (list? (first bindings)) (map (fn (b) (let ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) (list (ml-mangle vname) (ml-expr-inner (nth b 1) set-vars) (ml-is-fn-expr? (nth b 1))))) bindings) (ml-parse-clojure-bindings-full bindings 0 (list) set-vars)) (list)))) (define ml-parse-clojure-bindings-full (fn (bindings (i :as number) (result :as list) (set-vars :as list)) (if (>= i (- (len bindings) 1)) result (let ((vname (if (= (type-of (nth bindings i)) "symbol") (symbol-name (nth bindings i)) (str (nth bindings i)))) (val-expr (nth bindings (+ i 1)))) (ml-parse-clojure-bindings-full bindings (+ i 2) (append result (list (ml-mangle vname) (ml-expr-inner val-expr set-vars) (ml-is-fn-expr? val-expr))) set-vars))))) (define ml-parse-bindings (fn (bindings (set-vars :as list)) (if (and (list? bindings) (not (empty? bindings))) (if (list? (first bindings)) (map (fn (b) (let ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) (list (ml-mangle vname) (ml-expr-inner (nth b 1) set-vars)))) bindings) (ml-parse-clojure-bindings bindings 0 (list) set-vars)) (list)))) (define ml-parse-clojure-bindings (fn (bindings (i :as number) (result :as list) (set-vars :as list)) (if (>= i (- (len bindings) 1)) result (let ((vname (if (= (type-of (nth bindings i)) "symbol") (symbol-name (nth bindings i)) (str (nth bindings i))))) (ml-parse-clojure-bindings bindings (+ i 2) (append result (list (ml-mangle vname) (ml-expr-inner (nth bindings (+ i 1)) set-vars))) set-vars))))) (define ml-emit-when (fn (expr (set-vars :as list)) (let ((cond-e (ml-expr-inner (nth expr 1) set-vars)) (body-parts (rest (rest expr)))) (if (= (len body-parts) 1) (str "(if sx_truthy (" cond-e ") then " (ml-expr-inner (first body-parts) set-vars) " else Nil)") (str "(if sx_truthy (" cond-e ") then " (ml-emit-do body-parts set-vars) " else Nil)"))))) (define ml-emit-cond (fn ((clauses :as list) (set-vars :as list)) (if (empty? clauses) "Nil" (let ((is-scheme (and (every? (fn (c) (and (list? c) (= (len c) 2))) clauses) (not (some (fn (c) (= (type-of c) "keyword")) clauses))))) (if is-scheme (ml-cond-scheme clauses set-vars) (ml-cond-clojure clauses set-vars)))))) (define ml-is-else? (fn (test) (or (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else") (= (symbol-name test) "_"))) (and (= (type-of test) "keyword") (= (keyword-name test) "else"))))) (define ml-cond-scheme (fn ((clauses :as list) (set-vars :as list)) (if (empty? clauses) "Nil" (let ((clause (first clauses)) (test (first clause)) (body (nth clause 1))) (if (ml-is-else? test) (ml-expr-inner body set-vars) (str "(if sx_truthy (" (ml-expr-inner test set-vars) ") then " (ml-expr-inner body set-vars) " else " (ml-cond-scheme (rest clauses) set-vars) ")")))))) (define ml-cond-clojure (fn ((clauses :as list) (set-vars :as list)) (if (< (len clauses) 2) "Nil" (let ((test (first clauses)) (body (nth clauses 1))) (if (ml-is-else? test) (ml-expr-inner body set-vars) (str "(if sx_truthy (" (ml-expr-inner test set-vars) ") then " (ml-expr-inner body set-vars) " else " (ml-cond-clojure (rest (rest clauses)) set-vars) ")")))))) (define ml-emit-case (fn ((args :as list) (set-vars :as list)) (let ((match-expr (ml-expr-inner (first args) set-vars)) (clauses (rest args))) (str "(let _match_val = " match-expr " in " (ml-case-chain clauses set-vars) ")")))) (define ml-case-chain (fn ((clauses :as list) (set-vars :as list)) (if (empty? clauses) "Nil" (let ((clause (first clauses))) (if (list? clause) (let ((test (first clause)) (body (nth clause 1))) (if (ml-is-else? test) (ml-expr-inner body set-vars) (str "(if sx_truthy ((prim_call \"=\" [_match_val; " (ml-expr-inner test set-vars) "])) then " (ml-expr-inner body set-vars) " else " (ml-case-chain (rest clauses) set-vars) ")"))) (if (< (len clauses) 2) "Nil" (let ((test (first clauses)) (body (nth clauses 1))) (if (ml-is-else? test) (ml-expr-inner body set-vars) (str "(if _match_val = " (ml-expr-inner test set-vars) " then " (ml-expr-inner body set-vars) " else " (ml-case-chain (rest (rest clauses)) set-vars) ")"))))))))) (define ml-emit-and (fn ((args :as list) (set-vars :as list)) (if (= (len args) 1) (ml-expr-inner (first args) set-vars) (let ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) (ml-and-chain parts))))) (define ml-and-chain (fn ((parts :as list)) (if (= (len parts) 1) (first parts) (str "(let _and = " (first parts) " in if not (sx_truthy _and) then _and else " (ml-and-chain (rest parts)) ")")))) (define ml-emit-or (fn ((args :as list) (set-vars :as list)) (if (= (len args) 1) (ml-expr-inner (first args) set-vars) (let ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) (ml-or-chain parts))))) (define ml-or-chain (fn ((parts :as list)) (if (= (len parts) 1) (first parts) (str "(let _or = " (first parts) " in if sx_truthy _or then _or else " (ml-or-chain (rest parts)) ")")))) (define ml-emit-do (fn ((args :as list) (set-vars :as list)) (if (= (len args) 1) (ml-expr-inner (first args) set-vars) (ml-emit-do-chain args 0 set-vars)))) (define ml-is-define? (fn (expr) (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol") (= (symbol-name (first expr)) "define")))) (define ml-emit-do-chain (fn ((args :as list) (i :as number) (set-vars :as list)) (if (>= i (len args)) "Nil" (let ((expr (nth args i)) (is-last (= i (- (len args) 1)))) (if (ml-is-define? expr) (let ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) (val-expr (nth expr 2))) (let ((ml-name (ml-mangle name)) (is-fn (and (list? val-expr) (not (empty? val-expr)) (= (type-of (first val-expr)) "symbol") (or (= (symbol-name (first val-expr)) "fn") (= (symbol-name (first val-expr)) "lambda")))) (is-recursive (ml-is-self-recursive? name val-expr))) (let ((rec-kw (if is-recursive "rec " "")) (val-str (if (and is-fn is-recursive) (ml-emit-fn-bare val-expr set-vars) (ml-expr-inner val-expr set-vars))) (rest-str (ml-emit-do-chain args (+ i 1) set-vars))) (str "(let " rec-kw ml-name " = " val-str " in " rest-str ")")))) (if is-last (ml-expr-inner expr set-vars) (str "(let () = ignore (" (ml-expr-inner expr set-vars) ") in " (ml-emit-do-chain args (+ i 1) set-vars) ")"))))))) (define ml-is-inline-fn? (fn (expr) (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol") (or (= (symbol-name (first expr)) "fn") (= (symbol-name (first expr)) "lambda"))))) (define ml-emit-ho-form (fn ((ocaml-fn :as string) (wrap-pre :as string) (wrap-post :as string) (result-wrap :as string) (args :as list) (set-vars :as list)) (let ((fn-arg (first args)) (coll-arg (nth args 1)) (needs-bool (or (= ocaml-fn "List.filter") (= ocaml-fn "List.exists") (= ocaml-fn "List.for_all")))) (if (ml-is-inline-fn? fn-arg) (let ((params (nth fn-arg 1)) (body (rest (rest fn-arg))) (param-strs (ml-collect-params params))) (let ((param-str (if (empty? param-strs) "_" (first param-strs))) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-vars) (ml-emit-do body set-vars)))) (let ((wrapped-body (if needs-bool (str "sx_truthy (" body-str ")") body-str))) (str "(" result-wrap " (" ocaml-fn " (fun " param-str " -> " wrapped-body ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))) (let ((fn-str (ml-expr-inner fn-arg set-vars))) (if needs-bool (str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (cek_call " fn-str " (List [_x])))" " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))") (str "(" result-wrap " (" ocaml-fn " (fun _x -> cek_call " fn-str " (List [_x]))" " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))))) (define ml-emit-ho-indexed (fn ((args :as list) (set-vars :as list)) (let ((fn-arg (first args)) (coll-arg (nth args 1))) (if (ml-is-inline-fn? fn-arg) (let ((params (nth fn-arg 1)) (body (rest (rest fn-arg))) (param-strs (ml-collect-params params))) (let ((i-param (if (>= (len param-strs) 1) (first param-strs) "_i")) (v-param (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-vars) (ml-emit-do body set-vars)))) (str "(List (List.mapi (fun " i-param " " v-param " -> let " i-param " = Number (float_of_int " i-param ") in " body-str ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))) (str "(List (List.mapi (fun _i _x -> cek_call " (ml-expr-inner fn-arg set-vars) " (List [Number (float_of_int _i); _x])) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))) (define ml-emit-reduce (fn ((args :as list) (set-vars :as list)) (let ((fn-arg (first args)) (init-arg (nth args 1)) (coll-arg (nth args 2))) (if (ml-is-inline-fn? fn-arg) (let ((params (nth fn-arg 1)) (body (rest (rest fn-arg))) (param-strs (ml-collect-params params))) (let ((raw-acc (if (>= (len param-strs) 1) (first param-strs) "_acc")) (x-param (if (>= (len param-strs) 2) (nth param-strs 1) "_x")) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-vars) (ml-emit-do body set-vars))) (acc-param (if (string-contains? body-str raw-acc) raw-acc (if (starts-with? raw-acc "_") raw-acc (str "_" raw-acc))))) (str "(List.fold_left (fun " acc-param " " x-param " -> " body-str ") " (ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))) (str "(List.fold_left (fun _acc _x -> cek_call " (ml-expr-inner fn-arg set-vars) " (List [_acc; _x])) " (ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))))) (define ml-emit-for-each (fn ((args :as list) (set-vars :as list)) (let ((fn-arg (first args)) (coll-arg (nth args 1))) (if (ml-is-inline-fn? fn-arg) (let ((params (nth fn-arg 1)) (body (rest (rest fn-arg))) (param-strs (ml-collect-params params))) (let ((param-str (if (empty? param-strs) "_" (first param-strs))) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-vars) (ml-emit-do body set-vars)))) (str "(List.iter (fun " param-str " -> ignore (" body-str ")) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))) (str "(List.iter (fun _x -> ignore (cek_call " (ml-expr-inner fn-arg set-vars) " (List [_x]))) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))))) (define ml-emit-map-dict (fn ((args :as list) (set-vars :as list)) (let ((fn-arg (first args)) (dict-arg (nth args 1))) (if (ml-is-inline-fn? fn-arg) (let ((params (nth fn-arg 1)) (body (rest (rest fn-arg))) (param-strs (ml-collect-params params))) (let ((k-param (if (>= (len param-strs) 1) (first param-strs) "_k")) (v-param (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-vars) (ml-emit-do body set-vars)))) (str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> " "let _r = Hashtbl.create (Hashtbl.length _tbl) in " "Hashtbl.iter (fun " k-param " " v-param " -> " "let " k-param " = String " k-param " in " "Hashtbl.replace _r (value_to_str " k-param ") (" body-str ")) _tbl; " "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))) (let ((fn-str (ml-expr-inner fn-arg set-vars))) (str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> " "let _r = Hashtbl.create (Hashtbl.length _tbl) in " "Hashtbl.iter (fun _k _v -> " "Hashtbl.replace _r _k (cek_call " fn-str " (List [String _k; _v]))) _tbl; " "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))")))))) (define ml-emit-dict-call (fn ((pairs :as list) (set-vars :as list)) (let ((n (len pairs))) (if (= n 0) "(Dict (Hashtbl.create 0))" (str "(let _d = Hashtbl.create " (str (round (/ n 2))) " in " (ml-dict-pairs pairs 0 set-vars) " Dict _d)"))))) (define ml-dict-pairs (fn ((pairs :as list) (i :as number) (set-vars :as list)) (if (>= i (- (len pairs) 1)) "" (let ((key (nth pairs i)) (val (nth pairs (+ i 1)))) (let ((key-str (if (= (type-of key) "keyword") (ml-quote-string (keyword-name key)) (str "(value_to_str " (ml-expr-inner key set-vars) ")"))) (val-str (ml-expr-inner val set-vars))) (str "Hashtbl.replace _d " key-str " " val-str "; " (ml-dict-pairs pairs (+ i 2) set-vars))))))) (define ml-emit-quote (fn (expr) (cond (= (type-of expr) "boolean") (if expr "(Bool true)" "(Bool false)") (number? expr) (str "(Number " (str expr) ")") (string? expr) (str "(String " (ml-quote-string expr) ")") (nil? expr) "Nil" (= (type-of expr) "symbol") (str "(Symbol " (ml-quote-string (symbol-name expr)) ")") (= (type-of expr) "keyword") (str "(Keyword " (ml-quote-string (keyword-name expr)) ")") (list? expr) (str "(List [" (join "; " (map ml-emit-quote expr)) "])") :else (str "(* quote fallback *) " (str expr))))) (define ml-emit-define (fn (expr) (let ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) (val-expr (nth expr 2))) (let ((ml-name (ml-mangle name)) (is-fn (and (list? val-expr) (not (empty? val-expr)) (= (type-of (first val-expr)) "symbol") (or (= (symbol-name (first val-expr)) "fn") (= (symbol-name (first val-expr)) "lambda")))) (is-recursive (ml-is-self-recursive? name val-expr))) (let ((rec-kw (if is-recursive "rec " ""))) (if is-fn (let ((params (nth val-expr 1)) (body (rest (rest val-expr))) (param-strs (ml-collect-params params)) (set-targets (ml-find-set-targets body)) (let-bound (ml-find-let-bound-names body))) (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) (all-set-vars set-targets) (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) set-targets))) (if (empty? set-targets) (if (= (len body) 1) (str "let " rec-kw ml-name " " params-str " =\n " (ml-expr-inner (first body) all-set-vars) "\n") (str "let " rec-kw ml-name " " params-str " =\n " (ml-emit-do body all-set-vars) "\n")) (let ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) (body-str (if (= (len body) 1) (ml-expr-inner (first body) all-set-vars) (ml-emit-do body all-set-vars)))) (str "let " rec-kw ml-name " " params-str " =\n " ref-decls body-str "\n"))))) (if (ml-is-mutable-global? name) (str "let " ml-name " =\n !" ml-name "ref\n") (str "let " ml-name " =\n " (ml-expr val-expr) "\n")))))))) (define ml-translate-file (fn ((defines :as list)) (let ((parts (map (fn (pair) (let ((name (first pair)) (expr (nth pair 1))) (str "(* " name " *)\n" (ml-emit-define-body expr)))) defines))) (if (empty? parts) "" (str (first parts) "\n" (join "\n" (map (fn (p) (let ((nl-idx (index-of p "\n"))) (if (and (number? nl-idx) (>= nl-idx 0)) (let ((before (slice p 0 (+ nl-idx 1))) (after (slice p (+ nl-idx 1)))) (if (starts-with? after "let rec ") (str before "and " (slice after 8)) p)) (if (starts-with? p "let rec ") (str "and " (slice p 8)) p)))) (rest parts)))))))) (define ml-emit-define-body (fn (expr) (let ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) (val-expr (nth expr 2))) (let ((ml-name (ml-mangle name)) (is-fn (and (list? val-expr) (not (empty? val-expr)) (= (type-of (first val-expr)) "symbol") (or (= (symbol-name (first val-expr)) "fn") (= (symbol-name (first val-expr)) "lambda"))))) (if is-fn (let ((params (nth val-expr 1)) (body (rest (rest val-expr))) (param-strs (ml-collect-params params)) (set-targets (ml-find-set-targets body)) (let-bound (ml-find-let-bound-names body))) (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) set-targets))) (if (empty? set-targets) (if (= (len body) 1) (str "let rec " ml-name " " params-str " =\n " (ml-expr-inner (first body) set-targets) "\n") (str "let rec " ml-name " " params-str " =\n " (ml-emit-do body set-targets) "\n")) (let ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) (body-str (if (= (len body) 1) (ml-expr-inner (first body) set-targets) (ml-emit-do body set-targets)))) (str "let rec " ml-name " " params-str " =\n " ref-decls body-str "\n"))))) (if (ml-is-mutable-global? name) (str "let rec " ml-name " =\n !" ml-name "ref\n") (str "let rec " ml-name " =\n " (ml-expr val-expr) "\n")))))))