giles
1d68f20a37
Native functions (NativeFn/VmClosure) called through the CEK evaluator
can now have their Eval_errors caught by guard/handler-bind. The fix is
at the exact OCaml↔CEK boundary in continue-with-call:
- sx_runtime.ml: sx_apply_cek wraps native calls, returns error marker
dict {__eval_error__: true, message: "..."} instead of raising
- sx_runtime.ml: is_eval_error predicate checks for the marker
- spec/evaluator.sx: continue-with-call callable branch uses apply-cek,
detects error markers, converts to raise-eval CEK state
- transpiler.sx: apply-cek and eval-error? emit cases added
No mutable flags, no re-entry risk. Errors flow through the CEK handler
chain naturally. 2798/2800 tests pass.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1993 lines
59 KiB
Plaintext
1993 lines
59 KiB
Plaintext
(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"
|
|
"cek-step-loop"
|
|
"cek-resume"
|
|
"cek-suspended?"
|
|
"cek-io-request"
|
|
"make-cek-suspended"
|
|
"library-name-key"
|
|
"library-loaded?"
|
|
"library-exports"
|
|
"register-library"
|
|
"sx-call"
|
|
"sx-apply"
|
|
"apply-cek"
|
|
"eval-error?"
|
|
"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"
|
|
"eval-expr"
|
|
"expand-macro"
|
|
"try-catch"
|
|
"set-render-active!"
|
|
"scope-emitted"
|
|
"jit-try-call"))
|
|
|
|
(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*"
|
|
"*last-error-kont*"
|
|
"*bind-tracking*"
|
|
"*provide-batch-depth*"
|
|
"*provide-batch-queue*"
|
|
"*provide-subscribers*"))
|
|
|
|
(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 (symbol-name (nth node 1))))
|
|
(let
|
|
((mangled (ml-mangle var-name)))
|
|
(when
|
|
(and
|
|
(not (ml-is-mutable-global? var-name))
|
|
(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
|
|
(and
|
|
(not (ml-is-mutable-global? var-name))
|
|
(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")
|
|
(some (fn (k) (= k "subscribers")) items)
|
|
(ef "subscribers")
|
|
: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")
|
|
(some (fn (k) (= k "prev-tracking")) items)
|
|
(ef "prev-tracking")
|
|
(some (fn (k) (= k "extra")) items)
|
|
(ef "extra")
|
|
: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")
|
|
" })"))
|
|
(if
|
|
(and
|
|
(some (fn (k) (= k "ip")) items)
|
|
(some (fn (k) (= k "closure")) items)
|
|
(some (fn (k) (= k "base")) items))
|
|
(str
|
|
"(VmFrame { vf_closure = (match "
|
|
(ml-expr-inner (get d "closure") set-vars)
|
|
" with VmClosure c -> c | _ -> failwith \"vf_closure\")"
|
|
"; vf_ip = val_to_int "
|
|
(ml-expr-inner (get d "ip") set-vars)
|
|
"; vf_base = val_to_int "
|
|
(ml-expr-inner (get d "base") set-vars)
|
|
"; vf_local_cells = Hashtbl.create 4 })")
|
|
(if
|
|
(and
|
|
(some (fn (k) (= k "sp")) items)
|
|
(some (fn (k) (= k "stack")) items)
|
|
(some (fn (k) (= k "globals")) items))
|
|
(str
|
|
"(VmMachine { vm_stack = (match "
|
|
(ml-expr-inner (get d "stack") set-vars)
|
|
" with List _ -> Array.make 4096 Nil | _ -> Array.make 4096 Nil)"
|
|
"; vm_sp = val_to_int "
|
|
(ml-expr-inner (get d "sp") set-vars)
|
|
"; vm_frames = []"
|
|
"; vm_globals = (match "
|
|
(ml-expr-inner (get d "globals") set-vars)
|
|
" with Dict d -> d | _ -> Hashtbl.create 0)"
|
|
"; vm_pending_cek = None })")
|
|
(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 "apply-cek")
|
|
(str
|
|
"(sx_apply_cek "
|
|
(ml-expr-inner (first args) set-vars)
|
|
" "
|
|
(ml-expr-inner (nth args 1) set-vars)
|
|
")")
|
|
(= op "eval-error?")
|
|
(str
|
|
"(Bool (is_eval_error "
|
|
(ml-expr-inner (first args) 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 (symbol-name (nth expr 1)))
|
|
(item-expr (ml-expr-inner (nth args 1) set-vars)))
|
|
(if
|
|
(ml-is-mutable-global? target)
|
|
(let
|
|
((mangled (ml-mangle target)))
|
|
(str
|
|
"("
|
|
mangled
|
|
"ref := sx_append_b !"
|
|
mangled
|
|
"ref "
|
|
item-expr
|
|
"; Nil)"))
|
|
(if
|
|
(and
|
|
(= (type-of (nth expr 1)) "symbol")
|
|
(some (fn (v) (= v (ml-mangle target))) set-vars))
|
|
(let
|
|
((mangled (ml-mangle target)))
|
|
(str
|
|
"("
|
|
mangled
|
|
" := sx_append_b !"
|
|
mangled
|
|
" "
|
|
item-expr
|
|
"; Nil)"))
|
|
(str
|
|
"(sx_append_b "
|
|
(ml-expr-inner (nth expr 1) 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
|
|
(let ((raw (nth expr 2))) (if (keyword? raw) (last expr) raw))))
|
|
(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
|
|
"ref = ref "
|
|
(ml-expr val-expr)
|
|
"\nand "
|
|
ml-name
|
|
" =\n "
|
|
(ml-expr val-expr)
|
|
"\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))
|
|
(after (slice p (+ nl-idx 1))))
|
|
(cond
|
|
(starts-with? after "let rec ")
|
|
(str before "\nand " (slice after 8))
|
|
(starts-with? after "let ")
|
|
(str before "\nand " (slice after 4))
|
|
:else p))
|
|
(cond
|
|
(starts-with? p "let rec ")
|
|
(str "and " (slice p 8))
|
|
(starts-with? p "let ")
|
|
(str "and " (slice p 4))
|
|
:else 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
|
|
(let ((raw (nth expr 2))) (if (keyword? raw) (last expr) raw))))
|
|
(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
|
|
"ref = ref "
|
|
(ml-expr val-expr)
|
|
"\nand "
|
|
ml-name
|
|
" =\n "
|
|
(ml-expr val-expr)
|
|
"\n")
|
|
(str "let rec " ml-name " =\n " (ml-expr val-expr) "\n")))))))
|