coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
88e03daf4be2507a0265b0ce2913f6f225b3d71f
rose-ash/hosts/ocaml/transpiler.sx
giles dc7aa709bd review quick-wins: JIT gate, crash guards, crit-2 signal-return, regen repair 
Server (sx_server.ml):
- HTTP mode: JIT hook now opt-in via SX_SERVING_JIT, matching epoch mode
  (was unconditional — live serving-JIT miscompiles J1/J2/J3 de-risked)
- command channel: malformed/non-ASCII line returns an error response
  instead of killing the shared process (C1/C1b)
- response cache: soft error pages no longer cached (S4);
  http_render_page returns (html, is_error)

Kernel spec + regen:
- crit-2: signal-return frame stored the saved kont under :f but the reader
  looked up "saved-kont" — handler value became the whole program's result
  and the covering test passed vacuously. Fixed; raise-continuable now also
  resumes at the raise site (rest-k, not unwound-k), mirroring signal-condition
- quasiquote: R7RS longhand unquote-splicing aliased to splice-unquote
  (used to serialize literally — silent zero-splice)
- guard: re-raise sentinel gensym'd per execution (was forgeable by any
  (list '__guard-reraise__ x) value)
- do: IIFE-head form no longer misparses as a Scheme do-loop
- render: area/base/embed/param/track added to HTML_TAGS (were void-only
  and rendered as Undefined symbol)
- REGEN REPAIR: checked-in sx_ref.ml carried hand-written additions that
  every regeneration silently lost (let-values/define-values/delay/
  delay-force registrations, AdtValue define-type) plus 5 regen blockers
  (arrow-name mangling, 3-arg get, &rest defines, HO-position helper refs,
  transpiler prim-table gaps). Moved into bootstrap.py FIXUPS/skips and the
  transpiler prim table — regen is now reproducible, compiles, and tests
  at baseline (CI Dockerfile.test steps 3-4 could not previously have
  produced a compiling kernel)

Primitives:
- contains?: dict key-check arm per its spec doc
- expt: promotes to float on int63 overflow ((expt 2 100) returned 0)
- mcp_tree parity with sx_primitives: get (Integer indices + 3-arg default),
  split (literal substring, was char-class — the historical gotcha lived
  here), empty? on ""/{}, contains?, equal?, keyword-name, char-code
  (Integer), parse-number (Integer-aware)

Python/docs:
- shared/sx/boundary.py: dead validation now logs a one-time WARNING instead
  of silently no-oping (full revival gated: tier-1 declarations deleted and
  SX_BOUNDARY_STRICT=1 is live in production compose)
- CLAUDE.md: canonical reference now points at spec/*.sx; island authoring
  rules corrected (let IS sequential, bodies ARE implicit begin)

Verification: full suite 5762 passed / 274 failed — fail set byte-identical
to the pre-change baseline (273 in-progress hs-* + pre-existing r7rs radix
shadow). All repros verified fixed on both the native binary and the rebuilt
WASM browser kernel. Review findings: /tmp/sx-review/*.md

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
2026-07-03 13:49:43 +00:00

2004 lines
60 KiB
Plaintext
Raw Blame History

(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"
"callcc-continuation-winders-len"
"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"
"jit-skip?"))
(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*"
"*winders*"))
(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") (cond (some (fn (k) (= k "body-result")) items) (ef "body-result") :else (ef "name")))
"; cf_body = "
(if (= frame-type "if") (ef "then") (ef "body"))
"; cf_remaining = "
(ef "remaining")
"; cf_f = "
(cond (some (fn (k) (= k "after-thunk")) items) (ef "after-thunk") (some (fn (k) (= k "f")) items) (ef "f") :else "Nil")
"; 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")
(some (fn (k) (= k "winders-len")) items)
(ef "winders-len")
: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")
(= op "vector?")
(= op "vector->list")
(= op "list->vector")
(= op "vector-length")
(= op "vector-ref")
(= op "gensym"))
(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")))))))
Reference in New Issue View Git Blame Copy Permalink