Files
rose-ash/shared/sx/ref/js.sx
giles ff6c1fab71 Fix process-bindings scope loss and async-invoke arity, bootstrap async adapter
Two bugs fixed:
1. process-bindings used merge(env) which returns {} for Env objects
   (Env is not a dict subclass). Changed to env-extend in render.sx
   and adapter-async.sx. This caused "Undefined symbol: theme" etc.
2. async-aser-eval-call passed evaled-args list to async-invoke(&rest),
   double-wrapping it. Changed to inline apply + coroutine check.

Also: bootstrap define-async into sx_ref.py (Phase 6), replace ~1000 LOC
hand-written async_eval_ref.py with 24-line thin re-export shim.

Test runner now uses Env (not flat dict) for render envs to catch scope bugs.
8 new regression tests (4 scope chain, 2 native callable arity, 2 render).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 16:38:47 +00:00

1383 lines
49 KiB
Plaintext

;; ==========================================================================
;; js.sx — SX-to-JavaScript translator, written in SX
;;
;; Translates (define ...) forms from .sx spec files into JavaScript source.
;; This is the self-hosting bootstrapper: the Python evaluator executes
;; this file against the spec to produce sx-ref.js — identical output to
;; the hand-written bootstrap_js.py JSEmitter.
;;
;; Usage (from SX):
;; (js-expr expr) — translate one expression to JS
;; (js-statement expr) — translate to JS statement
;; (js-translate-file defines) — translate a list of (name . define-expr) pairs
;;
;; Usage (as reader macro):
;; #js(define foo (fn (x) (+ x 1)))
;; → "var foo = function(x) { return (x + 1); };"
;; ==========================================================================
;; --------------------------------------------------------------------------
;; JS reserved words — names that get _ suffix
;; --------------------------------------------------------------------------
(define js-reserved
(list "abstract" "arguments" "boolean" "break" "byte" "case" "catch"
"char" "class" "const" "continue" "debugger" "default" "delete"
"do" "double" "else" "enum" "eval" "export" "extends" "false"
"final" "finally" "float" "for" "function" "goto" "if"
"implements" "import" "in" "instanceof" "int" "interface" "let"
"long" "native" "new" "null" "package" "private" "protected"
"public" "return" "short" "static" "super" "switch" "synchronized"
"this" "throw" "throws" "transient" "true" "try" "typeof"
"undefined" "var" "void" "volatile" "while" "with" "yield"))
;; --------------------------------------------------------------------------
;; RENAMES table — explicit SX name → JS name mappings
;; --------------------------------------------------------------------------
(define js-renames {
:nil "NIL"
:true "true"
:false "false"
"nil?" "isNil"
"type-of" "typeOf"
"symbol-name" "symbolName"
"keyword-name" "keywordName"
"make-lambda" "makeLambda"
"make-component" "makeComponent"
"make-macro" "makeMacro"
"make-thunk" "makeThunk"
"make-handler-def" "makeHandlerDef"
"make-query-def" "makeQueryDef"
"make-action-def" "makeActionDef"
"make-page-def" "makePageDef"
"make-symbol" "makeSymbol"
"make-keyword" "makeKeyword"
"lambda-params" "lambdaParams"
"lambda-body" "lambdaBody"
"lambda-closure" "lambdaClosure"
"lambda-name" "lambdaName"
"set-lambda-name!" "setLambdaName"
"component-params" "componentParams"
"component-body" "componentBody"
"component-closure" "componentClosure"
"component-has-children?" "componentHasChildren"
"component-name" "componentName"
"component-affinity" "componentAffinity"
"macro-params" "macroParams"
"macro-rest-param" "macroRestParam"
"macro-body" "macroBody"
"macro-closure" "macroClosure"
"thunk?" "isThunk"
"thunk-expr" "thunkExpr"
"thunk-env" "thunkEnv"
"callable?" "isCallable"
"lambda?" "isLambda"
"component?" "isComponent"
"island?" "isIsland"
"make-island" "makeIsland"
"make-signal" "makeSignal"
"signal?" "isSignal"
"signal-value" "signalValue"
"signal-set-value!" "signalSetValue"
"signal-subscribers" "signalSubscribers"
"signal-add-sub!" "signalAddSub"
"signal-remove-sub!" "signalRemoveSub"
"signal-deps" "signalDeps"
"signal-set-deps!" "signalSetDeps"
"set-tracking-context!" "setTrackingContext"
"get-tracking-context" "getTrackingContext"
"make-tracking-context" "makeTrackingContext"
"tracking-context-deps" "trackingContextDeps"
"tracking-context-add-dep!" "trackingContextAddDep"
"tracking-context-notify-fn" "trackingContextNotifyFn"
"identical?" "isIdentical"
"notify-subscribers" "notifySubscribers"
"flush-subscribers" "flushSubscribers"
"dispose-computed" "disposeComputed"
"with-island-scope" "withIslandScope"
"register-in-scope" "registerInScope"
"*batch-depth*" "_batchDepth"
"*batch-queue*" "_batchQueue"
"*island-scope*" "_islandScope"
"*store-registry*" "_storeRegistry"
"def-store" "defStore"
"use-store" "useStore"
"clear-stores" "clearStores"
"emit-event" "emitEvent"
"on-event" "onEvent"
"bridge-event" "bridgeEvent"
"macro?" "isMacro"
"primitive?" "isPrimitive"
"get-primitive" "getPrimitive"
"env-has?" "envHas"
"env-get" "envGet"
"env-set!" "envSet"
"env-extend" "envExtend"
"env-merge" "envMerge"
"dict-set!" "dictSet"
"dict-get" "dictGet"
"eval-expr" "evalExpr"
"eval-list" "evalList"
"eval-call" "evalCall"
"is-render-expr?" "isRenderExpr"
"render-expr" "renderExpr"
"render-active?" "renderActiveP"
"set-render-active!" "setRenderActiveB"
"call-lambda" "callLambda"
"call-component" "callComponent"
"parse-keyword-args" "parseKeywordArgs"
"parse-comp-params" "parseCompParams"
"parse-macro-params" "parseMacroParams"
"expand-macro" "expandMacro"
"render-to-html" "renderToHtml"
"render-to-sx" "renderToSx"
"render-value-to-html" "renderValueToHtml"
"render-list-to-html" "renderListToHtml"
"render-html-element" "renderHtmlElement"
"render-html-component" "renderHtmlComponent"
"render-html-island" "renderHtmlIsland"
"serialize-island-state" "serializeIslandState"
"json-serialize" "jsonSerialize"
"empty-dict?" "isEmptyDict"
"parse-element-args" "parseElementArgs"
"render-attrs" "renderAttrs"
"aser-list" "aserList"
"aser-fragment" "aserFragment"
"aser-call" "aserCall"
"aser-special" "aserSpecial"
"eval-case-aser" "evalCaseAser"
"sx-serialize" "sxSerialize"
"sx-serialize-dict" "sxSerializeDict"
"sx-expr-source" "sxExprSource"
"sf-if" "sfIf"
"sf-when" "sfWhen"
"sf-cond" "sfCond"
"sf-cond-scheme" "sfCondScheme"
"sf-cond-clojure" "sfCondClojure"
"sf-case" "sfCase"
"sf-case-loop" "sfCaseLoop"
"sf-and" "sfAnd"
"sf-or" "sfOr"
"sf-let" "sfLet"
"sf-named-let" "sfNamedLet"
"sf-letrec" "sfLetrec"
"sf-dynamic-wind" "sfDynamicWind"
"push-wind!" "pushWind"
"pop-wind!" "popWind"
"call-thunk" "callThunk"
"sf-lambda" "sfLambda"
"sf-define" "sfDefine"
"sf-defcomp" "sfDefcomp"
"sf-defisland" "sfDefisland"
"defcomp-kwarg" "defcompKwarg"
"sf-defmacro" "sfDefmacro"
"sf-begin" "sfBegin"
"sf-quote" "sfQuote"
"sf-quasiquote" "sfQuasiquote"
"sf-thread-first" "sfThreadFirst"
"sf-set!" "sfSetBang"
"qq-expand" "qqExpand"
"ho-map" "hoMap"
"ho-map-indexed" "hoMapIndexed"
"ho-filter" "hoFilter"
"ho-reduce" "hoReduce"
"ho-some" "hoSome"
"ho-every" "hoEvery"
"ho-for-each" "hoForEach"
"sf-defstyle" "sfDefstyle"
"kf-name" "kfName"
"special-form?" "isSpecialForm"
"ho-form?" "isHoForm"
"strip-prefix" "stripPrefix"
"escape-html" "escapeHtml"
"escape-attr" "escapeAttr"
"escape-string" "escapeString"
"raw-html-content" "rawHtmlContent"
"HTML_TAGS" "HTML_TAGS"
"VOID_ELEMENTS" "VOID_ELEMENTS"
"BOOLEAN_ATTRS" "BOOLEAN_ATTRS"
"definition-form?" "isDefinitionForm"
"RENDER_HTML_FORMS" "RENDER_HTML_FORMS"
"render-html-form?" "isRenderHtmlForm"
"dispatch-html-form" "dispatchHtmlForm"
"render-lambda-html" "renderLambdaHtml"
"make-raw-html" "makeRawHtml"
"SVG_NS" "SVG_NS"
"MATH_NS" "MATH_NS"
"render-to-dom" "renderToDom"
"render-dom-list" "renderDomList"
"render-dom-element" "renderDomElement"
"render-dom-component" "renderDomComponent"
"render-dom-fragment" "renderDomFragment"
"render-dom-raw" "renderDomRaw"
"render-dom-unknown-component" "renderDomUnknownComponent"
"RENDER_DOM_FORMS" "RENDER_DOM_FORMS"
"render-dom-form?" "isRenderDomForm"
"dispatch-render-form" "dispatchRenderForm"
"render-lambda-dom" "renderLambdaDom"
"render-dom-island" "renderDomIsland"
"reactive-text" "reactiveText"
"reactive-attr" "reactiveAttr"
"reactive-fragment" "reactiveFragment"
"reactive-list" "reactiveList"
"dom-create-element" "domCreateElement"
"dom-append" "domAppend"
"dom-set-attr" "domSetAttr"
"dom-get-attr" "domGetAttr"
"dom-remove-attr" "domRemoveAttr"
"dom-has-attr?" "domHasAttr"
"dom-parse-html" "domParseHtml"
"dom-clone" "domClone"
"create-text-node" "createTextNode"
"create-fragment" "createFragment"
"dom-parent" "domParent"
"dom-id" "domId"
"dom-node-type" "domNodeType"
"dom-node-name" "domNodeName"
"dom-text-content" "domTextContent"
"dom-set-text-content" "domSetTextContent"
"dom-is-fragment?" "domIsFragment"
"dom-is-child-of?" "domIsChildOf"
"dom-is-active-element?" "domIsActiveElement"
"dom-is-input-element?" "domIsInputElement"
"dom-first-child" "domFirstChild"
"dom-next-sibling" "domNextSibling"
"dom-child-list" "domChildList"
"dom-attr-list" "domAttrList"
"dom-insert-before" "domInsertBefore"
"dom-insert-after" "domInsertAfter"
"dom-prepend" "domPrepend"
"dom-remove-child" "domRemoveChild"
"dom-replace-child" "domReplaceChild"
"dom-set-inner-html" "domSetInnerHtml"
"dom-insert-adjacent-html" "domInsertAdjacentHtml"
"dom-get-style" "domGetStyle"
"dom-set-style" "domSetStyle"
"dom-get-prop" "domGetProp"
"dom-set-prop" "domSetProp"
"dom-add-class" "domAddClass"
"dom-remove-class" "domRemoveClass"
"dom-dispatch" "domDispatch"
"dom-listen" "domListen"
"event-detail" "eventDetail"
"dom-query" "domQuery"
"dom-ensure-element" "domEnsureElement"
"dom-query-all" "domQueryAll"
"dom-tag-name" "domTagName"
"create-comment" "createComment"
"dom-remove" "domRemove"
"dom-child-nodes" "domChildNodes"
"dom-remove-children-after" "domRemoveChildrenAfter"
"dom-set-data" "domSetData"
"dom-get-data" "domGetData"
"json-parse" "jsonParse"
"dict-has?" "dictHas"
"has-key?" "dictHas"
"dict-delete!" "dictDelete"
"process-bindings" "processBindings"
"eval-cond" "evalCond"
"eval-cond-scheme" "evalCondScheme"
"eval-cond-clojure" "evalCondClojure"
"for-each-indexed" "forEachIndexed"
"index-of" "indexOf_"
"ENGINE_VERBS" "ENGINE_VERBS"
"DEFAULT_SWAP" "DEFAULT_SWAP"
"parse-time" "parseTime"
"parse-trigger-spec" "parseTriggerSpec"
"default-trigger" "defaultTrigger"
"get-verb-info" "getVerbInfo"
"build-request-headers" "buildRequestHeaders"
"process-response-headers" "processResponseHeaders"
"parse-swap-spec" "parseSwapSpec"
"parse-retry-spec" "parseRetrySpec"
"next-retry-ms" "nextRetryMs"
"filter-params" "filterParams"
"resolve-target" "resolveTarget"
"apply-optimistic" "applyOptimistic"
"revert-optimistic" "revertOptimistic"
"find-oob-swaps" "findOobSwaps"
"morph-node" "morphNode"
"sync-attrs" "syncAttrs"
"morph-children" "morphChildren"
"swap-dom-nodes" "swapDomNodes"
"insert-remaining-siblings" "insertRemainingSiblings"
"swap-html-string" "swapHtmlString"
"handle-history" "handleHistory"
"PRELOAD_TTL" "PRELOAD_TTL"
"preload-cache-get" "preloadCacheGet"
"preload-cache-set" "preloadCacheSet"
"classify-trigger" "classifyTrigger"
"should-boost-link?" "shouldBoostLink"
"should-boost-form?" "shouldBoostForm"
"parse-sse-swap" "parseSseSwap"
"_preload-cache" "_preloadCache"
"_css-hash" "_cssHash"
"dispatch-trigger-events" "dispatchTriggerEvents"
"init-css-tracking" "initCssTracking"
"execute-request" "executeRequest"
"do-fetch" "doFetch"
"handle-fetch-success" "handleFetchSuccess"
"handle-sx-response" "handleSxResponse"
"handle-html-response" "handleHtmlResponse"
"handle-retry" "handleRetry"
"bind-triggers" "bindTriggers"
"bind-event" "bindEvent"
"post-swap" "postSwap"
"activate-scripts" "activateScripts"
"process-oob-swaps" "processOobSwaps"
"hoist-head-elements" "hoistHeadElements"
"process-boosted" "processBoosted"
"boost-descendants" "boostDescendants"
"process-sse" "processSse"
"bind-sse" "bindSse"
"bind-sse-swap" "bindSseSwap"
"bind-inline-handlers" "bindInlineHandlers"
"process-emit-elements" "processEmitElements"
"bind-preload-for" "bindPreloadFor"
"do-preload" "doPreload"
"VERB_SELECTOR" "VERB_SELECTOR"
"process-elements" "processElements"
"process-one" "processOne"
"handle-popstate" "handlePopstate"
"engine-init" "engineInit"
"promise-resolve" "promiseResolve"
"promise-then" "promiseThen"
"promise-catch" "promiseCatch"
"promise-delayed" "promiseDelayed"
"abort-previous" "abortPrevious"
"track-controller" "trackController"
"abort-previous-target" "abortPreviousTarget"
"track-controller-target" "trackControllerTarget"
"new-abort-controller" "newAbortController"
"controller-signal" "controllerSignal"
"abort-error?" "isAbortError"
"set-timeout" "setTimeout_"
"set-interval" "setInterval_"
"clear-timeout" "clearTimeout_"
"clear-interval" "clearInterval_"
"request-animation-frame" "requestAnimationFrame_"
"csrf-token" "csrfToken"
"cross-origin?" "isCrossOrigin"
"loaded-component-names" "loadedComponentNames"
"build-request-body" "buildRequestBody"
"show-indicator" "showIndicator"
"disable-elements" "disableElements"
"clear-loading-state" "clearLoadingState"
"fetch-request" "fetchRequest"
"fetch-location" "fetchLocation"
"fetch-and-restore" "fetchAndRestore"
"fetch-streaming" "fetchStreaming"
"fetch-preload" "fetchPreload"
"dom-query-by-id" "domQueryById"
"dom-matches?" "domMatches"
"dom-closest" "domClosest"
"dom-body" "domBody"
"dom-has-class?" "domHasClass"
"dom-append-to-head" "domAppendToHead"
"dom-parse-html-document" "domParseHtmlDocument"
"dom-outer-html" "domOuterHtml"
"dom-body-inner-html" "domBodyInnerHtml"
"prevent-default" "preventDefault_"
"stop-propagation" "stopPropagation_"
"dom-focus" "domFocus"
"try-catch" "tryCatch"
"error-message" "errorMessage"
"schedule-idle" "scheduleIdle"
"element-value" "elementValue"
"validate-for-request" "validateForRequest"
"with-transition" "withTransition"
"observe-intersection" "observeIntersection"
"event-source-connect" "eventSourceConnect"
"event-source-listen" "eventSourceListen"
"bind-boost-link" "bindBoostLink"
"bind-boost-form" "bindBoostForm"
"bind-client-route-link" "bindClientRouteLink"
"bind-client-route-click" "bindClientRouteClick"
"try-client-route" "tryClientRoute"
"try-eval-content" "tryEvalContent"
"try-async-eval-content" "tryAsyncEvalContent"
"register-io-deps" "registerIoDeps"
"url-pathname" "urlPathname"
"bind-preload" "bindPreload"
"mark-processed!" "markProcessed"
"is-processed?" "isProcessed"
"create-script-clone" "createScriptClone"
"sx-render" "sxRender"
"sx-process-scripts" "sxProcessScripts"
"sx-hydrate" "sxHydrate"
"strip-component-scripts" "stripComponentScripts"
"extract-response-css" "extractResponseCss"
"select-from-container" "selectFromContainer"
"children-to-fragment" "childrenToFragment"
"select-html-from-doc" "selectHtmlFromDoc"
"try-parse-json" "tryParseJson"
"process-css-response" "processCssResponse"
"browser-location-href" "browserLocationHref"
"browser-same-origin?" "browserSameOrigin"
"browser-push-state" "browserPushState"
"browser-replace-state" "browserReplaceState"
"browser-navigate" "browserNavigate"
"browser-reload" "browserReload"
"browser-scroll-to" "browserScrollTo"
"browser-media-matches?" "browserMediaMatches"
"browser-confirm" "browserConfirm"
"browser-prompt" "browserPrompt"
"now-ms" "nowMs"
"parse-header-value" "parseHeaderValue"
"replace" "replace_"
"whitespace?" "isWhitespace"
"digit?" "isDigit"
"ident-start?" "isIdentStart"
"ident-char?" "isIdentChar"
"parse-number" "parseNumber"
"starts-with?" "startsWith"
"ends-with?" "endsWith"
"contains?" "contains"
"empty?" "isEmpty"
"odd?" "isOdd"
"even?" "isEven"
"zero?" "isZero"
"number?" "isNumber"
"string?" "isString"
"list?" "isList"
"dict?" "isDict"
"every?" "isEvery"
"map-indexed" "mapIndexed"
"for-each" "forEach"
"map-dict" "mapDict"
"chunk-every" "chunkEvery"
"zip-pairs" "zipPairs"
"strip-tags" "stripTags"
"format-date" "formatDate"
"format-decimal" "formatDecimal"
"parse-int" "parseInt_"
"HEAD_HOIST_SELECTOR" "HEAD_HOIST_SELECTOR"
"hoist-head-elements-full" "hoistHeadElementsFull"
"sx-mount" "sxMount"
"sx-hydrate-elements" "sxHydrateElements"
"sx-update-element" "sxUpdateElement"
"sx-render-component" "sxRenderComponent"
"process-sx-scripts" "processSxScripts"
"process-component-script" "processComponentScript"
"SX_VERSION" "SX_VERSION"
"boot-init" "bootInit"
"sx-hydrate-islands" "sxHydrateIslands"
"hydrate-island" "hydrateIsland"
"dispose-island" "disposeIsland"
"resolve-suspense" "resolveSuspense"
"resolve-mount-target" "resolveMountTarget"
"sx-render-with-env" "sxRenderWithEnv"
"get-render-env" "getRenderEnv"
"merge-envs" "mergeEnvs"
"sx-load-components" "sxLoadComponents"
"set-document-title" "setDocumentTitle"
"remove-head-element" "removeHeadElement"
"query-sx-scripts" "querySxScripts"
"local-storage-get" "localStorageGet"
"local-storage-set" "localStorageSet"
"local-storage-remove" "localStorageRemove"
"set-sx-comp-cookie" "setSxCompCookie"
"clear-sx-comp-cookie" "clearSxCompCookie"
"parse-env-attr" "parseEnvAttr"
"store-env-attr" "storeEnvAttr"
"to-kebab" "toKebab"
"log-info" "logInfo"
"log-warn" "logWarn"
"log-parse-error" "logParseError"
"_page-routes" "_pageRoutes"
"process-page-scripts" "processPageScripts"
"query-page-scripts" "queryPageScripts"
"scan-refs" "scanRefs"
"scan-refs-walk" "scanRefsWalk"
"transitive-deps" "transitiveDeps"
"compute-all-deps" "computeAllDeps"
"scan-components-from-source" "scanComponentsFromSource"
"components-needed" "componentsNeeded"
"page-component-bundle" "pageComponentBundle"
"page-css-classes" "pageCssClasses"
"component-deps" "componentDeps"
"component-set-deps!" "componentSetDeps"
"component-css-classes" "componentCssClasses"
"component-io-refs" "componentIoRefs"
"component-set-io-refs!" "componentSetIoRefs"
"env-components" "envComponents"
"regex-find-all" "regexFindAll"
"scan-css-classes" "scanCssClasses"
"scan-io-refs" "scanIoRefs"
"scan-io-refs-walk" "scanIoRefsWalk"
"transitive-io-refs" "transitiveIoRefs"
"compute-all-io-refs" "computeAllIoRefs"
"component-io-refs-cached" "componentIoRefsCached"
"component-pure?" "componentPure_p"
"render-target" "renderTarget"
"page-render-plan" "pageRenderPlan"
"split-path-segments" "splitPathSegments"
"make-route-segment" "makeRouteSegment"
"parse-route-pattern" "parseRoutePattern"
"match-route-segments" "matchRouteSegments"
"match-route" "matchRoute"
"find-matching-route" "findMatchingRoute"
})
;; --------------------------------------------------------------------------
;; Name mangling: SX identifier → valid JS identifier (camelCase)
;; --------------------------------------------------------------------------
(define js-mangle
(fn (name)
(let ((renamed (get js-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 camelCase
(let ((result (js-kebab-to-camel result)))
;; Escape JS reserved words
(if (some (fn (r) (= r result)) js-reserved)
(str result "_")
result))))))))
(define js-kebab-to-camel
(fn (s)
(let ((parts (split s "-")))
(if (<= (len parts) 1)
s
(str (first parts)
(join "" (map (fn (p) (js-capitalize p)) (rest parts))))))))
(define js-capitalize
(fn (s)
(if (empty? s) s
(str (upper (slice s 0 1)) (slice s 1)))))
;; --------------------------------------------------------------------------
;; String quoting for JavaScript
;; --------------------------------------------------------------------------
(define js-quote-string
(fn (s)
(str "\""
(replace (replace (replace (replace (replace (replace
s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\r" "\\r") "\t" "\\t") "\0" "\\0")
"\"")))
;; --------------------------------------------------------------------------
;; Infix operators
;; --------------------------------------------------------------------------
(define js-infix-ops
(list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod"))
(define js-infix?
(fn (op)
(some (fn (x) (= x op)) js-infix-ops)))
(define js-op-symbol
(fn (op)
(case op
"=" "=="
"!=" "!="
"mod" "%"
:else op)))
;; --------------------------------------------------------------------------
;; Self-tail-recursion detection
;; --------------------------------------------------------------------------
(define js-is-self-tail-recursive?
(fn (name body)
(if (empty? body)
false
(js-has-tail-call? name (last body)))))
(define js-has-tail-call?
(fn (name expr)
(if (not (and (list? expr) (not (empty? expr))))
false
(let ((head (first expr)))
(if (not (= (type-of head) "symbol"))
false
(let ((h (symbol-name head)))
(cond
;; Direct tail call
(= h name) true
;; Branching forms
(= h "if")
(or (js-has-tail-call? name (nth expr 2))
(and (>= (len expr) 4)
(js-has-tail-call? name (nth expr 3))))
(= h "when")
(some (fn (e) (js-has-tail-call? name e)) (rest (rest expr)))
(= h "cond")
(some (fn (clause)
(if (and (list? clause) (= (len clause) 2))
(js-has-tail-call? name (nth clause 1))
(if (= (type-of clause) "keyword")
false
(js-has-tail-call? name clause))))
(rest expr))
(or (= h "do") (= h "begin"))
(if (> (len expr) 1) (js-has-tail-call? name (last expr)) false)
(or (= h "let") (= h "let*"))
(if (> (len expr) 2) (js-has-tail-call? name (last expr)) false)
:else false)))))))
;; --------------------------------------------------------------------------
;; Tail-as-statement emission (for while loop bodies)
;; --------------------------------------------------------------------------
(define js-emit-tail-as-stmt
(fn (name expr)
(if (not (and (list? expr) (not (empty? expr))))
(str "return " (js-expr expr) ";")
(let ((head (first expr)))
(if (not (= (type-of head) "symbol"))
(str "return " (js-expr expr) ";")
(let ((h (symbol-name head)))
(cond
;; Direct tail call to self → continue
(= h name)
"continue;"
;; (do/begin stmt1 ... tail) → emit stmts then recurse on tail
(or (= h "do") (= h "begin"))
(str (join "\n" (map (fn (e) (js-statement e)) (slice expr 1 (- (len expr) 1))))
"\n" (js-emit-tail-as-stmt name (last expr)))
;; (if cond then else)
(= h "if")
(str "if (isSxTruthy(" (js-expr (nth expr 1))
")) { " (js-emit-tail-as-stmt name (nth expr 2))
" } else { " (if (>= (len expr) 4)
(js-emit-tail-as-stmt name (nth expr 3))
"return NIL;")
" }")
;; (when cond body...)
(= h "when")
(let ((body-parts (rest (rest expr))))
(str "if (isSxTruthy(" (js-expr (nth expr 1))
")) { " (if (empty? body-parts) ""
(str (join "\n" (map (fn (e) (js-statement e))
(slice body-parts 0 (- (len body-parts) 1))))
(if (> (len body-parts) 1) "\n" "")
(js-emit-tail-as-stmt name (last body-parts))))
" } else { return NIL; }"))
;; (cond ...)
(= h "cond")
(js-emit-cond-as-loop-stmt name (rest expr))
;; (let bindings body...)
(or (= h "let") (= h "let*"))
(let ((bindings (nth expr 1))
(body (rest (rest expr)))
(parts (list)))
(begin
;; Emit bindings as var declarations
(js-append-let-binding-parts bindings parts)
;; Emit body[:-1] as statements
(for-each (fn (e) (append! parts (js-statement e)))
(slice body 0 (- (len body) 1)))
;; Emit tail
(append! parts (js-emit-tail-as-stmt name (last body)))
(str "{ " (join "\n" parts) " }")))
;; Not a tail call
:else
(str "return " (js-expr expr) ";"))))))))
;; --------------------------------------------------------------------------
;; Cond as loop statement (if/else if/else for while loop body)
;; --------------------------------------------------------------------------
(define js-emit-cond-as-loop-stmt
(fn (name clauses)
(if (empty? clauses)
"return NIL;"
;; Detect scheme vs clojure
(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
(js-cond-scheme-loop name clauses 0)
(js-cond-clojure-loop name clauses 0 0 false))))))
(define js-cond-scheme-loop
(fn (name clauses i)
(if (>= i (len clauses))
"else { return NIL; }"
(let ((clause (nth clauses i))
(test (first clause))
(body (nth clause 1)))
(if (js-is-else? test)
(str "{ " (js-emit-tail-as-stmt name body) " }")
(str (if (= i 0) "if" " else if")
" (isSxTruthy(" (js-expr test) ")) { "
(js-emit-tail-as-stmt name body) " }"
(js-cond-scheme-loop name clauses (+ i 1))))))))
(define js-cond-clojure-loop
(fn (name clauses i clause-idx has-else)
(if (>= i (len clauses))
(if has-else "" " else { return NIL; }")
(let ((c (nth clauses i)))
(if (and (= (type-of c) "keyword") (= (keyword-name c) "else"))
(if (< (+ i 1) (len clauses))
(str " else { " (js-emit-tail-as-stmt name (nth clauses (+ i 1))) " }")
"")
(if (< (+ i 1) (len clauses))
(str (if (= clause-idx 0) "if" " else if")
" (isSxTruthy(" (js-expr c) ")) { "
(js-emit-tail-as-stmt name (nth clauses (+ i 1)))
" }" (js-cond-clojure-loop name clauses (+ i 2) (+ clause-idx 1) has-else))
(str " else { " (js-emit-tail-as-stmt name c) " }")))))))
;; --------------------------------------------------------------------------
;; Loop body emission (for self-tail-recursive while loops)
;; --------------------------------------------------------------------------
(define js-emit-loop-body
(fn (name body)
(if (empty? body)
"return NIL;"
(str (join "\n" (map (fn (e) (js-statement e))
(slice body 0 (- (len body) 1))))
(if (> (len body) 1) "\n" "")
(js-emit-tail-as-stmt name (last body))))))
;; --------------------------------------------------------------------------
;; Expression translator: SX AST → JS expression string
;; --------------------------------------------------------------------------
(define js-expr
(fn (expr)
(cond
;; Bool MUST come before number check
(= (type-of expr) "boolean")
(if expr "true" "false")
;; Nil
(nil? expr) "NIL"
;; Numbers
(number? expr) (str expr)
;; Strings
(string? expr) (js-quote-string expr)
;; Symbols
(= (type-of expr) "symbol")
(js-mangle (symbol-name expr))
;; Keywords → string
(= (type-of expr) "keyword")
(js-quote-string (keyword-name expr))
;; Dicts (native {:key val} syntax)
(= (type-of expr) "dict")
(js-emit-native-dict expr)
;; Lists (function calls / special forms)
(list? expr)
(if (empty? expr)
"[]"
(js-emit-list expr))
;; Fallback
:else (str expr))))
;; --------------------------------------------------------------------------
;; Dict emission
;; --------------------------------------------------------------------------
(define js-emit-native-dict
(fn (d)
(let ((items (keys d)))
(str "{" (join ", " (map (fn (k)
(str (js-quote-string k) ": " (js-expr (get d k))))
items)) "}"))))
;; --------------------------------------------------------------------------
;; List/call emission — the main dispatch
;; --------------------------------------------------------------------------
(define js-emit-list
(fn (expr)
(let ((head (first expr))
(args (rest expr)))
(if (not (= (type-of head) "symbol"))
;; Data list — not a function call
(str "[" (join ", " (map js-expr expr)) "]")
(let ((op (symbol-name head)))
(cond
;; fn/lambda
(or (= op "fn") (= op "lambda"))
(js-emit-fn expr)
;; let/let*
(or (= op "let") (= op "let*"))
(js-emit-let expr)
;; if
(= op "if")
(let ((cond-e (js-expr (nth args 0)))
(then-e (js-expr (nth args 1)))
(else-e (if (>= (len args) 3)
(js-expr (nth args 2))
"NIL")))
(str "(isSxTruthy(" cond-e ") ? " then-e " : " else-e ")"))
;; when
(= op "when")
(js-emit-when expr)
;; cond
(= op "cond")
(js-emit-cond args)
;; case
(= op "case")
(js-emit-case args)
;; and
(= op "and")
(js-emit-and args)
;; or
(= op "or")
(js-emit-or args)
;; not
(= op "not")
(str "!isSxTruthy(" (js-expr (first args)) ")")
;; do/begin → comma operator
(or (= op "do") (= op "begin"))
(js-emit-do args)
;; list literal
(= op "list")
(str "[" (join ", " (map js-expr args)) "]")
;; dict literal
(= op "dict")
(js-emit-dict-literal args)
;; quote
(= op "quote")
(js-emit-quote (first args))
;; set! → direct assignment (JS closures capture by reference)
(= op "set!")
(str "(" (js-mangle (symbol-name (first args))) " = "
(js-expr (nth args 1)) ")")
;; str → String() concatenation
(= op "str")
(if (empty? args)
"\"\""
(str "(" (join " + " (map (fn (x) (str "String(" (js-expr x) ")"))
args)) ")"))
;; Mutation forms
(= op "append!")
(str "append_b(" (js-expr (nth args 0))
", " (js-expr (nth args 1)) ")")
(= op "dict-set!")
(str "dictSet(" (js-expr (nth args 0))
", " (js-expr (nth args 1))
", " (js-expr (nth args 2)) ")")
(= op "env-set!")
(str "envSet(" (js-expr (nth args 0))
", " (js-expr (nth args 1))
", " (js-expr (nth args 2)) ")")
(= op "set-lambda-name!")
(str "setLambdaName(" (js-expr (nth args 0))
", " (js-expr (nth args 1)) ")")
;; Infix operators
(js-infix? op)
(js-emit-infix op args)
;; inc/dec
(= op "inc")
(str "(" (js-expr (first args)) " + 1)")
(= op "dec")
(str "(" (js-expr (first args)) " - 1)")
;; Regular function call
:else
(str (js-mangle op) "("
(join ", " (map js-expr args))
")")))))))
;; --------------------------------------------------------------------------
;; fn/lambda → function() { return ...; }
;; --------------------------------------------------------------------------
(define js-emit-fn
(fn (expr)
(let ((params (nth expr 1))
(body (rest (rest expr)))
(param-info (js-collect-params params)))
(let ((param-strs (first param-info))
(rest-name (nth param-info 1))
(params-str (join ", " param-strs)))
(let ((rest-preamble (if (nil? rest-name)
""
(str "var " rest-name " = Array.prototype.slice.call(arguments, "
(str (len param-strs)) "); "))))
(if (= (len body) 1)
;; Single expression body
(let ((body-js (js-expr (first body))))
(if (not (= rest-preamble ""))
(str "function(" params-str ") { " rest-preamble "return " body-js "; }")
(str "function(" params-str ") { return " body-js "; }")))
;; Multi-expression body: statements then return last
(let ((parts (list)))
(begin
(when (not (= rest-preamble ""))
(append! parts (slice rest-preamble 0 (- (string-length rest-preamble) 1))))
(for-each (fn (b) (append! parts (js-statement b)))
(slice body 0 (- (len body) 1)))
(append! parts (str "return " (js-expr (last body)) ";"))
(str "function(" params-str ") { " (join "\n" parts) " }")))))))))
(define js-collect-params
(fn (params)
(js-collect-params-loop params 0 (list) nil)))
(define js-collect-params-loop
(fn (params i result rest-name)
(if (>= i (len params))
(list result rest-name)
(let ((p (nth params i)))
(cond
;; &rest marker
(and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
(if (< (+ i 1) (len params))
(js-collect-params-loop params (+ i 2) result
(js-mangle (symbol-name (nth params (+ i 1)))))
(js-collect-params-loop params (+ i 1) result rest-name))
;; Normal param
(= (type-of p) "symbol")
(js-collect-params-loop params (+ i 1)
(append result (js-mangle (symbol-name p))) rest-name)
;; Something else
:else
(js-collect-params-loop params (+ i 1)
(append result (str p)) rest-name))))))
;; --------------------------------------------------------------------------
;; let → IIFE (immediately invoked function expression)
;; --------------------------------------------------------------------------
(define js-emit-let
(fn (expr)
(let ((bindings (nth expr 1))
(body (rest (rest expr))))
(let ((binding-lines (js-parse-let-bindings bindings))
(body-strs (list)))
(begin
(for-each (fn (b) (append! body-strs (str " " (js-statement b))))
(slice body 0 (- (len body) 1)))
(append! body-strs (str " return " (js-expr (last body)) ";"))
(str "(function() {\n"
(join "\n" binding-lines)
(if (empty? binding-lines) "" "\n")
(join "\n" body-strs)
"\n})()"))))))
(define js-parse-let-bindings
(fn (bindings)
(if (not (and (list? bindings) (not (empty? bindings))))
(list)
(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)))))
(str " var " (js-mangle vname) " = " (js-expr (nth b 1)) ";")))
bindings)
;; Clojure-style: (name val name val ...)
(js-parse-clojure-let-bindings bindings 0 (list))))))
(define js-parse-clojure-let-bindings
(fn (bindings i result)
(if (>= i (- (len bindings) 1))
result
(let ((vname (if (= (type-of (nth bindings i)) "symbol")
(symbol-name (nth bindings i))
(str (nth bindings i)))))
(js-parse-clojure-let-bindings bindings (+ i 2)
(append result (str " var " (js-mangle vname) " = "
(js-expr (nth bindings (+ i 1))) ";")))))))
(define js-emit-let-bindings-as-vars
(fn (bindings)
(if (not (and (list? bindings) (not (empty? bindings))))
""
(if (list? (first bindings))
;; Scheme-style
(str (join " " (map (fn (b)
(let ((vname (if (= (type-of (first b)) "symbol")
(symbol-name (first b))
(str (first b)))))
(str "var " (js-mangle vname) " = " (js-expr (nth b 1)) ";")))
bindings)) " ")
;; Clojure-style
(str (js-emit-clojure-let-vars bindings 0 (list)) " ")))))
(define js-emit-clojure-let-vars
(fn (bindings i result)
(if (>= i (- (len bindings) 1))
(join " " result)
(let ((vname (if (= (type-of (nth bindings i)) "symbol")
(symbol-name (nth bindings i))
(str (nth bindings i)))))
(js-emit-clojure-let-vars bindings (+ i 2)
(append result (str "var " (js-mangle vname) " = "
(js-expr (nth bindings (+ i 1))) ";")))))))
;; Helper to append let binding var declarations to a parts list
(define js-append-let-binding-parts
(fn (bindings parts)
(when (and (list? bindings) (not (empty? bindings)))
(if (list? (first bindings))
;; Scheme-style
(for-each (fn (b)
(let ((vname (if (= (type-of (first b)) "symbol")
(symbol-name (first b))
(str (first b)))))
(append! parts (str "var " (js-mangle vname) " = " (js-expr (nth b 1)) ";"))))
bindings)
;; Clojure-style
(js-append-clojure-bindings bindings parts 0)))))
(define js-append-clojure-bindings
(fn (bindings parts i)
(when (< i (- (len bindings) 1))
(let ((vname (if (= (type-of (nth bindings i)) "symbol")
(symbol-name (nth bindings i))
(str (nth bindings i)))))
(begin
(append! parts (str "var " (js-mangle vname) " = "
(js-expr (nth bindings (+ i 1))) ";"))
(js-append-clojure-bindings bindings parts (+ i 2)))))))
;; --------------------------------------------------------------------------
;; when → ternary
;; --------------------------------------------------------------------------
(define js-emit-when
(fn (expr)
(let ((cond-e (js-expr (nth expr 1)))
(body-parts (rest (rest expr))))
(if (= (len body-parts) 1)
(str "(isSxTruthy(" cond-e ") ? " (js-expr (first body-parts)) " : NIL)")
(str "(isSxTruthy(" cond-e ") ? " (js-emit-do body-parts) " : NIL)")))))
;; --------------------------------------------------------------------------
;; cond → chained ternaries
;; --------------------------------------------------------------------------
(define js-emit-cond
(fn (clauses)
(if (empty? clauses)
"NIL"
;; Detect scheme vs clojure style
(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
(js-cond-scheme clauses)
(js-cond-clojure clauses))))))
(define js-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 js-cond-scheme
(fn (clauses)
(if (empty? clauses)
"NIL"
(let ((clause (first clauses))
(test (first clause))
(body (nth clause 1)))
(if (js-is-else? test)
(js-expr body)
(str "(isSxTruthy(" (js-expr test) ") ? " (js-expr body)
" : " (js-cond-scheme (rest clauses)) ")"))))))
(define js-cond-clojure
(fn (clauses)
(if (< (len clauses) 2)
"NIL"
(let ((test (first clauses))
(body (nth clauses 1)))
(if (js-is-else? test)
(js-expr body)
(str "(isSxTruthy(" (js-expr test) ") ? " (js-expr body)
" : " (js-cond-clojure (rest (rest clauses))) ")"))))))
;; --------------------------------------------------------------------------
;; case → IIFE with if/else chain
;; --------------------------------------------------------------------------
(define js-emit-case
(fn (args)
(let ((match-expr (js-expr (first args)))
(clauses (rest args)))
(str "(function() { var _m = " match-expr "; "
(js-case-chain clauses) " })()"))))
(define js-case-chain
(fn (clauses)
(if (< (len clauses) 2)
"return NIL;"
(let ((test (nth clauses 0))
(body (nth clauses 1)))
(if (js-is-else? test)
(str "return " (js-expr body) ";")
(str "if (_m == " (js-expr test) ") return "
(js-expr body) "; "
(js-case-chain (rest (rest clauses)))))))))
;; --------------------------------------------------------------------------
;; and → && with isSxTruthy
;; --------------------------------------------------------------------------
(define js-emit-and
(fn (args)
(let ((parts (map js-expr args)))
(if (= (len parts) 1)
(first parts)
;; All but last wrapped in isSxTruthy, last returned as-is
(str "(" (join " && " (map (fn (p) (str "isSxTruthy(" p ")"))
(slice parts 0 (- (len parts) 1))))
" && " (last parts) ")")))))
;; --------------------------------------------------------------------------
;; or → sxOr()
;; --------------------------------------------------------------------------
(define js-emit-or
(fn (args)
(if (= (len args) 1)
(js-expr (first args))
(str "sxOr(" (join ", " (map js-expr args)) ")"))))
;; --------------------------------------------------------------------------
;; do/begin → comma operator
;; --------------------------------------------------------------------------
(define js-emit-do
(fn (args)
(if (= (len args) 1)
(js-expr (first args))
(str "(" (join ", " (map js-expr args)) ")"))))
;; --------------------------------------------------------------------------
;; dict literal → JS object
;; --------------------------------------------------------------------------
(define js-emit-dict-literal
(fn (pairs)
(str "{" (js-dict-pairs-str pairs 0 (list)) "}")))
(define js-dict-pairs-str
(fn (pairs i result)
(if (>= i (- (len pairs) 1))
(join ", " result)
(let ((key (nth pairs i))
(val (nth pairs (+ i 1))))
(let ((key-str (if (= (type-of key) "keyword")
(js-quote-string (keyword-name key))
(str "[" (js-expr key) "]")))
(val-str (js-expr val)))
(js-dict-pairs-str pairs (+ i 2)
(append result (str key-str ": " val-str))))))))
;; --------------------------------------------------------------------------
;; Infix operators
;; --------------------------------------------------------------------------
(define js-emit-infix
(fn (op args)
(let ((js-op (js-op-symbol op)))
(if (and (= (len args) 1) (= op "-"))
(str "(-" (js-expr (first args)) ")")
(str "(" (js-expr (first args))
" " js-op " " (js-expr (nth args 1)) ")")))))
;; --------------------------------------------------------------------------
;; quote → JS AST literals
;; --------------------------------------------------------------------------
(define js-emit-quote
(fn (expr)
(cond
(= (type-of expr) "boolean")
(if expr "true" "false")
(number? expr) (str expr)
(string? expr) (js-quote-string expr)
(nil? expr) "NIL"
(= (type-of expr) "symbol")
(str "new Symbol(" (js-quote-string (symbol-name expr)) ")")
(= (type-of expr) "keyword")
(str "new Keyword(" (js-quote-string (keyword-name expr)) ")")
(list? expr)
(str "[" (join ", " (map js-emit-quote expr)) "]")
:else (str expr))))
;; --------------------------------------------------------------------------
;; Statement translator: SX AST → JS statement string
;; --------------------------------------------------------------------------
(define js-statement
(fn (expr)
(if (and (list? expr) (not (empty? expr))
(= (type-of (first expr)) "symbol"))
(let ((name (symbol-name (first expr))))
(cond
(= name "define")
(js-emit-define expr)
(= name "set!")
(str (js-mangle (symbol-name (nth expr 1))) " = "
(js-expr (nth expr 2)) ";")
(= name "when")
(js-emit-when-stmt expr)
(or (= name "do") (= name "begin"))
(join "\n" (map js-statement (rest expr)))
(= name "for-each")
(js-emit-for-each-stmt expr)
(= name "dict-set!")
(str (js-expr (nth expr 1)) "[" (js-expr (nth expr 2))
"] = " (js-expr (nth expr 3)) ";")
(= name "append!")
(str (js-expr (nth expr 1)) ".push(" (js-expr (nth expr 2)) ");")
(= name "env-set!")
(str "envSet(" (js-expr (nth expr 1))
", " (js-expr (nth expr 2))
", " (js-expr (nth expr 3)) ");")
(= name "set-lambda-name!")
(str (js-expr (nth expr 1)) ".name = " (js-expr (nth expr 2)) ";")
:else
(str (js-expr expr) ";")))
(str (js-expr expr) ";"))))
;; --------------------------------------------------------------------------
;; define → var declaration with self-tail-recursion optimization
;; --------------------------------------------------------------------------
(define js-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)))
(if (nil? val-expr)
(str "var " (js-mangle name) " = NIL;")
;; Detect zero-arg self-tail-recursive functions → while loops
(if (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"))
(list? (nth val-expr 1))
(= (len (nth val-expr 1)) 0)
(js-is-self-tail-recursive? name (rest (rest val-expr))))
;; While loop optimization
(let ((body (rest (rest val-expr)))
(loop-body (js-emit-loop-body name body)))
(str "var " (js-mangle name) " = function() { while(true) { " loop-body " } };"))
;; Normal define
(str "var " (js-mangle name) " = " (js-expr val-expr) ";"))))))
;; --------------------------------------------------------------------------
;; when as statement → if block
;; --------------------------------------------------------------------------
(define js-emit-when-stmt
(fn (expr)
(let ((cond-e (js-expr (nth expr 1)))
(body-parts (rest (rest expr))))
(str "if (isSxTruthy(" cond-e ")) {\n"
(join "\n" (map (fn (e) (str " " (js-statement e))) body-parts))
"\n}"))))
;; --------------------------------------------------------------------------
;; for-each as statement → for loop
;; --------------------------------------------------------------------------
(define js-emit-for-each-stmt
(fn (expr)
(let ((fn-expr (nth expr 1))
(coll-expr (nth expr 2))
(coll (js-expr coll-expr)))
(if (and (list? fn-expr)
(= (type-of (first fn-expr)) "symbol")
(= (symbol-name (first fn-expr)) "fn"))
;; Inline lambda → for loop
(let ((params (nth fn-expr 1))
(body (rest (rest fn-expr)))
(p (if (= (type-of (first params)) "symbol")
(symbol-name (first params))
(str (first params))))
(p-js (js-mangle p)))
(str "{ var _c = " coll "; for (var _i = 0; _i < _c.length; _i++) { var "
p-js " = _c[_i]; "
(join "\n" (map js-statement body)) " } }"))
;; Non-inline → for loop with function call
(str "{ var _c = " coll "; for (var _i = 0; _i < _c.length; _i++) { "
(js-expr fn-expr) "(_c[_i]); } }")))))
;; --------------------------------------------------------------------------
;; File translation: process a list of (name, define-expr) pairs
;; --------------------------------------------------------------------------
(define js-translate-file
(fn (defines)
(join "\n" (map (fn (pair)
(let ((name (first pair))
(expr (nth pair 1)))
(str " // " name "\n " (js-statement expr) "\n")))
defines))))