coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
f12bbae6c96fbdede14c05df24ece76b62ed79fa
rose-ash/hosts/javascript/transpiler.sx
giles 71c2003a60 OCaml evaluator for page dispatch + handler aser, 83/83 Playwright tests 
Major architectural change: page function dispatch and handler execution
now go through the OCaml kernel instead of the Python bootstrapped evaluator.

OCaml integration:
- Page dispatch: bridge.eval() evaluates SX URL expressions (geography, marshes, etc.)
- Handler aser: bridge.aser() serializes handler responses as SX wire format
- _ensure_components loads all .sx files into OCaml kernel (spec, web adapter, handlers)
- defhandler/defpage registered as no-op special forms so handler files load
- helper IO primitive dispatches to Python page helpers + IO handlers
- ok-raw response format for SX wire format (no double-escaping)
- Natural list serialization in eval (no (list ...) wrapper)
- Clean pipe: _read_until_ok always sends io-response on error

SX adapter (aser):
- scope-emit!/scope-peek aliases to avoid CEK special form conflict
- aser-fragment/aser-call: strings starting with "(" pass through unserialized
- Registered cond-scheme?, is-else-clause?, primitive?, get-primitive in kernel
- random-int, parse-int as kernel primitives; json-encode, into via IO bridge

Handler migration:
- All IO calls converted to (helper "name" args...) pattern
- request-arg, request-form, state-get, state-set!, now, component-source etc.
- Fixed bare (effect ...) in island bodies leaking disposer functions as text
- Fixed lower-case → lower, ~search-results → ~examples/search-results

Reactive islands:
- sx-hydrate-islands called after client-side navigation swap
- force-dispose-islands-in for outerHTML swaps (clears hydration markers)
- clear-processed! platform primitive for re-hydration

Content restructuring:
- Design, event bridge, named stores, phase 2 consolidated into reactive overview
- Marshes split into overview + 5 example sub-pages
- Nav links use sx-get/sx-target for client-side navigation

Playwright test suite (sx/tests/test_demos.py):
- 83 tests covering hypermedia demos, reactive islands, marshes, spec explorer
- Server-side rendering, handler interactions, island hydration, navigation

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

1566 lines
56 KiB
Plaintext
Raw Blame History

;; ==========================================================================
;; 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"
"*custom-special-forms*" "_customSpecialForms"
"register-special-form!" "registerSpecialForm"
"*render-check*" "_renderCheck"
"*render-fn*" "_renderFn"
"is-else-clause?" "isElseClause"
"host-global" "hostGlobal"
"host-get" "hostGet"
"host-set!" "hostSet"
"host-call" "hostCall"
"host-new" "hostNew"
"host-callback" "hostCallback"
"host-typeof" "hostTypeof"
"host-await" "hostAwait"
"dom-document" "domDocument"
"dom-window" "domWindow"
"dom-head" "domHead"
"!=" "notEqual_"
"<=" "lte_"
">=" "gte_"
"*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-bind!" "envBind"
"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"
"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"
"clear-processed!" "clearProcessed"
"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-bind!")
(str "envBind(" (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)
;; Detect named let: (let name ((x init) ...) body...)
(if (= (type-of (nth expr 1)) "symbol")
(js-emit-named-let 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})()")))))))
;; Named let: (let loop-name ((param init) ...) body...)
;; Emits a named IIFE: (function loop(p1, p2) { body })(init1, init2)
(define js-emit-named-let
(fn (expr)
(let ((loop-name (symbol-name (nth expr 1)))
(bindings (nth expr 2))
(body (slice expr 3))
(params (list))
(inits (list)))
;; Parse bindings — Scheme-style ((name val) ...)
(for-each
(fn (b)
(let ((pname (if (= (type-of (first b)) "symbol")
(symbol-name (first b))
(str (first b)))))
(append! params (js-mangle pname))
(append! inits (js-expr (nth b 1)))))
bindings)
;; Emit body statements + return last
(let ((body-strs (list))
(mangled-name (js-mangle loop-name)))
(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 " mangled-name "(" (join ", " params) ") {\n"
(join "\n" body-strs)
"\n})(" (join ", " inits) ")")))))
(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-bind!")
(str "envBind(" (js-expr (nth expr 1))
", " (js-expr (nth expr 2))
", " (js-expr (nth expr 3)) ");")
(= 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))))
Reference in New Issue View Git Blame Copy Permalink