Files
rose-ash/shared/sx/ref/js.sx
giles 8e635cec3d
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 3m26s
Fix duplicate sx-cssx-live style tags
Cache the style element reference in _cssx-style-el so flush-cssx-to-dom
never creates more than one. Previous code called dom-query on every
flush, which could miss the element during rapid successive calls,
creating duplicates.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-14 18:39:28 +00:00

1506 lines
54 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"
"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"
"*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"
"cek-reactive-text" "cekReactiveText"
"cek-reactive-attr" "cekReactiveAttr"
"*use-cek-reactive*" "_useCekReactive"
"enable-cek-reactive!" "enableCekReactive"
"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"
"make-spread" "makeSpread"
"spread?" "isSpread"
"spread-attrs" "spreadAttrs"
"merge-spread-attrs" "mergeSpreadAttrs"
"collect!" "sxCollect"
"collected" "sxCollected"
"clear-collected!" "sxClearCollected"
"make-cek-continuation" "makeCekContinuation"
"continuation-data" "continuationData"
"make-cek-state" "makeCekState"
"make-cek-value" "makeCekValue"
"cek-terminal?" "cekTerminal_p"
"cek-run" "cekRun"
"cek-step" "cekStep"
"cek-control" "cekControl"
"cek-env" "cekEnv"
"cek-kont" "cekKont"
"cek-phase" "cekPhase"
"cek-value" "cekValue"
"kont-push" "kontPush"
"kont-top" "kontTop"
"kont-pop" "kontPop"
"kont-empty?" "kontEmpty_p"
"kont-capture-to-reset" "kontCaptureToReset"
"kont-capture-to-reactive-reset" "kontCaptureToReactiveReset"
"has-reactive-reset-frame?" "hasReactiveResetFrame_p"
"frame-type" "frameType"
"make-if-frame" "makeIfFrame"
"make-when-frame" "makeWhenFrame"
"make-begin-frame" "makeBeginFrame"
"make-let-frame" "makeLetFrame"
"make-define-frame" "makeDefineFrame"
"make-set-frame" "makeSetFrame"
"make-arg-frame" "makeArgFrame"
"make-call-frame" "makeCallFrame"
"make-cond-frame" "makeCondFrame"
"make-case-frame" "makeCaseFrame"
"make-thread-frame" "makeThreadFrame"
"make-map-frame" "makeMapFrame"
"make-filter-frame" "makeFilterFrame"
"make-reduce-frame" "makeReduceFrame"
"make-for-each-frame" "makeForEachFrame"
"make-scope-frame" "makeScopeFrame"
"make-reset-frame" "makeResetFrame"
"make-dict-frame" "makeDictFrame"
"make-and-frame" "makeAndFrame"
"make-or-frame" "makeOrFrame"
"make-dynamic-wind-frame" "makeDynamicWindFrame"
"make-reactive-reset-frame" "makeReactiveResetFrame"
"make-deref-frame" "makeDerefFrame"
"step-eval" "stepEval"
"step-continue" "stepContinue"
"step-eval-list" "stepEvalList"
"step-eval-call" "stepEvalCall"
"step-sf-if" "stepSfIf"
"step-sf-when" "stepSfWhen"
"step-sf-begin" "stepSfBegin"
"step-sf-let" "stepSfLet"
"step-sf-define" "stepSfDefine"
"step-sf-set!" "stepSfSet"
"step-sf-and" "stepSfAnd"
"step-sf-or" "stepSfOr"
"step-sf-cond" "stepSfCond"
"step-sf-case" "stepSfCase"
"step-sf-thread-first" "stepSfThreadFirst"
"step-sf-lambda" "stepSfLambda"
"step-sf-scope" "stepSfScope"
"step-sf-provide" "stepSfProvide"
"step-sf-reset" "stepSfReset"
"step-sf-shift" "stepSfShift"
"step-sf-deref" "stepSfDeref"
"step-ho-map" "stepHoMap"
"step-ho-filter" "stepHoFilter"
"step-ho-reduce" "stepHoReduce"
"step-ho-for-each" "stepHoForEach"
"continue-with-call" "continueWithCall"
"sf-case-step-loop" "sfCaseStepLoop"
"eval-expr-cek" "evalExprCek"
"trampoline-cek" "trampolineCek"
"reactive-shift-deref" "reactiveShiftDeref"
"cond-scheme?" "condScheme_p"
"scope-push!" "scopePush"
"scope-pop!" "scopePop"
"provide-push!" "providePush"
"provide-pop!" "providePop"
"context" "sxContext"
"emit!" "sxEmit"
"emitted" "sxEmitted"
})
;; --------------------------------------------------------------------------
;; Name mangling: SX identifier → valid JS identifier (camelCase)
;; --------------------------------------------------------------------------
(define js-mangle
(fn ((name :as string))
(let ((renamed (get js-renames name)))
(if (not (nil? renamed))
renamed
;; General mangling rules
(let ((result (replace 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 :as string))
(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 :as string))
(if (empty? s) s
(str (upper (slice s 0 1)) (slice s 1)))))
;; --------------------------------------------------------------------------
;; String quoting for JavaScript
;; --------------------------------------------------------------------------
(define js-quote-string
(fn ((s :as string))
(str "\""
(replace (replace (replace (replace (replace (replace
s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\r" "\\r") "\t" "\\t") (char-from-code 0) "\\u0000")
"\"")))
;; --------------------------------------------------------------------------
;; Infix operators
;; --------------------------------------------------------------------------
(define js-infix-ops
(list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod"))
(define js-infix?
(fn ((op :as string))
(some (fn (x) (= x op)) js-infix-ops)))
(define js-op-symbol
(fn ((op :as string))
(case op
"=" "=="
"!=" "!="
"mod" "%"
:else op)))
;; --------------------------------------------------------------------------
;; Self-tail-recursion detection
;; --------------------------------------------------------------------------
(define js-is-self-tail-recursive?
(fn ((name :as string) (body :as list))
(if (empty? body)
false
(js-has-tail-call? name (last body)))))
(define js-has-tail-call?
(fn ((name :as string) 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 :as string) 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 :as string) (clauses :as list))
(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 :as string) (clauses :as list) (i :as number))
(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 :as string) (clauses :as list) (i :as number) (clause-idx :as number) (has-else :as boolean))
(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 :as string) (body :as list))
(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 :as dict))
(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 :as list))
(js-collect-params-loop params 0 (list) nil)))
(define js-collect-params-loop
(fn ((params :as list) (i :as number) (result :as list) 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))
(let ((rp (nth params (+ i 1))))
(js-collect-params-loop params (+ i 2) result
(js-mangle
(if (and (= (type-of rp) "list") (= (len rp) 3)
(= (type-of (nth rp 1)) "keyword")
(= (keyword-name (nth rp 1)) "as"))
(symbol-name (first rp))
(if (= (type-of rp) "symbol") (symbol-name rp) (str rp))))))
(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)
;; Annotated param: (name :as type) → extract name
(and (= (type-of p) "list") (= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(js-collect-params-loop params (+ i 1)
(append result (js-mangle (symbol-name (first 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 :as number) (result :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)))))
(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 :as number) (result :as list))
(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 :as list))
(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 :as list) (i :as number))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(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 :as list))
(str "{" (js-dict-pairs-str pairs 0 (list)) "}")))
(define js-dict-pairs-str
(fn ((pairs :as list) (i :as number) (result :as list))
(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 :as string) (args :as list))
(let ((js-op (js-op-symbol op))
(n (len args)))
(cond
(and (= n 1) (= op "-"))
(str "(-" (js-expr (first args)) ")")
(= n 2)
(str "(" (js-expr (first args))
" " js-op " " (js-expr (nth args 1)) ")")
;; Variadic: left-fold (a op b op c op d ...)
:else
(let ((result (js-expr (first args))))
(for-each (fn (arg)
(set! result (str "(" result " " js-op " " (js-expr arg) ")")))
(rest args))
result)))))
;; --------------------------------------------------------------------------
;; 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)
;; Handle (define name :effects [...] value) — skip :effects annotation
(let ((name (if (= (type-of (nth expr 1)) "symbol")
(symbol-name (nth expr 1))
(str (nth expr 1))))
(val-expr (if (and (>= (len expr) 5)
(= (type-of (nth expr 2)) "keyword")
(= (keyword-name (nth expr 2)) "effects"))
(nth expr 4)
(nth expr 2))))
(let ((mangled (js-mangle name))
(var-decl
(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 " mangled " = function() { while(true) { " loop-body " } };"))
;; Normal define
(str "var " mangled " = " (js-expr val-expr) ";")))))
;; Self-register: every spec define is available to evaluated SX code
(str var-decl "\nPRIMITIVES[\"" name "\"] = " mangled ";")))))
;; --------------------------------------------------------------------------
;; 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)))
(raw-p (first params))
(p (cond
(= (type-of raw-p) "symbol")
(symbol-name raw-p)
;; (name :as type) annotation → extract name
(and (= (type-of raw-p) "list") (= (len raw-p) 3)
(= (type-of (nth raw-p 1)) "keyword")
(= (keyword-name (nth raw-p 1)) "as"))
(symbol-name (first raw-p))
:else (str raw-p)))
(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 :as list))
(join "\n" (map (fn (pair)
(let ((name (first pair))
(expr (nth pair 1)))
(str " // " name "\n " (js-statement expr) "\n")))
defines))))