giles
efb2d92b99
SX lambdas ((fn (x) body)) now transpile to NativeFn values that can
be stored as SX values — passed to signal-add-sub!, stored in dicts,
used as reactive subscribers. Previously emitted as bare OCaml closures
which couldn't be stored in the SX value type system.
ml-emit-fn → NativeFn("λ", fun args -> match args with [...] -> body)
ml-emit-fn-bare → (fun params -> body) — used by HO inliners and
recursive let bindings (let rec) which call themselves directly.
HO forms (map, filter, reduce, for-each, map-indexed, map-dict) use
cek_call for non-inline function arguments, bare OCaml lambdas for
inline (fn ...) arguments.
Runtime: with_island_scope accepts NativeFn values (pattern match on
value type) since transpiled lambdas are now NativeFn-wrapped.
Unblocks WASM reactive signals — the bootstrap FIXUPS that manually
wrapped reactive_shift_deref's subscriber as NativeFn are no longer
needed when merging to the wasm branch.
1314/1314 JS tests, 4/4 Playwright isomorphic tests.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1325 lines
57 KiB
Plaintext
1325 lines
57 KiB
Plaintext
;; ==========================================================================
|
|
;; ml.sx — SX-to-OCaml translator, written in SX
|
|
;;
|
|
;; Translates (define ...) forms from .sx spec files into OCaml source.
|
|
;; The Python evaluator executes this file against the spec to produce
|
|
;; sx_ref.ml — the transpiled evaluator as native OCaml.
|
|
;;
|
|
;; Usage (from SX):
|
|
;; (ml-expr expr) — translate one expression to OCaml
|
|
;; (ml-statement expr) — translate to OCaml top-level statement
|
|
;; (ml-translate-file defines) — translate a list of (name . define-expr) pairs
|
|
;; ==========================================================================
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; OCaml reserved words — names that get _ suffix
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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"))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; RENAMES table — explicit SX name → OCaml name mappings
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-renames {
|
|
:nil "Nil"
|
|
:true "(Bool true)"
|
|
:false "(Bool false)"
|
|
"nil?" "is_nil"
|
|
"type-of" "type_of"
|
|
"symbol-name" "symbol_name"
|
|
"keyword-name" "keyword_name"
|
|
"make-lambda" "make_lambda"
|
|
"make-component" "make_component"
|
|
"make-macro" "make_macro"
|
|
"make-thunk" "make_thunk"
|
|
"make-symbol" "make_symbol"
|
|
"make-keyword" "make_keyword"
|
|
"lambda-params" "lambda_params"
|
|
"lambda-body" "lambda_body"
|
|
"lambda-closure" "lambda_closure"
|
|
"lambda-name" "lambda_name"
|
|
"set-lambda-name!" "set_lambda_name"
|
|
"component-params" "component_params"
|
|
"component-body" "component_body"
|
|
"component-closure" "component_closure"
|
|
"component-has-children?" "component_has_children"
|
|
"component-name" "component_name"
|
|
"component-affinity" "component_affinity"
|
|
"macro-params" "macro_params"
|
|
"macro-rest-param" "macro_rest_param"
|
|
"macro-body" "macro_body"
|
|
"macro-closure" "macro_closure"
|
|
"thunk?" "is_thunk"
|
|
"thunk-expr" "thunk_expr"
|
|
"thunk-env" "thunk_env"
|
|
"callable?" "is_callable"
|
|
"lambda?" "is_lambda"
|
|
"component?" "is_component"
|
|
"island?" "is_island"
|
|
"make-island" "make_island"
|
|
"macro?" "is_macro"
|
|
"signal?" "is_signal"
|
|
"identical?" "is_identical"
|
|
"primitive?" "is_primitive"
|
|
"get-primitive" "get_primitive"
|
|
"env-has?" "env_has"
|
|
"env-get" "env_get"
|
|
"env-bind!" "env_bind"
|
|
"env-set!" "env_set"
|
|
"env-extend" "env_extend"
|
|
"env-merge" "env_merge"
|
|
"dict-set!" "dict_set"
|
|
"dict-get" "dict_get"
|
|
"dict-has?" "dict_has"
|
|
"dict-delete!" "dict_delete"
|
|
"eval-expr" "eval_expr"
|
|
"call-lambda" "call_lambda"
|
|
"expand-macro" "expand_macro"
|
|
"render-to-html" "render_to_html"
|
|
"escape-html" "escape_html"
|
|
"escape-attr" "escape_attr"
|
|
"escape-string" "escape_string"
|
|
"raw-html-content" "raw_html_content"
|
|
"make-raw-html" "make_raw_html"
|
|
"make-spread" "make_spread"
|
|
"spread?" "is_spread"
|
|
"spread-attrs" "spread_attrs"
|
|
"contains?" "contains_p"
|
|
"starts-with?" "starts_with_p"
|
|
"ends-with?" "ends_with_p"
|
|
"empty?" "empty_p"
|
|
"every?" "every_p"
|
|
"for-each" "for_each"
|
|
"for-each-indexed" "for_each_indexed"
|
|
"map-indexed" "map_indexed"
|
|
"map-dict" "map_dict"
|
|
"string-length" "string_length"
|
|
"string-contains?" "string_contains_p"
|
|
"has-key?" "has_key_p"
|
|
"index-of" "index_of"
|
|
"char-from-code" "char_from_code"
|
|
"parse-int" "parse_int"
|
|
"parse-float" "parse_float"
|
|
"collect!" "sx_collect"
|
|
"collected" "sx_collected"
|
|
"clear-collected!" "sx_clear_collected"
|
|
"context" "sx_context"
|
|
"emit!" "sx_emit"
|
|
"emitted" "sx_emitted"
|
|
"scope-push!" "scope_push"
|
|
"scope-pop!" "scope_pop"
|
|
"scope-peek" "scope_peek"
|
|
"scope-emit!" "scope_emit"
|
|
"provide-push!" "provide_push"
|
|
"provide-pop!" "provide_pop"
|
|
"sx-serialize" "sx_serialize"
|
|
"*custom-special-forms*" "custom_special_forms"
|
|
"register-special-form!" "register_special_form"
|
|
"*render-check*" "render_check"
|
|
"*render-fn*" "render_fn"
|
|
"is-else-clause?" "is_else_clause"
|
|
"HTML_TAGS" "html_tags"
|
|
"VOID_ELEMENTS" "void_elements"
|
|
"BOOLEAN_ATTRS" "boolean_attrs"
|
|
})
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Name mangling: SX identifier → valid OCaml identifier
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-mangle
|
|
(fn ((name :as string))
|
|
(let ((renamed (get ml-renames name)))
|
|
(if (not (nil? renamed))
|
|
renamed
|
|
;; General mangling rules
|
|
(let ((result name))
|
|
;; Handle trailing ? and !
|
|
(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)))
|
|
;; Kebab to snake_case
|
|
(let ((result (replace result "-" "_")))
|
|
;; Handle * wrappers (like *strict*)
|
|
(let ((result (replace result "*" "_")))
|
|
;; Escape OCaml reserved words
|
|
(if (some (fn (r) (= r result)) ml-reserved)
|
|
(str result "'")
|
|
result)))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Known name detection — distinguishes static OCaml calls from dynamic SX calls.
|
|
;; Names in ml-renames, _known_defines, or ml-runtime-names get direct calls.
|
|
;; Unknown names (local variables) use cek_call for dynamic dispatch.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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" "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"
|
|
"dynamic-wind-call" "strip-prefix"
|
|
"component-set-param-types!" "parse-comp-params" "parse-macro-params"
|
|
"parse-keyword-args"))
|
|
|
|
(define ml-is-known-name?
|
|
(fn ((name :as string))
|
|
;; Check renames table
|
|
(if (not (nil? (get ml-renames name)))
|
|
true
|
|
;; Check runtime names
|
|
(if (some (fn (r) (= r name)) ml-runtime-names)
|
|
true
|
|
;; Check _known_defines (set by bootstrap.py)
|
|
(some (fn (d) (= d name)) _known_defines)))))
|
|
|
|
;; Dynamic globals — top-level defines that hold SX values (not functions).
|
|
;; When these appear as callees, use cek_call for dynamic dispatch.
|
|
(define ml-dynamic-globals
|
|
(list "*render-check*" "*render-fn*"))
|
|
|
|
(define ml-is-dyn-global?
|
|
(fn ((name :as string))
|
|
(some (fn (g) (= g name)) ml-dynamic-globals)))
|
|
|
|
;; Check if a variable is "dynamic" — locally bound to a non-function expression.
|
|
;; These variables hold SX values (from eval-expr, get, etc.) and need cek_call
|
|
;; when used as callees. We encode this in the set-vars list as "dyn:name".
|
|
(define ml-is-dyn-var?
|
|
(fn ((name :as string) (set-vars :as list))
|
|
(some (fn (v) (= v (str "dyn:" name))) set-vars)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; String quoting for OCaml
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-quote-string
|
|
(fn ((s :as string))
|
|
(str "\"" (replace (replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\t" "\\t") "\"")))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Detect self-recursion in a define body
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; let-bound name detection — find variables bound by let in the body
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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
|
|
;; Extract bound names from let bindings
|
|
(if (and (not (empty? bindings)) (list? (first bindings)))
|
|
;; Scheme-style: ((name val) ...)
|
|
(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)
|
|
;; Clojure-style: (name val name val ...)
|
|
(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)))
|
|
;; Also scan body of let for more let-bound names
|
|
(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))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; set! target detection — find variables that need ref
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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
|
|
;; set! targets
|
|
(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))))
|
|
;; append! targets — need ref wrapping just like set!
|
|
(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))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Expression translator: SX AST → OCaml expression string
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-expr
|
|
(fn (expr)
|
|
(ml-expr-inner expr (list))))
|
|
|
|
(define ml-expr-inner
|
|
(fn (expr (set-vars :as list))
|
|
(cond
|
|
;; Bool
|
|
(= (type-of expr) "boolean")
|
|
(if expr "(Bool true)" "(Bool false)")
|
|
|
|
;; Nil
|
|
(nil? expr) "Nil"
|
|
|
|
;; Numbers — ensure float suffix for OCaml
|
|
(number? expr)
|
|
(if (string-contains? (str expr) ".")
|
|
(str "(Number " (str expr) ")")
|
|
(str "(Number " (str expr) ".0)"))
|
|
|
|
;; Strings
|
|
(string? expr)
|
|
(str "(String " (ml-quote-string expr) ")")
|
|
|
|
;; Symbols
|
|
(= (type-of expr) "symbol")
|
|
(let ((mangled (ml-mangle (symbol-name expr))))
|
|
(if (some (fn (c) (= c mangled)) set-vars)
|
|
(str "!" mangled)
|
|
mangled))
|
|
|
|
;; Keywords → string value
|
|
(= (type-of expr) "keyword")
|
|
(str "(String " (ml-quote-string (keyword-name expr)) ")")
|
|
|
|
;; Dicts
|
|
(= (type-of expr) "dict")
|
|
(ml-emit-dict-native expr set-vars)
|
|
|
|
;; Lists
|
|
(list? expr)
|
|
(if (empty? expr)
|
|
"[]"
|
|
(ml-emit-list expr set-vars))
|
|
|
|
;; Fallback
|
|
:else (str "(* ??? *) " (str expr)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Dict emission
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-emit-dict-native
|
|
(fn ((d :as dict) (set-vars :as list))
|
|
(let ((items (keys d)))
|
|
;; Optimize CEK state dicts — emit CekState record instead of Hashtbl.
|
|
;; Detected by having exactly {control, env, kont, phase, value} keys.
|
|
(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)
|
|
" })")
|
|
;; Optimize CEK frame dicts — detected by having a "type" string field.
|
|
;; Maps frame fields to generic CekFrame record slots.
|
|
(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")
|
|
" })"))
|
|
;; Regular dict — Hashtbl
|
|
(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)"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; List/call emission — the main dispatch
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-emit-list
|
|
(fn (expr (set-vars :as list))
|
|
(let ((head (first expr))
|
|
(args (rest expr)))
|
|
(if (not (= (type-of head) "symbol"))
|
|
;; Non-symbol head: if head is a list (call expr), dispatch via cek_call;
|
|
;; otherwise treat as data list
|
|
(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
|
|
;; fn/lambda
|
|
(or (= op "fn") (= op "lambda"))
|
|
(ml-emit-fn expr set-vars)
|
|
|
|
;; let/let*
|
|
(or (= op "let") (= op "let*"))
|
|
(ml-emit-let expr set-vars)
|
|
|
|
;; if
|
|
(= 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 ")"))
|
|
|
|
;; when
|
|
(= op "when")
|
|
(ml-emit-when expr set-vars)
|
|
|
|
;; cond
|
|
(= op "cond")
|
|
(ml-emit-cond args set-vars)
|
|
|
|
;; case
|
|
(= op "case")
|
|
(ml-emit-case args set-vars)
|
|
|
|
;; and
|
|
(= op "and")
|
|
(ml-emit-and args set-vars)
|
|
|
|
;; or
|
|
(= op "or")
|
|
(ml-emit-or args set-vars)
|
|
|
|
;; not
|
|
(= op "not")
|
|
(str "(Bool (not (sx_truthy (" (ml-expr-inner (first args) set-vars) "))))")
|
|
|
|
;; do/begin
|
|
(or (= op "do") (= op "begin"))
|
|
(ml-emit-do args set-vars)
|
|
|
|
;; list literal
|
|
(= op "list")
|
|
(str "(List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])")
|
|
|
|
;; dict literal
|
|
(= op "dict")
|
|
(ml-emit-dict-call args set-vars)
|
|
|
|
;; quote
|
|
(= op "quote")
|
|
(ml-emit-quote (first args))
|
|
|
|
;; set!
|
|
(= op "set!")
|
|
(let ((var-name (if (= (type-of (first args)) "symbol")
|
|
(symbol-name (first args))
|
|
(str (first args)))))
|
|
(let ((mangled (ml-mangle var-name)))
|
|
(str "(" mangled " := " (ml-expr-inner (nth args 1) set-vars) "; Nil)")))
|
|
|
|
;; str — concatenate
|
|
(= op "str")
|
|
(str "(String (sx_str [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
|
|
|
;; error
|
|
(= op "error")
|
|
(str "(raise (Eval_error (value_to_str " (ml-expr-inner (first args) set-vars) ")))")
|
|
|
|
;; Infix arithmetic — emit as primitive calls
|
|
(= 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)) "])")
|
|
|
|
;; Comparison — emit as primitive calls
|
|
(= 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)) "])")
|
|
|
|
;; apply
|
|
(= op "apply")
|
|
(str "(sx_apply " (ml-expr-inner (first args) set-vars)
|
|
" " (ml-expr-inner (nth args 1) set-vars) ")")
|
|
|
|
;; for-each
|
|
(= op "for-each")
|
|
(ml-emit-for-each args set-vars)
|
|
|
|
;; map, filter, reduce, some, every?
|
|
(= 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)
|
|
|
|
;; map-dict — inline lambda optimization
|
|
(= op "map-dict")
|
|
(ml-emit-map-dict args set-vars)
|
|
|
|
;; Mutation forms
|
|
(= 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))
|
|
;; Target is a ref variable — emit ref mutation
|
|
(let ((mangled (ml-mangle (symbol-name target))))
|
|
(str "(" mangled " := sx_append_b !" mangled " " item-expr "; Nil)"))
|
|
;; Not a ref — fallback (returns new list)
|
|
(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) "))")
|
|
|
|
;; Variadic primitives — always use prim_call
|
|
(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)) "])")
|
|
|
|
;; inc/dec inlined
|
|
(= 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) "])")
|
|
|
|
;; Regular function call
|
|
:else
|
|
(let ((callee (ml-mangle op)))
|
|
(if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op))
|
|
;; Dynamic callee (local var or dynamic global) — dispatch via cek_call
|
|
(str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
|
;; Static callee — direct OCaml call
|
|
(if (empty? args)
|
|
(str "(" callee " ())")
|
|
(str "(" callee " " (join " " (map (fn (x) (str "(" (ml-expr-inner x set-vars) ")")) args)) ")"))))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; fn/lambda
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; ml-emit-fn-bare: emit a plain OCaml function (fun params -> body).
|
|
;; Used by HO form inlining where a bare OCaml closure is needed.
|
|
(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))
|
|
;; Only pre-declare refs for set! targets NOT rebound by let
|
|
(needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) body-set-vars)))
|
|
(if (empty? body-set-vars)
|
|
;; No set! targets — simple function
|
|
(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) ")"))
|
|
;; Has set! targets — emit ref bindings only for non-let-bound 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 ")")))))))
|
|
|
|
;; ml-emit-fn: emit an SX-compatible NativeFn value.
|
|
;; Wraps the OCaml closure so it can be stored as a value, passed to
|
|
;; signal-add-sub!, etc. The args pattern-match unpacks the value list.
|
|
(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)
|
|
;; Zero-arg: NativeFn("λ", fun _args -> body)
|
|
(str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))")
|
|
;; N-arg: NativeFn("λ", fun args -> match args with [a;b;...] -> body | _ -> Nil)
|
|
(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
|
|
;; &key — skip (components handle this differently)
|
|
(and (= (type-of p) "symbol") (= (symbol-name p) "&key"))
|
|
(ml-collect-params-loop params (+ i 1) result)
|
|
;; &rest
|
|
(and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
|
|
(ml-collect-params-loop params (+ i 2) result)
|
|
;; Annotated: (name :as type)
|
|
(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)))))
|
|
;; Simple symbol
|
|
(= (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))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; let → OCaml let ... in ...
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)))
|
|
;; Track dynamic vars: let-bound vars whose init is NOT a fn/lambda
|
|
(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 ")"))))))))
|
|
|
|
;; ml-parse-bindings-full returns (name ocaml-expr is-fn?) triples
|
|
(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))
|
|
;; Scheme-style: ((name val) ...)
|
|
(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)
|
|
;; Clojure-style: (name val name val ...)
|
|
(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))
|
|
;; Scheme-style: ((name val) ...)
|
|
(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)
|
|
;; Clojure-style: (name val name val ...)
|
|
(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)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; when
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)")))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; cond → chained if/then/else
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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")))
|
|
(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) ")"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; case → match ... with
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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 (< (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) ")"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; and/or → short-circuit
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)) ")"))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; do/begin → sequencing
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ml-emit-do
|
|
(fn ((args :as list) (set-vars :as list))
|
|
(if (= (len args) 1)
|
|
(ml-expr-inner (first args) set-vars)
|
|
;; Check for defines in the block — emit as let...in chain
|
|
(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)
|
|
;; define inside do — emit as let...in
|
|
(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 " ""))
|
|
;; Recursive fns must be bare OCaml functions (called directly)
|
|
(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 ")"))))
|
|
;; Non-define expression
|
|
(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) ")")))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Higher-order form helpers — detect inline lambdas for direct OCaml calls
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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))
|
|
;; Detect if the OCaml HOF needs bool (filter, exists, for_all)
|
|
(needs-bool (or (= ocaml-fn "List.filter")
|
|
(= ocaml-fn "List.exists")
|
|
(= ocaml-fn "List.for_all"))))
|
|
(if (ml-is-inline-fn? fn-arg)
|
|
;; Inline lambda — call directly, no sx_call
|
|
(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) ")))"))))
|
|
;; Named function — dispatch via cek_call (fn may be NativeFn value)
|
|
(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)))
|
|
;; Prefix acc with _ if unused in body to avoid OCaml warning
|
|
(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) "))")))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; for-each
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)")))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; map-dict
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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\"))"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; dict call
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; quote → OCaml AST literals
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Top-level define
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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
|
|
;; Function define — emit as let [rec] name params = body
|
|
(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"))
|
|
;; Has set! targets — only pre-declare refs for non-let-bound
|
|
(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")))))
|
|
;; Non-function define
|
|
(str "let " ml-name " =\n " (ml-expr val-expr) "\n")))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; File translation: process a list of (name, define-expr) pairs
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; ml-translate-file emits all defines as a single let rec ... and ... block.
|
|
;; This handles forward references between evaluator functions — OCaml's
|
|
;; let rec allows mutual recursion between all and-joined definitions.
|
|
(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)))
|
|
;; Join with "and" — first one uses "let rec", rest use "and"
|
|
;; Each part is "(* name *)\nlet rec name ..." — replace the "let rec" on second line
|
|
(if (empty? parts)
|
|
""
|
|
(str (first parts) "\n" (join "\n" (map (fn (p)
|
|
;; Find first newline, then replace "let rec " after it
|
|
(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))
|
|
;; No newline — try direct replacement
|
|
(if (starts-with? p "let rec ")
|
|
(str "and " (slice p 8))
|
|
p))))
|
|
(rest parts))))))))
|
|
|
|
;; ml-emit-define-body — like ml-emit-define but always emits as let [rec]
|
|
(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
|
|
;; Function define
|
|
(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")))))
|
|
;; Non-function define
|
|
(str "let rec " ml-name " =\n " (ml-expr val-expr) "\n"))))))
|