Compare commits
1 Commits
73810d249d
...
wasm
| Author | SHA1 | Date | |
|---|---|---|---|
| 0caa965de0 |
@@ -1,17 +0,0 @@
|
||||
---
|
||||
name: SX navigation single-source-of-truth
|
||||
description: Navigation must be defined once in nav-data.sx — no fragment URLs, no duplicated case statements, use make-page-fn for convention-based routing
|
||||
type: feedback
|
||||
---
|
||||
|
||||
Never use fragment URLs (#anchors) in the SX docs nav system. Every navigable item must have its own Lisp URL.
|
||||
|
||||
**Why:** Fragment URLs don't work with the SX URL routing system — fragments are client-side only and never reach the server, so nav resolution can't identify the current page.
|
||||
|
||||
**How to apply:**
|
||||
- `nav-data.sx` is the single source of truth for all navigation labels, hrefs, summaries, and hierarchy
|
||||
- `page-functions.sx` uses `make-page-fn` (convention-based) or `slug->component` to derive component names from slugs — no hand-written case statements for simple pages
|
||||
- Overview/index pages should generate link lists from nav-data variables (e.g. `reactive-examples-nav-items`) rather than hardcoding URLs
|
||||
- To add a new simple page: add nav item to nav-data.sx, create the component file. That's it — the naming convention handles routing.
|
||||
- Pages that need server-side data fetching (reference, spec, test, bootstrapper, isomorphism) still use custom functions with explicit case clauses
|
||||
- Legacy Python nav lists in `content/pages.py` have been removed — nav-data.sx is canonical
|
||||
@@ -1,5 +1,5 @@
|
||||
.git
|
||||
.gitea/workflows
|
||||
.gitea
|
||||
.env
|
||||
_snapshot
|
||||
docs
|
||||
|
||||
@@ -1,85 +0,0 @@
|
||||
# syntax=docker/dockerfile:1
|
||||
#
|
||||
# CI test image — Python 3 + Node.js + OCaml 5.2 + dune.
|
||||
#
|
||||
# Build chain:
|
||||
# 1. Compile OCaml from checked-in sx_ref.ml — produces sx_server.exe
|
||||
# 2. Bootstrap JS (sx-browser.js) — OcamlSync transpiler → JS
|
||||
# 3. Re-bootstrap OCaml (sx_ref.ml) — OcamlSync transpiler → OCaml
|
||||
# 4. Recompile OCaml with fresh sx_ref.ml — final native binary
|
||||
#
|
||||
# Test suites (run at CMD):
|
||||
# - JS standard + full tests — Node
|
||||
# - OCaml spec tests — native binary
|
||||
# - OCaml bridge integration tests — Python + OCaml subprocess
|
||||
#
|
||||
# Usage:
|
||||
# docker build -f .gitea/Dockerfile.test -t sx-test .
|
||||
# docker run --rm sx-test
|
||||
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2
|
||||
|
||||
USER root
|
||||
RUN apt-get update && apt-get install -y --no-install-recommends \
|
||||
python3 ca-certificates curl xz-utils \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
# Node.js — direct binary (avoids the massive Debian nodejs dep tree)
|
||||
RUN NODE_VERSION=22.22.1 \
|
||||
&& ARCH=$(dpkg --print-architecture | sed 's/amd64/x64/;s/arm64/arm64/;s/armhf/armv7l/') \
|
||||
&& curl -fsSL "https://nodejs.org/dist/v${NODE_VERSION}/node-v${NODE_VERSION}-linux-${ARCH}.tar.xz" \
|
||||
| tar -xJ --strip-components=1 -C /usr/local
|
||||
USER opam
|
||||
|
||||
# Install dune into the opam switch
|
||||
RUN opam install dune -y
|
||||
|
||||
# Bake the opam switch PATH into the image so dune/ocamlfind work in RUN
|
||||
ENV PATH="/home/opam/.opam/5.2/bin:${PATH}"
|
||||
|
||||
WORKDIR /home/opam/project
|
||||
|
||||
# Copy OCaml sources first (changes less often → better caching)
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./hosts/ocaml/
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./hosts/ocaml/lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/ ./hosts/ocaml/bin/
|
||||
|
||||
# Copy spec, lib, web, shared (needed by bootstrappers + tests)
|
||||
COPY --chown=opam:opam spec/ ./spec/
|
||||
COPY --chown=opam:opam lib/ ./lib/
|
||||
COPY --chown=opam:opam web/ ./web/
|
||||
COPY --chown=opam:opam shared/sx/ ./shared/sx/
|
||||
COPY --chown=opam:opam shared/__init__.py ./shared/__init__.py
|
||||
|
||||
# Copy JS host (bootstrapper + test runner)
|
||||
COPY --chown=opam:opam hosts/javascript/ ./hosts/javascript/
|
||||
|
||||
# Copy OCaml host (bootstrapper + transpiler)
|
||||
COPY --chown=opam:opam hosts/ocaml/bootstrap.py ./hosts/ocaml/bootstrap.py
|
||||
COPY --chown=opam:opam hosts/ocaml/transpiler.sx ./hosts/ocaml/transpiler.sx
|
||||
|
||||
# Create output directory for JS builds
|
||||
RUN mkdir -p shared/static/scripts
|
||||
|
||||
# Step 1: Compile OCaml from checked-in sx_ref.ml
|
||||
# → produces sx_server.exe (needed by both JS and OCaml bootstrappers)
|
||||
RUN cd hosts/ocaml && dune build
|
||||
|
||||
# Step 2: Bootstrap JS (uses sx_server.exe via OcamlSync)
|
||||
RUN python3 hosts/javascript/cli.py \
|
||||
--output shared/static/scripts/sx-browser.js \
|
||||
&& python3 hosts/javascript/cli.py \
|
||||
--extensions continuations --spec-modules types \
|
||||
--output shared/static/scripts/sx-full-test.js
|
||||
|
||||
# Step 3: Re-bootstrap OCaml (transpile current spec → fresh sx_ref.ml)
|
||||
RUN python3 hosts/ocaml/bootstrap.py \
|
||||
--output hosts/ocaml/lib/sx_ref.ml
|
||||
|
||||
# Step 4: Recompile OCaml with freshly bootstrapped sx_ref.ml
|
||||
RUN cd hosts/ocaml && dune build
|
||||
|
||||
# Default: run all tests
|
||||
COPY --chown=opam:opam .gitea/run-ci-tests.sh ./run-ci-tests.sh
|
||||
RUN chmod +x run-ci-tests.sh
|
||||
|
||||
CMD ["./run-ci-tests.sh"]
|
||||
@@ -1,115 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# ===========================================================================
|
||||
# run-ci-tests.sh — CI test runner for SX language suite.
|
||||
#
|
||||
# Runs JS + OCaml tests. No Python evaluator (eliminated).
|
||||
# Exit non-zero if any suite fails.
|
||||
# ===========================================================================
|
||||
set -euo pipefail
|
||||
|
||||
FAILURES=()
|
||||
PASSES=()
|
||||
|
||||
run_suite() {
|
||||
local name="$1"
|
||||
shift
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " $name"
|
||||
echo "============================================================"
|
||||
if "$@"; then
|
||||
PASSES+=("$name")
|
||||
else
|
||||
FAILURES+=("$name")
|
||||
fi
|
||||
}
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 1. JS standard tests
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS standard (spec tests)" \
|
||||
node hosts/javascript/run_tests.js
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 2. JS full tests (continuations + types + VM)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS full (spec + continuations + types + VM)" \
|
||||
node hosts/javascript/run_tests.js --full
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 3. OCaml spec tests
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml (spec tests)" \
|
||||
hosts/ocaml/_build/default/bin/run_tests.exe
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 4. OCaml bridge integration (custom special forms, web-forms.sx)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml bridge — custom special forms + web-forms" \
|
||||
python3 -c "
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
bridge = OcamlSync()
|
||||
for f in ['spec/parser.sx', 'spec/render.sx', 'web/adapter-html.sx', 'web/adapter-sx.sx', 'web/web-forms.sx', 'lib/freeze.sx']:
|
||||
bridge.load(f)
|
||||
ok = 0; fail = 0
|
||||
def check(name, expr, expected=None):
|
||||
global ok, fail
|
||||
try:
|
||||
r = bridge.eval(expr)
|
||||
if expected is not None and r != expected:
|
||||
print(f' FAIL: {name}: expected {expected!r}, got {r!r}'); fail += 1
|
||||
else:
|
||||
print(f' PASS: {name}'); ok += 1
|
||||
except Exception as e:
|
||||
print(f' FAIL: {name}: {e}'); fail += 1
|
||||
|
||||
for form in ['defhandler', 'defquery', 'defaction', 'defpage', 'defrelation', 'defstyle', 'deftype', 'defeffect']:
|
||||
check(f'{form} registered', f'(has-key? *custom-special-forms* \"{form}\")', 'true')
|
||||
|
||||
check('deftype via eval', '(deftype test-t number)', 'nil')
|
||||
check('defeffect via eval', '(defeffect test-e)', 'nil')
|
||||
check('defstyle via eval', '(defstyle my-s \"bold\")', 'bold')
|
||||
check('defhandler via eval', '(has-key? (defhandler test-h (&key x) x) \"__type\")', 'true')
|
||||
|
||||
check('definition-form-extensions populated', '(> (len *definition-form-extensions*) 0)', 'true')
|
||||
check('RENDER_HTML_FORMS has defstyle', '(contains? RENDER_HTML_FORMS \"defstyle\")', 'true')
|
||||
|
||||
bridge2 = OcamlSync()
|
||||
bridge2.eval('(register-special-form! \"shadow-test\" (fn (args env) 42))')
|
||||
bridge2.load('spec/evaluator.sx')
|
||||
check('custom form survives evaluator.sx load',
|
||||
bridge2.eval('(has-key? *custom-special-forms* \"shadow-test\")'), 'true')
|
||||
bridge2.eval('(register-special-form! \"post-load\" (fn (args env) 99))')
|
||||
check('custom form callable after evaluator.sx load',
|
||||
bridge2.eval('(post-load 1)'), '99')
|
||||
|
||||
print(f'\nResults: {ok} passed, {fail} failed')
|
||||
import sys; sys.exit(1 if fail > 0 else 0)
|
||||
"
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# Summary
|
||||
# -------------------------------------------------------------------
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " CI TEST SUMMARY"
|
||||
echo "============================================================"
|
||||
for p in "${PASSES[@]}"; do
|
||||
echo " PASS: $p"
|
||||
done
|
||||
for f in "${FAILURES[@]}"; do
|
||||
echo " FAIL: $f"
|
||||
done
|
||||
echo "============================================================"
|
||||
|
||||
if [ ${#FAILURES[@]} -gt 0 ]; then
|
||||
echo ""
|
||||
echo " ${#FAILURES[@]} suite(s) FAILED"
|
||||
echo ""
|
||||
exit 1
|
||||
else
|
||||
echo ""
|
||||
echo " All ${#PASSES[@]} suites passed."
|
||||
echo ""
|
||||
exit 0
|
||||
fi
|
||||
@@ -1,4 +1,4 @@
|
||||
name: Test, Build, and Deploy
|
||||
name: Build and Deploy
|
||||
|
||||
on:
|
||||
push:
|
||||
@@ -10,7 +10,7 @@ env:
|
||||
BUILD_DIR: /root/rose-ash-ci
|
||||
|
||||
jobs:
|
||||
test-build-deploy:
|
||||
build-and-deploy:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
@@ -29,11 +29,12 @@ jobs:
|
||||
chmod 600 ~/.ssh/id_rsa
|
||||
ssh-keyscan -H "$DEPLOY_HOST" >> ~/.ssh/known_hosts 2>/dev/null || true
|
||||
|
||||
- name: Sync CI build directory
|
||||
- name: Build and deploy changed apps
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
# --- Build in isolated CI directory (never touch dev working tree) ---
|
||||
BUILD=${{ env.BUILD_DIR }}
|
||||
ORIGIN=\$(git -C ${{ env.APP_DIR }} remote get-url origin)
|
||||
if [ ! -d \"\$BUILD/.git\" ]; then
|
||||
@@ -42,31 +43,6 @@ jobs:
|
||||
cd \"\$BUILD\"
|
||||
git fetch origin
|
||||
git reset --hard origin/${{ github.ref_name }}
|
||||
"
|
||||
|
||||
- name: Test SX language suite
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
cd ${{ env.BUILD_DIR }}
|
||||
|
||||
echo '=== Building SX test image ==='
|
||||
docker build \
|
||||
-f .gitea/Dockerfile.test \
|
||||
-t sx-test:${{ github.sha }} \
|
||||
.
|
||||
|
||||
echo '=== Running SX tests ==='
|
||||
docker run --rm sx-test:${{ github.sha }}
|
||||
"
|
||||
|
||||
- name: Build and deploy changed apps
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
cd ${{ env.BUILD_DIR }}
|
||||
|
||||
# Detect changes using push event SHAs (not local checkout state)
|
||||
BEFORE='${{ github.event.before }}'
|
||||
|
||||
Binary file not shown.
10
deploy.sh
10
deploy.sh
@@ -53,10 +53,16 @@ fi
|
||||
echo "Building: ${BUILD[*]}"
|
||||
echo ""
|
||||
|
||||
# --- Run unit tests before deploying (skip Playwright — needs running server) ---
|
||||
if ! QUICK=true ./run-tests.sh; then
|
||||
# --- Run unit tests before deploying ---
|
||||
echo "=== Running unit tests ==="
|
||||
docker build -f test/Dockerfile.unit -t rose-ash-test-unit:latest . -q
|
||||
if ! docker run --rm rose-ash-test-unit:latest; then
|
||||
echo ""
|
||||
echo "Unit tests FAILED — aborting deploy."
|
||||
exit 1
|
||||
fi
|
||||
echo "Unit tests passed."
|
||||
echo ""
|
||||
|
||||
for app in "${BUILD[@]}"; do
|
||||
dir=$(_app_dir "$app")
|
||||
|
||||
@@ -16,10 +16,8 @@ services:
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_WASM: "1"
|
||||
SX_DEV: "1"
|
||||
OCAMLRUNPARAM: "b"
|
||||
ports:
|
||||
- "8013:8000"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
@@ -31,10 +29,6 @@ services:
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
# Spec + lib + web SX files (loaded by OCaml kernel)
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
# OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
|
||||
@@ -12,8 +12,6 @@ x-dev-env: &dev-env
|
||||
WORKERS: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
x-sibling-models: &sibling-models
|
||||
# Every app needs all sibling __init__.py + models/ for cross-domain SQLAlchemy imports
|
||||
@@ -46,10 +44,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./blog/alembic.ini:/app/blog/alembic.ini:ro
|
||||
- ./blog/alembic:/app/blog/alembic:ro
|
||||
- ./blog/app.py:/app/app.py
|
||||
@@ -89,10 +83,6 @@ services:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- /root/rose-ash/_snapshot:/app/_snapshot
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./market/alembic.ini:/app/market/alembic.ini:ro
|
||||
- ./market/alembic:/app/market/alembic:ro
|
||||
- ./market/app.py:/app/app.py
|
||||
@@ -131,10 +121,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./cart/alembic.ini:/app/cart/alembic.ini:ro
|
||||
- ./cart/alembic:/app/cart/alembic:ro
|
||||
- ./cart/app.py:/app/app.py
|
||||
@@ -173,10 +159,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./events/alembic.ini:/app/events/alembic.ini:ro
|
||||
- ./events/alembic:/app/events/alembic:ro
|
||||
- ./events/app.py:/app/app.py
|
||||
@@ -215,10 +197,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./federation/alembic.ini:/app/federation/alembic.ini:ro
|
||||
- ./federation/alembic:/app/federation/alembic:ro
|
||||
- ./federation/app.py:/app/app.py
|
||||
@@ -257,10 +235,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./account/alembic.ini:/app/account/alembic.ini:ro
|
||||
- ./account/alembic:/app/account/alembic:ro
|
||||
- ./account/app.py:/app/app.py
|
||||
@@ -299,10 +273,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./relations/alembic.ini:/app/relations/alembic.ini:ro
|
||||
- ./relations/alembic:/app/relations/alembic:ro
|
||||
- ./relations/app.py:/app/app.py
|
||||
@@ -334,10 +304,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./likes/alembic.ini:/app/likes/alembic.ini:ro
|
||||
- ./likes/alembic:/app/likes/alembic:ro
|
||||
- ./likes/app.py:/app/app.py
|
||||
@@ -369,10 +335,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./orders/alembic.ini:/app/orders/alembic.ini:ro
|
||||
- ./orders/alembic:/app/orders/alembic:ro
|
||||
- ./orders/app.py:/app/app.py
|
||||
@@ -407,10 +369,6 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./test/app.py:/app/app.py
|
||||
- ./test/sx:/app/sx
|
||||
- ./test/bp:/app/bp
|
||||
@@ -435,14 +393,9 @@ services:
|
||||
- "8012:8000"
|
||||
environment:
|
||||
<<: *dev-env
|
||||
SX_STANDALONE: "true"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
@@ -478,10 +431,6 @@ services:
|
||||
dockerfile: test/Dockerfile.unit
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag/core:/app/artdag/core
|
||||
- ./artdag/l1/tests:/app/artdag/l1/tests
|
||||
- ./artdag/l1/sexp_effects:/app/artdag/l1/sexp_effects
|
||||
@@ -507,10 +456,6 @@ services:
|
||||
dockerfile: test/Dockerfile.integration
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag:/app/artdag
|
||||
profiles:
|
||||
- test
|
||||
|
||||
@@ -58,8 +58,6 @@ x-app-env: &app-env
|
||||
EXTERNAL_INBOXES: "artdag|https://celery-artdag.rose-ash.com/inbox"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
services:
|
||||
blog:
|
||||
@@ -230,6 +228,8 @@ services:
|
||||
<<: *app-env
|
||||
REDIS_URL: redis://redis:6379/10
|
||||
WORKERS: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
db:
|
||||
image: postgres:16
|
||||
|
||||
@@ -20,8 +20,8 @@ _PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
if _PROJECT not in sys.path:
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
import tempfile
|
||||
from shared.sx.parser import serialize
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
from hosts.javascript.platform import (
|
||||
extract_defines,
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER, EXTENSION_NAMES,
|
||||
@@ -35,23 +35,29 @@ from hosts.javascript.platform import (
|
||||
)
|
||||
|
||||
|
||||
_bridge = None # cached OcamlSync instance
|
||||
_js_sx_env = None # cached
|
||||
|
||||
|
||||
def _get_bridge():
|
||||
"""Get or create the OCaml sync bridge with transpiler loaded."""
|
||||
global _bridge
|
||||
if _bridge is not None:
|
||||
return _bridge
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
_bridge = OcamlSync()
|
||||
_bridge.load(os.path.join(_HERE, "transpiler.sx"))
|
||||
return _bridge
|
||||
def load_js_sx() -> dict:
|
||||
"""Load js.sx into an evaluator environment and return it."""
|
||||
global _js_sx_env
|
||||
if _js_sx_env is not None:
|
||||
return _js_sx_env
|
||||
|
||||
js_sx_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(js_sx_path) as f:
|
||||
source = f.read()
|
||||
|
||||
def load_js_sx():
|
||||
"""Load js.sx transpiler into the OCaml kernel. Returns the bridge."""
|
||||
return _get_bridge()
|
||||
exprs = parse_all(source)
|
||||
|
||||
from shared.sx.ref.sx_ref import evaluate, make_env
|
||||
|
||||
env = make_env()
|
||||
for expr in exprs:
|
||||
evaluate(expr, env)
|
||||
|
||||
_js_sx_env = env
|
||||
return env
|
||||
|
||||
|
||||
def compile_ref_to_js(
|
||||
@@ -69,14 +75,16 @@ def compile_ref_to_js(
|
||||
spec_modules: List of spec modules (deps, router, signals). None = auto.
|
||||
"""
|
||||
from datetime import datetime, timezone
|
||||
from shared.sx.ref.sx_ref import evaluate
|
||||
|
||||
# Source directories: core spec, standard library, web framework
|
||||
ref_dir = os.path.join(_PROJECT, "shared", "sx", "ref")
|
||||
# Source directories: core spec, web framework, and legacy ref (for bootstrapper tools)
|
||||
_source_dirs = [
|
||||
os.path.join(_PROJECT, "spec"), # Core language spec
|
||||
os.path.join(_PROJECT, "lib"), # Standard library (stdlib, compiler, vm, ...)
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
os.path.join(_PROJECT, "spec"), # Core spec
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
ref_dir, # Legacy location (fallback)
|
||||
]
|
||||
bridge = _get_bridge()
|
||||
env = load_js_sx()
|
||||
|
||||
# Resolve adapter set
|
||||
if adapters is None:
|
||||
@@ -123,12 +131,7 @@ def compile_ref_to_js(
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
# stdlib.sx is loaded at runtime via eval, not transpiled —
|
||||
# transpiling it would shadow native PRIMITIVES in module scope.
|
||||
("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
("content.sx", "content (content-addressed computation)"),
|
||||
("render.sx", "render (core)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
]
|
||||
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set:
|
||||
@@ -211,16 +214,11 @@ def compile_ref_to_js(
|
||||
sx_defines = [[name, expr] for name, expr in defines]
|
||||
|
||||
parts.append(f"\n // === Transpiled from {label} ===\n")
|
||||
# Serialize defines to SX, write to temp file, load into OCaml kernel
|
||||
defines_sx = serialize(sx_defines)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
result = bridge.eval("(js-translate-file _defines)")
|
||||
env["_defines"] = sx_defines
|
||||
result = evaluate(
|
||||
[Symbol("js-translate-file"), Symbol("_defines")],
|
||||
env,
|
||||
)
|
||||
parts.append(result)
|
||||
|
||||
# Platform JS for selected adapters
|
||||
@@ -232,28 +230,6 @@ def compile_ref_to_js(
|
||||
if has_cek:
|
||||
parts.append(CEK_FIXUPS_JS)
|
||||
|
||||
# Load stdlib.sx via eval (NOT transpiled) so defines go into the eval
|
||||
# env, not the module scope. This prevents stdlib functions from
|
||||
# shadowing native PRIMITIVES aliases used by transpiled evaluator code.
|
||||
stdlib_path = _find_sx("stdlib.sx")
|
||||
if stdlib_path:
|
||||
with open(stdlib_path) as f:
|
||||
stdlib_src = f.read()
|
||||
# Escape for JS string literal
|
||||
stdlib_escaped = stdlib_src.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n")
|
||||
parts.append(f'\n // === stdlib.sx (eval\'d at runtime, not transpiled) ===')
|
||||
parts.append(f' (function() {{')
|
||||
parts.append(f' var src = "{stdlib_escaped}";')
|
||||
parts.append(f' var forms = sxParse(src);')
|
||||
parts.append(f' var tmpEnv = merge({{}}, PRIMITIVES);')
|
||||
parts.append(f' for (var i = 0; i < forms.length; i++) {{')
|
||||
parts.append(f' trampoline(evalExpr(forms[i], tmpEnv));')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' for (var k in tmpEnv) {{')
|
||||
parts.append(f' if (!PRIMITIVES[k]) PRIMITIVES[k] = tmpEnv[k];')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' }})();\n')
|
||||
|
||||
for name in ("dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set and name in adapter_platform:
|
||||
parts.append(adapter_platform[name])
|
||||
|
||||
@@ -13,14 +13,7 @@ from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, expr) for top-level forms.
|
||||
|
||||
Extracts (define name ...) forms with their name, plus selected
|
||||
non-define top-level expressions (e.g. register-special-form! calls)
|
||||
with a synthetic name for the comment.
|
||||
"""
|
||||
# Top-level calls that should be transpiled (not special forms)
|
||||
_TOPLEVEL_CALLS = {"register-special-form!"}
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
@@ -28,18 +21,12 @@ def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
elif expr[0].name in _TOPLEVEL_CALLS:
|
||||
# Top-level call expression (e.g. register-special-form!)
|
||||
call_name = expr[0].name
|
||||
defines.append((f"({call_name} ...)", expr))
|
||||
return defines
|
||||
|
||||
ADAPTER_FILES = {
|
||||
"parser": ("parser.sx", "parser"),
|
||||
"html": ("adapter-html.sx", "adapter-html"),
|
||||
"sx": ("adapter-sx.sx", "adapter-sx"),
|
||||
"dom-lib": ("lib/dom.sx", "lib/dom (DOM library)"),
|
||||
"browser-lib": ("lib/browser.sx", "lib/browser (browser API library)"),
|
||||
"dom": ("adapter-dom.sx", "adapter-dom"),
|
||||
"engine": ("engine.sx", "engine"),
|
||||
"orchestration": ("orchestration.sx","orchestration"),
|
||||
@@ -48,9 +35,6 @@ ADAPTER_FILES = {
|
||||
|
||||
# Dependencies
|
||||
ADAPTER_DEPS = {
|
||||
"dom-lib": [],
|
||||
"browser-lib": ["dom-lib"],
|
||||
"dom": ["dom-lib", "browser-lib"],
|
||||
"engine": ["dom"],
|
||||
"orchestration": ["engine", "dom"],
|
||||
"boot": ["dom", "engine", "orchestration", "parser"],
|
||||
@@ -63,12 +47,11 @@ SPEC_MODULES = {
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"vm": ("vm.sx", "vm (bytecode virtual machine)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types", "vm"]
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types"]
|
||||
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -300,11 +283,9 @@ ASYNC_IO_JS = '''
|
||||
if (hname === "map-indexed") return asyncRenderMapIndexed(expr, env, ns);
|
||||
if (hname === "for-each") return asyncRenderMap(expr, env, ns);
|
||||
|
||||
// define/defcomp/defmacro and custom special forms — eval for side effects
|
||||
// define/defcomp/defmacro — eval for side effects
|
||||
if (hname === "define" || hname === "defcomp" || hname === "defmacro" ||
|
||||
hname === "defstyle" || hname === "defhandler" ||
|
||||
hname === "deftype" || hname === "defeffect" ||
|
||||
(typeof _customSpecialForms !== "undefined" && _customSpecialForms[hname])) {
|
||||
hname === "defstyle" || hname === "defhandler") {
|
||||
trampoline(evalExpr(expr, env));
|
||||
return null;
|
||||
}
|
||||
@@ -1130,58 +1111,6 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["context"] = sxContext;
|
||||
PRIMITIVES["emit!"] = sxEmit;
|
||||
PRIMITIVES["emitted"] = sxEmitted;
|
||||
// Aliases for aser adapter (avoids CEK special form conflict on server)
|
||||
var scopeEmit = sxEmit;
|
||||
function scopePeek(name) {
|
||||
if (_scopeStacks[name] && _scopeStacks[name].length) {
|
||||
return _scopeStacks[name][_scopeStacks[name].length - 1].value;
|
||||
}
|
||||
return NIL;
|
||||
}
|
||||
PRIMITIVES["scope-emit!"] = scopeEmit;
|
||||
PRIMITIVES["scope-peek"] = scopePeek;
|
||||
PRIMITIVES["scope-emitted"] = sxEmitted;
|
||||
PRIMITIVES["scope-collected"] = sxCollected;
|
||||
PRIMITIVES["scope-clear-collected!"] = sxClearCollected;
|
||||
|
||||
// ---- VM stack primitives ----
|
||||
// The VM spec (vm.sx) requires these array-like operations.
|
||||
// In JS, a plain Array serves as the stack.
|
||||
PRIMITIVES["make-vm-stack"] = function(size) {
|
||||
var a = new Array(size);
|
||||
for (var i = 0; i < size; i++) a[i] = NIL;
|
||||
return a;
|
||||
};
|
||||
PRIMITIVES["vm-stack-get"] = function(stack, idx) { return stack[idx]; };
|
||||
PRIMITIVES["vm-stack-set!"] = function(stack, idx, value) { stack[idx] = value; return NIL; };
|
||||
PRIMITIVES["vm-stack-length"] = function(stack) { return stack.length; };
|
||||
PRIMITIVES["vm-stack-copy!"] = function(src, dst, count) {
|
||||
for (var i = 0; i < count; i++) dst[i] = src[i];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-primitive"] = function(name) {
|
||||
if (name in PRIMITIVES) return PRIMITIVES[name];
|
||||
throw new Error("VM undefined: " + name);
|
||||
};
|
||||
PRIMITIVES["call-primitive"] = function(name, args) {
|
||||
if (!(name in PRIMITIVES)) throw new Error("VM undefined: " + name);
|
||||
var fn = PRIMITIVES[name];
|
||||
return fn.apply(null, Array.isArray(args) ? args : []);
|
||||
};
|
||||
PRIMITIVES["primitive?"] = function(name) {
|
||||
return name in PRIMITIVES;
|
||||
};
|
||||
PRIMITIVES["set-nth!"] = function(lst, idx, val) {
|
||||
lst[idx] = val;
|
||||
return NIL;
|
||||
};
|
||||
|
||||
PRIMITIVES["env-parent"] = function(env) {
|
||||
if (env && Object.getPrototypeOf(env) !== Object.prototype &&
|
||||
Object.getPrototypeOf(env) !== null)
|
||||
return Object.getPrototypeOf(env);
|
||||
return NIL;
|
||||
};
|
||||
''',
|
||||
}
|
||||
# Modules to include by default (all)
|
||||
@@ -1220,7 +1149,6 @@ PLATFORM_JS_PRE = '''
|
||||
if (x._spread) return "spread";
|
||||
if (x._macro) return "macro";
|
||||
if (x._raw) return "raw-html";
|
||||
if (x._sx_expr) return "sx-expr";
|
||||
if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
|
||||
if (Array.isArray(x)) return "list";
|
||||
if (typeof x === "object") return "dict";
|
||||
@@ -1466,11 +1394,6 @@ PLATFORM_JS_POST = '''
|
||||
var get = PRIMITIVES["get"];
|
||||
var assoc = PRIMITIVES["assoc"];
|
||||
var range = PRIMITIVES["range"];
|
||||
var floor = PRIMITIVES["floor"];
|
||||
var pow = PRIMITIVES["pow"];
|
||||
var mod = PRIMITIVES["mod"];
|
||||
var indexOf_ = PRIMITIVES["index-of"];
|
||||
var hasKey = PRIMITIVES["has-key?"];
|
||||
function zip(a, b) { var r = []; for (var i = 0; i < Math.min(a.length, b.length); i++) r.push([a[i], b[i]]); return r; }
|
||||
function append_b(arr, x) { arr.push(x); return arr; }
|
||||
var apply = function(f, args) {
|
||||
@@ -1489,10 +1412,12 @@ PLATFORM_JS_POST = '''
|
||||
var dict_fn = PRIMITIVES["dict"];
|
||||
|
||||
// HTML rendering helpers
|
||||
// escape-html and escape-attr are now library functions defined in render.sx
|
||||
function escapeHtml(s) {
|
||||
return String(s).replace(/&/g,"&").replace(/</g,"<").replace(/>/g,">").replace(/"/g,""");
|
||||
}
|
||||
function escapeAttr(s) { return escapeHtml(s); }
|
||||
function rawHtmlContent(r) { return r.html; }
|
||||
function makeRawHtml(s) { return { _raw: true, html: s }; }
|
||||
function makeSxExpr(s) { return { _sx_expr: true, source: s }; }
|
||||
function sxExprSource(x) { return x && x.source ? x.source : String(x); }
|
||||
|
||||
// Placeholders — overridden by transpiled spec from parser.sx / adapter-sx.sx
|
||||
@@ -1500,102 +1425,11 @@ PLATFORM_JS_POST = '''
|
||||
function isSpecialForm(n) { return false; }
|
||||
function isHoForm(n) { return false; }
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// Host FFI — the irreducible web platform primitives
|
||||
// All DOM/browser operations are built on these in web/lib/dom.sx
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["host-global"] = function(name) {
|
||||
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||
if (typeof window !== "undefined" && name in window) return window[name];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-get"] = function(obj, prop) {
|
||||
if (obj == null || obj === NIL) return NIL;
|
||||
var v = obj[prop];
|
||||
return v === undefined || v === null ? NIL : v;
|
||||
};
|
||||
PRIMITIVES["host-set!"] = function(obj, prop, val) {
|
||||
if (obj != null && obj !== NIL) obj[prop] = val === NIL ? null : val;
|
||||
};
|
||||
PRIMITIVES["host-call"] = function() {
|
||||
var obj = arguments[0], method = arguments[1];
|
||||
var args = [];
|
||||
for (var i = 2; i < arguments.length; i++) {
|
||||
var a = arguments[i];
|
||||
args.push(a === NIL ? null : a);
|
||||
}
|
||||
if (obj == null || obj === NIL) {
|
||||
// Global function call
|
||||
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
|
||||
if (typeof fn === "function") return fn.apply(null, args);
|
||||
return NIL;
|
||||
}
|
||||
if (typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, args); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-new"] = function() {
|
||||
var name = arguments[0];
|
||||
var args = Array.prototype.slice.call(arguments, 1).map(function(a) { return a === NIL ? null : a; });
|
||||
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
|
||||
if (typeof Ctor !== "function") return NIL;
|
||||
// Support 0-4 args (covers all practical cases)
|
||||
switch (args.length) {
|
||||
case 0: return new Ctor();
|
||||
case 1: return new Ctor(args[0]);
|
||||
case 2: return new Ctor(args[0], args[1]);
|
||||
case 3: return new Ctor(args[0], args[1], args[2]);
|
||||
default: return new Ctor(args[0], args[1], args[2], args[3]);
|
||||
}
|
||||
};
|
||||
PRIMITIVES["host-callback"] = function(fn) {
|
||||
// Wrap SX function/lambda as a native JS callback
|
||||
if (typeof fn === "function") return fn;
|
||||
if (fn && fn._type === "lambda") {
|
||||
return function() {
|
||||
var a = Array.prototype.slice.call(arguments);
|
||||
return cekCall(fn, a);
|
||||
};
|
||||
}
|
||||
return function() {};
|
||||
};
|
||||
PRIMITIVES["host-typeof"] = function(obj) {
|
||||
if (obj == null || obj === NIL) return "nil";
|
||||
if (obj instanceof Element) return "element";
|
||||
if (obj instanceof Text) return "text";
|
||||
if (obj instanceof DocumentFragment) return "fragment";
|
||||
if (obj instanceof Document) return "document";
|
||||
if (obj instanceof Event) return "event";
|
||||
if (obj instanceof Promise) return "promise";
|
||||
if (obj instanceof AbortController) return "abort-controller";
|
||||
return typeof obj;
|
||||
};
|
||||
PRIMITIVES["host-await"] = function(promise, callback) {
|
||||
if (promise && typeof promise.then === "function") {
|
||||
var cb = typeof callback === "function" ? callback :
|
||||
(callback && callback._type === "lambda") ?
|
||||
function(v) { return cekCall(callback, [v]); } : function() {};
|
||||
promise.then(cb);
|
||||
}
|
||||
};
|
||||
// Aliases for transpiled dom.sx / browser.sx code (transpiler mangles host-* names)
|
||||
var hostGlobal = PRIMITIVES["host-global"];
|
||||
var hostGet = PRIMITIVES["host-get"];
|
||||
var hostSet = PRIMITIVES["host-set!"];
|
||||
var hostCall = PRIMITIVES["host-call"];
|
||||
var hostNew = PRIMITIVES["host-new"];
|
||||
var hostCallback = PRIMITIVES["host-callback"];
|
||||
var hostTypeof = PRIMITIVES["host-typeof"];
|
||||
var hostAwait = PRIMITIVES["host-await"];
|
||||
|
||||
// processBindings and evalCond — now specced in render.sx, bootstrapped above
|
||||
|
||||
function isDefinitionForm(name) {
|
||||
return name === "define" || name === "defcomp" || name === "defmacro" ||
|
||||
name === "defstyle" || name === "defhandler" ||
|
||||
name === "deftype" || name === "defeffect";
|
||||
name === "defstyle" || name === "defhandler";
|
||||
}
|
||||
|
||||
function indexOf_(s, ch) {
|
||||
@@ -1730,8 +1564,21 @@ CEK_FIXUPS_JS = '''
|
||||
PRIMITIVES["island?"] = isIsland;
|
||||
PRIMITIVES["make-symbol"] = function(n) { return new Symbol(n); };
|
||||
PRIMITIVES["is-html-tag?"] = function(n) { return HTML_TAGS.indexOf(n) >= 0; };
|
||||
function makeEnv() { return merge(componentEnv, PRIMITIVES); }
|
||||
PRIMITIVES["make-env"] = makeEnv;
|
||||
PRIMITIVES["make-env"] = function() { return merge(componentEnv, PRIMITIVES); };
|
||||
|
||||
// localStorage — defined here (before boot) so islands can use at hydration
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
'''
|
||||
|
||||
|
||||
@@ -1840,7 +1687,7 @@ PLATFORM_PARSER_JS = r"""
|
||||
function escapeString(s) {
|
||||
return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t");
|
||||
}
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : (e && e.source ? e.source : String(e)); }
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : String(e); }
|
||||
var charFromCode = PRIMITIVES["char-from-code"];
|
||||
"""
|
||||
|
||||
@@ -1856,11 +1703,6 @@ PLATFORM_DOM_JS = """
|
||||
_renderExprFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
_renderMode = true; // Browser always evaluates in render context.
|
||||
|
||||
// Wire CEK render hooks — evaluator checks _renderCheck/_renderFn instead of
|
||||
// the old renderActiveP()/isRenderExpr()/renderExpr() triple.
|
||||
_renderCheck = function(expr, env) { return _renderMode && isRenderExpr(expr); };
|
||||
_renderFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
var MATH_NS = "http://www.w3.org/1998/Math/MathML";
|
||||
|
||||
@@ -2027,14 +1869,12 @@ PLATFORM_DOM_JS = """
|
||||
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
|
||||
var wrapped = isLambda(handler)
|
||||
? (lambdaParams(handler).length === 0
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } })
|
||||
: handler;
|
||||
if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
|
||||
var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
|
||||
var opts = passiveEvents[name] ? { passive: true } : undefined;
|
||||
el.addEventListener(name, wrapped, opts);
|
||||
return function() { el.removeEventListener(name, wrapped, opts); };
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
}
|
||||
|
||||
function eventDetail(e) {
|
||||
@@ -2348,10 +2188,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
}
|
||||
}
|
||||
});
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:popstate fetch error " + url + " — " + (err && err.message ? err.message : err));
|
||||
location.reload();
|
||||
});
|
||||
}).catch(function() { location.reload(); });
|
||||
}
|
||||
|
||||
function fetchStreaming(target, url, headers) {
|
||||
@@ -2489,9 +2326,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
return resp.text().then(function(text) {
|
||||
preloadCacheSet(cache, url, text, ct);
|
||||
});
|
||||
}).catch(function(err) {
|
||||
logInfo("sx:preload error " + url + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
}).catch(function() { /* ignore */ });
|
||||
}
|
||||
|
||||
// --- Request body building ---
|
||||
@@ -2656,7 +2491,6 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function preventDefault_(e) { if (e && e.preventDefault) e.preventDefault(); }
|
||||
function stopPropagation_(e) { if (e && e.stopPropagation) e.stopPropagation(); }
|
||||
function eventModifierKey_p(e) { return !!(e && (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey)); }
|
||||
function domFocus(el) { if (el && el.focus) el.focus(); }
|
||||
function tryCatch(tryFn, catchFn) {
|
||||
var t = _wrapSxFn(tryFn);
|
||||
@@ -2760,7 +2594,6 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindBoostLink(el, _href) {
|
||||
el.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = el.getAttribute("href") || _href;
|
||||
@@ -2782,8 +2615,6 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
var liveAction = form.getAttribute("action") || _action || location.href;
|
||||
executeRequest(form, { method: liveMethod, url: liveAction }).then(function() {
|
||||
try { history.pushState({ sxUrl: liveAction, scrollY: window.scrollY }, "", liveAction); } catch (err) {}
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:boost form error " + liveMethod + " " + liveAction + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
});
|
||||
}
|
||||
@@ -2792,7 +2623,6 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindClientRouteClick(link, _href, fallbackFn) {
|
||||
link.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = link.getAttribute("href") || _href;
|
||||
@@ -2943,7 +2773,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
} else {
|
||||
fn();
|
||||
}
|
||||
}, { passive: true });
|
||||
});
|
||||
});
|
||||
}
|
||||
|
||||
@@ -2953,7 +2783,6 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function markProcessed(el, key) { el[PROCESSED + key] = true; }
|
||||
function isProcessed(el, key) { return !!el[PROCESSED + key]; }
|
||||
function clearProcessed(el, key) { delete el[PROCESSED + key]; }
|
||||
|
||||
// --- Script cloning ---
|
||||
|
||||
@@ -3207,37 +3036,57 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
return _rawCallLambda(f, args, callerEnv);
|
||||
};
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// Core primitives that require native JS (cannot be expressed via FFI)
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
|
||||
// FFI library functions — defined in dom.sx/browser.sx but not transpiled.
|
||||
// Registered here so runtime-evaluated SX code (data-init, islands) can use them.
|
||||
PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
// Expose render functions as primitives so SX code can call them''']
|
||||
if has_html:
|
||||
lines.append(' if (typeof renderToHtml === "function") PRIMITIVES["render-to-html"] = renderToHtml;')
|
||||
if has_sx:
|
||||
lines.append(' if (typeof renderToSx === "function") PRIMITIVES["render-to-sx"] = renderToSx;')
|
||||
lines.append(' if (typeof aser === "function") PRIMITIVES["aser"] = aser;')
|
||||
if has_dom:
|
||||
lines.append(' if (typeof renderToDom === "function") PRIMITIVES["render-to-dom"] = renderToDom;')
|
||||
if has_signals:
|
||||
lines.append('''
|
||||
// Expose signal functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. island bodies from .sx files) can call them
|
||||
PRIMITIVES["signal"] = signal;
|
||||
PRIMITIVES["signal?"] = isSignal;
|
||||
PRIMITIVES["deref"] = deref;
|
||||
PRIMITIVES["reset!"] = reset_b;
|
||||
PRIMITIVES["swap!"] = swap_b;
|
||||
PRIMITIVES["computed"] = computed;
|
||||
PRIMITIVES["effect"] = effect;
|
||||
PRIMITIVES["batch"] = batch;
|
||||
// Timer primitives for island code
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
// Reactive DOM helpers for island code
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["resource"] = resource;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["def-store"] = defStore;
|
||||
PRIMITIVES["use-store"] = useStore;
|
||||
PRIMITIVES["emit-event"] = emitEvent;
|
||||
PRIMITIVES["on-event"] = onEvent;
|
||||
PRIMITIVES["bridge-event"] = bridgeEvent;
|
||||
// DOM primitives for island code
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["dom-call-method"] = domCallMethod;
|
||||
PRIMITIVES["dom-post-message"] = domPostMessage;
|
||||
PRIMITIVES["stop-propagation"] = stopPropagation_;
|
||||
PRIMITIVES["event-modifier-key?"] = eventModifierKey_p;
|
||||
PRIMITIVES["element-value"] = elementValue;
|
||||
PRIMITIVES["error-message"] = errorMessage;
|
||||
PRIMITIVES["schedule-idle"] = scheduleIdle;
|
||||
PRIMITIVES["console-log"] = function() {
|
||||
var args = Array.prototype.slice.call(arguments);
|
||||
console.log.apply(console, ["[sx]"].concat(args));
|
||||
return args.length > 0 ? args[0] : NIL;
|
||||
};
|
||||
PRIMITIVES["set-cookie"] = function(name, value, days) {
|
||||
var d = days || 365;
|
||||
var expires = new Date(Date.now() + d * 864e5).toUTCString();
|
||||
document.cookie = name + "=" + encodeURIComponent(value) + ";expires=" + expires + ";path=/;SameSite=Lax";
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-cookie"] = function(name) {
|
||||
var m = document.cookie.match(new RegExp("(?:^|;\\\\s*)" + name + "=([^;]*)"));
|
||||
return m ? decodeURIComponent(m[1]) : NIL;
|
||||
};
|
||||
|
||||
// dom.sx / browser.sx library functions — not transpiled, registered from
|
||||
// native platform implementations so runtime-eval'd SX code can use them.
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
PRIMITIVES["filter"] = filter;
|
||||
// DOM primitives for sx-on:* handlers and data-init scripts
|
||||
if (typeof domBody === "function") PRIMITIVES["dom-body"] = domBody;
|
||||
if (typeof domQuery === "function") PRIMITIVES["dom-query"] = domQuery;
|
||||
if (typeof domQueryAll === "function") PRIMITIVES["dom-query-all"] = domQueryAll;
|
||||
@@ -3251,6 +3100,8 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domHasClass === "function") PRIMITIVES["dom-has-class?"] = domHasClass;
|
||||
if (typeof domClosest === "function") PRIMITIVES["dom-closest"] = domClosest;
|
||||
if (typeof domMatches === "function") PRIMITIVES["dom-matches?"] = domMatches;
|
||||
if (typeof preventDefault_ === "function") PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
if (typeof elementValue === "function") PRIMITIVES["element-value"] = elementValue;
|
||||
if (typeof domOuterHtml === "function") PRIMITIVES["dom-outer-html"] = domOuterHtml;
|
||||
if (typeof domInnerHtml === "function") PRIMITIVES["dom-inner-html"] = domInnerHtml;
|
||||
if (typeof domTextContent === "function") PRIMITIVES["dom-text-content"] = domTextContent;
|
||||
@@ -3259,43 +3110,52 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domAppendToHead === "function") PRIMITIVES["dom-append-to-head"] = domAppendToHead;
|
||||
if (typeof jsonParse === "function") PRIMITIVES["json-parse"] = jsonParse;
|
||||
if (typeof nowMs === "function") PRIMITIVES["now-ms"] = nowMs;
|
||||
PRIMITIVES["log-info"] = logInfo;
|
||||
PRIMITIVES["log-warn"] = logWarn;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;''']
|
||||
PRIMITIVES["sx-parse"] = sxParse;
|
||||
PRIMITIVES["console-log"] = function() { console.log.apply(console, ["[sx]"].concat(Array.prototype.slice.call(arguments))); return arguments.length > 0 ? arguments[0] : NIL; };''')
|
||||
if has_deps:
|
||||
lines.append('''
|
||||
// Platform deps functions (native JS, not transpiled — need explicit registration)
|
||||
// Expose deps module functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. test-deps.sx in browser) can call them
|
||||
// Platform functions (from PLATFORM_DEPS_JS)
|
||||
PRIMITIVES["component-deps"] = componentDeps;
|
||||
PRIMITIVES["component-set-deps!"] = componentSetDeps;
|
||||
PRIMITIVES["component-css-classes"] = componentCssClasses;
|
||||
PRIMITIVES["env-components"] = envComponents;
|
||||
PRIMITIVES["regex-find-all"] = regexFindAll;
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;''')
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;
|
||||
// Transpiled functions (from deps.sx)
|
||||
PRIMITIVES["scan-refs"] = scanRefs;
|
||||
PRIMITIVES["scan-refs-walk"] = scanRefsWalk;
|
||||
PRIMITIVES["transitive-deps"] = transitiveDeps;
|
||||
PRIMITIVES["transitive-deps-walk"] = transitiveDepsWalk;
|
||||
PRIMITIVES["compute-all-deps"] = computeAllDeps;
|
||||
PRIMITIVES["scan-components-from-source"] = scanComponentsFromSource;
|
||||
PRIMITIVES["components-needed"] = componentsNeeded;
|
||||
PRIMITIVES["page-component-bundle"] = pageComponentBundle;
|
||||
PRIMITIVES["page-css-classes"] = pageCssClasses;
|
||||
PRIMITIVES["scan-io-refs-walk"] = scanIoRefsWalk;
|
||||
PRIMITIVES["scan-io-refs"] = scanIoRefs;
|
||||
PRIMITIVES["transitive-io-refs-walk"] = transitiveIoRefsWalk;
|
||||
PRIMITIVES["transitive-io-refs"] = transitiveIoRefs;
|
||||
PRIMITIVES["compute-all-io-refs"] = computeAllIoRefs;
|
||||
PRIMITIVES["component-io-refs-cached"] = componentIoRefsCached;
|
||||
PRIMITIVES["component-pure?"] = componentPure_p;
|
||||
PRIMITIVES["render-target"] = renderTarget;
|
||||
PRIMITIVES["page-render-plan"] = pageRenderPlan;''')
|
||||
if has_page_helpers:
|
||||
lines.append('''
|
||||
// Expose page-helper functions as primitives
|
||||
PRIMITIVES["categorize-special-forms"] = categorizeSpecialForms;
|
||||
PRIMITIVES["extract-define-kwargs"] = extractDefineKwargs;
|
||||
PRIMITIVES["build-reference-data"] = buildReferenceData;
|
||||
PRIMITIVES["build-ref-items-with-href"] = buildRefItemsWithHref;
|
||||
PRIMITIVES["build-attr-detail"] = buildAttrDetail;
|
||||
PRIMITIVES["build-header-detail"] = buildHeaderDetail;
|
||||
PRIMITIVES["build-event-detail"] = buildEventDetail;
|
||||
PRIMITIVES["build-component-source"] = buildComponentSource;
|
||||
PRIMITIVES["build-bundle-analysis"] = buildBundleAnalysis;
|
||||
PRIMITIVES["build-routing-analysis"] = buildRoutingAnalysis;
|
||||
PRIMITIVES["build-affinity-analysis"] = buildAffinityAnalysis;''')
|
||||
return "\n".join(lines)
|
||||
|
||||
|
||||
|
||||
@@ -81,7 +81,6 @@ env["env-extend"] = function(e) { return Object.create(e); };
|
||||
env["env-merge"] = function(a, b) { return Object.assign({}, a, b); };
|
||||
|
||||
// Missing primitives referenced by tests
|
||||
// primitive? is now in platform.py PRIMITIVES
|
||||
env["upcase"] = function(s) { return s.toUpperCase(); };
|
||||
env["downcase"] = function(s) { return s.toLowerCase(); };
|
||||
env["make-keyword"] = function(name) { return new Sx.Keyword(name); };
|
||||
@@ -219,19 +218,6 @@ env["component-has-children"] = function(c) {
|
||||
return c && c.has_children ? c.has_children : false;
|
||||
};
|
||||
|
||||
// Aser test helper: parse SX source, evaluate via aser, return wire format string
|
||||
env["render-sx"] = function(source) {
|
||||
const exprs = Sx.parse(source);
|
||||
const parts = [];
|
||||
for (const expr of exprs) {
|
||||
const result = Sx.renderToSx(expr, env);
|
||||
if (result !== null && result !== undefined && result !== Sx.NIL) {
|
||||
parts.push(typeof result === "string" ? result : Sx.serialize(result));
|
||||
}
|
||||
}
|
||||
return parts.join("");
|
||||
};
|
||||
|
||||
// Platform test functions
|
||||
env["try-call"] = function(thunk) {
|
||||
try {
|
||||
@@ -270,7 +256,6 @@ env["pop-suite"] = function() {
|
||||
// Load test framework
|
||||
const projectDir = path.join(__dirname, "..", "..");
|
||||
const specTests = path.join(projectDir, "spec", "tests");
|
||||
const libTests = path.join(projectDir, "lib", "tests");
|
||||
const webTests = path.join(projectDir, "web", "tests");
|
||||
|
||||
const frameworkSrc = fs.readFileSync(path.join(specTests, "test-framework.sx"), "utf8");
|
||||
@@ -279,52 +264,31 @@ for (const expr of frameworkExprs) {
|
||||
Sx.eval(expr, env);
|
||||
}
|
||||
|
||||
// Load compiler + VM from lib/ when running full tests
|
||||
if (fullBuild) {
|
||||
const libDir = path.join(projectDir, "lib");
|
||||
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx"]) {
|
||||
const libPath = path.join(libDir, libFile);
|
||||
if (fs.existsSync(libPath)) {
|
||||
const src = fs.readFileSync(libPath, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading ${libFile}: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Determine which tests to run
|
||||
const args = process.argv.slice(2).filter(a => !a.startsWith("--"));
|
||||
let testFiles = [];
|
||||
|
||||
if (args.length > 0) {
|
||||
// Specific test files — search spec, lib, and web test dirs
|
||||
// Specific test files
|
||||
for (const arg of args) {
|
||||
const name = arg.endsWith(".sx") ? arg : `${arg}.sx`;
|
||||
const specPath = path.join(specTests, name);
|
||||
const libPath = path.join(libTests, name);
|
||||
const webPath = path.join(webTests, name);
|
||||
if (fs.existsSync(specPath)) testFiles.push(specPath);
|
||||
else if (fs.existsSync(libPath)) testFiles.push(libPath);
|
||||
else if (fs.existsSync(webPath)) testFiles.push(webPath);
|
||||
else console.error(`Test file not found: ${name}`);
|
||||
}
|
||||
} else {
|
||||
// All spec tests (core language — always run)
|
||||
// Tests requiring optional modules (only run with --full)
|
||||
const requiresFull = new Set(["test-continuations.sx", "test-types.sx", "test-freeze.sx"]);
|
||||
// All spec tests
|
||||
for (const f of fs.readdirSync(specTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx") && f !== "test-framework.sx") {
|
||||
testFiles.push(path.join(specTests, f));
|
||||
}
|
||||
}
|
||||
// Library tests (only with --full — require compiler, vm, signals, etc.)
|
||||
if (fullBuild) {
|
||||
for (const f of fs.readdirSync(libTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx")) {
|
||||
testFiles.push(path.join(libTests, f));
|
||||
if (!fullBuild && requiresFull.has(f)) {
|
||||
console.log(`Skipping ${f} (requires --full)`);
|
||||
continue;
|
||||
}
|
||||
testFiles.push(path.join(specTests, f));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@@ -54,8 +54,6 @@
|
||||
"make-action-def" "makeActionDef"
|
||||
"make-page-def" "makePageDef"
|
||||
"make-symbol" "makeSymbol"
|
||||
"make-env" "makeEnv"
|
||||
"make-sx-expr" "makeSxExpr"
|
||||
"make-keyword" "makeKeyword"
|
||||
"lambda-params" "lambdaParams"
|
||||
"lambda-body" "lambdaBody"
|
||||
@@ -95,25 +93,6 @@
|
||||
"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"
|
||||
@@ -165,7 +144,6 @@
|
||||
"aser-special" "aserSpecial"
|
||||
"eval-case-aser" "evalCaseAser"
|
||||
"sx-serialize" "sxSerialize"
|
||||
|
||||
"sx-serialize-dict" "sxSerializeDict"
|
||||
"sx-expr-source" "sxExprSource"
|
||||
"sf-if" "sfIf"
|
||||
@@ -203,6 +181,7 @@
|
||||
"ho-some" "hoSome"
|
||||
"ho-every" "hoEvery"
|
||||
"ho-for-each" "hoForEach"
|
||||
"sf-defstyle" "sfDefstyle"
|
||||
"kf-name" "kfName"
|
||||
"special-form?" "isSpecialForm"
|
||||
"ho-form?" "isHoForm"
|
||||
@@ -423,7 +402,6 @@
|
||||
"bind-preload" "bindPreload"
|
||||
"mark-processed!" "markProcessed"
|
||||
"is-processed?" "isProcessed"
|
||||
"clear-processed!" "clearProcessed"
|
||||
"create-script-clone" "createScriptClone"
|
||||
"sx-render" "sxRender"
|
||||
"sx-process-scripts" "sxProcessScripts"
|
||||
@@ -623,9 +601,6 @@
|
||||
"cond-scheme?" "condScheme_p"
|
||||
"scope-push!" "scopePush"
|
||||
"scope-pop!" "scopePop"
|
||||
"scope-emit!" "scopeEmit"
|
||||
"scope-emitted" "sxEmitted"
|
||||
"scope-peek" "scopePeek"
|
||||
"provide-push!" "providePush"
|
||||
"provide-pop!" "providePop"
|
||||
"context" "sxContext"
|
||||
@@ -932,11 +907,8 @@
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
(if (= (type-of head) "list")
|
||||
;; Head is a sub-expression (call) — emit as function call: (head)(args)
|
||||
(str "(" (js-expr head) ")(" (join ", " (map js-expr args)) ")")
|
||||
;; Data list — not a function call
|
||||
(str "[" (join ", " (map js-expr expr)) "]"))
|
||||
;; Data list — not a function call
|
||||
(str "[" (join ", " (map js-expr expr)) "]")
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; fn/lambda
|
||||
@@ -1125,50 +1097,19 @@
|
||||
|
||||
(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) ")")))))
|
||||
(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)
|
||||
|
||||
@@ -1,25 +0,0 @@
|
||||
# OCaml SX kernel build image.
|
||||
#
|
||||
# Produces a statically-linked sx_server binary that can be COPY'd
|
||||
# into any service's Docker image.
|
||||
#
|
||||
# Usage:
|
||||
# docker build -t sx-kernel -f hosts/ocaml/Dockerfile .
|
||||
# docker build --target=export -o hosts/ocaml/_build/export -f hosts/ocaml/Dockerfile .
|
||||
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2 AS build
|
||||
|
||||
USER opam
|
||||
WORKDIR /home/opam/sx
|
||||
|
||||
# Copy only what's needed for the OCaml build
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/ ./bin/
|
||||
|
||||
# Build the server binary
|
||||
RUN eval $(opam env) && dune build bin/sx_server.exe
|
||||
|
||||
# Export stage — just the binary
|
||||
FROM scratch AS export
|
||||
COPY --from=build /home/opam/sx/_build/default/bin/sx_server.exe /sx_server
|
||||
@@ -1,6 +1,6 @@
|
||||
module T = Sx.Sx_types
|
||||
module P = Sx.Sx_parser
|
||||
module R = Sx.Sx_ref
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
|
||||
@@ -1,3 +1,3 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
(names run_tests debug_set sx_server)
|
||||
(libraries sx))
|
||||
|
||||
@@ -1,521 +0,0 @@
|
||||
(** Integration tests — exercises the full rendering pipeline.
|
||||
|
||||
Loads spec files + web adapters into a server-like env, then renders
|
||||
HTML expressions. Catches "Undefined symbol" errors that only surface
|
||||
when the full stack is loaded (not caught by spec unit tests).
|
||||
|
||||
Usage:
|
||||
dune exec bin/integration_tests.exe *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if expected = actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s\n expected: %s\n got: %s\n%!" name expected actual
|
||||
end
|
||||
|
||||
let assert_contains name needle haystack =
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in
|
||||
if String.length needle > 0 && find 0 then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected to contain %S in %S\n%!" name needle haystack
|
||||
end
|
||||
|
||||
let assert_no_error name f =
|
||||
try
|
||||
ignore (f ());
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name (Printexc.to_string exn)
|
||||
|
||||
(* Build a server-like env with rendering support *)
|
||||
let make_integration_env () =
|
||||
let env = make_env () in
|
||||
let bind (n : string) fn =
|
||||
ignore (Sx_types.env_bind env n (NativeFn (n, fn)))
|
||||
in
|
||||
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* HTML tag functions — same as sx_server.ml *)
|
||||
List.iter (fun tag ->
|
||||
ignore (env_bind env tag
|
||||
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
||||
) Sx_render.html_tags;
|
||||
|
||||
(* Platform primitives needed by spec/render.sx and adapters *)
|
||||
bind "make-raw-html" (fun args ->
|
||||
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
|
||||
bind "raw-html-content" (fun args ->
|
||||
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
|
||||
bind "escape-html" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-attr" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-string" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "is-html-tag?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
||||
bind "is-void-element?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_void s) | _ -> Bool false);
|
||||
bind "is-boolean-attr?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_boolean_attr s) | _ -> Bool false);
|
||||
|
||||
(* Mutable operations needed by adapter code *)
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
bind "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
|
||||
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
|
||||
| _ -> Nil);
|
||||
bind "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (Hashtbl.mem d k)
|
||||
| [Dict d; Keyword k] -> Bool (Hashtbl.mem d k)
|
||||
| _ -> Bool false);
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| _ -> Nil);
|
||||
bind "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
bind "mutable-list" (fun _args -> ListRef (ref []));
|
||||
|
||||
(* Symbol/keyword accessors needed by adapter-html.sx *)
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with [String s] -> Symbol s | _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* Type predicates needed by adapters *)
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args -> match args with [Component _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] -> let d = Hashtbl.create 8 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
|
||||
| _ -> Nil);
|
||||
bind "component-name" (fun args -> match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil);
|
||||
bind "component-params" (fun args -> match args with [Component c] -> List (List.map (fun s -> String s) c.c_params) | _ -> List []);
|
||||
bind "component-body" (fun args -> match args with [Component c] -> c.c_body | _ -> Nil);
|
||||
bind "component-closure" (fun args -> match args with [Component c] -> Env c.c_closure | _ -> Nil);
|
||||
bind "component-has-children?" (fun args -> match args with [Component c] -> Bool c.c_has_children | _ -> Bool false);
|
||||
bind "component-affinity" (fun args -> match args with [Component c] -> String c.c_affinity | _ -> String "auto");
|
||||
bind "lambda-params" (fun args -> match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
bind "lambda-name" (fun args -> match args with [Lambda l] -> (match l.l_name with Some n -> String n | None -> Nil) | _ -> Nil);
|
||||
bind "set-lambda-name!" (fun args -> match args with [Lambda l; String n] -> l.l_name <- Some n; Nil | _ -> Nil);
|
||||
|
||||
(* Environment operations *)
|
||||
bind "env-extend" (fun args ->
|
||||
match args with [Env e] -> Env (env_extend e) | _ -> Env (env_extend env));
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_bind e k v | _ -> Nil);
|
||||
bind "env-set!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_set e k v | _ -> Nil);
|
||||
bind "env-get" (fun args ->
|
||||
match args with [Env e; String k] -> env_get e k | _ -> Nil);
|
||||
bind "env-has?" (fun args ->
|
||||
match args with [Env e; String k] -> Bool (env_has e k) | _ -> Bool false);
|
||||
bind "env-merge" (fun args ->
|
||||
match args with [Env a; Env b] -> Env (env_merge a b) | _ -> Nil);
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
(* Eval/trampoline — needed by adapters *)
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| _ -> Nil);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (e, env)] -> Sx_ref.eval_expr e (Env env)
|
||||
| [v] -> v | _ -> Nil);
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [f; List a] -> Sx_runtime.sx_call f a
|
||||
| [f; a] -> Sx_runtime.sx_call f [a]
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; _env] ->
|
||||
let local = env_extend m.m_closure in
|
||||
let rec bind_params ps as' = match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with Some rp -> ignore (env_bind local rp (List rest)) | None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a); bind_params ps_rest as_rest
|
||||
| _ :: _, [] -> ()
|
||||
in
|
||||
bind_params m.m_params macro_args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
| _ -> Nil);
|
||||
|
||||
(* Scope/provide — needed by adapter-html.sx and the CEK evaluator.
|
||||
Must be registered as primitives (prim_call) not just env bindings. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_emitted : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_push name v =
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (v :: stack); Nil in
|
||||
let scope_pop name =
|
||||
(match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (_ :: rest) -> Hashtbl.replace scope_stacks name rest
|
||||
| _ -> ()); Nil in
|
||||
let scope_peek name =
|
||||
match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (v :: _) -> v | _ -> Nil in
|
||||
let scope_emit name v =
|
||||
let items = try Hashtbl.find scope_emitted name with Not_found -> [] in
|
||||
Hashtbl.replace scope_emitted name (items @ [v]); Nil in
|
||||
let emitted name =
|
||||
match Hashtbl.find_opt scope_emitted name with Some l -> List l | None -> List [] in
|
||||
(* Register as both env bindings AND primitives *)
|
||||
bind "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
bind "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "collect!" (fun _args -> Nil);
|
||||
bind "collected" (fun _args -> List []);
|
||||
bind "clear-collected!" (fun _args -> Nil);
|
||||
bind "scope-collected" (fun _args -> List []);
|
||||
bind "scope-clear-collected!" (fun _args -> Nil);
|
||||
bind "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
bind "sx-context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
(* Also register as primitives for prim_call *)
|
||||
Sx_primitives.register "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
Sx_primitives.register "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "collect!" (fun _args -> Nil);
|
||||
Sx_primitives.register "collected" (fun _args -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "scope-collected" (fun _args -> List []);
|
||||
Sx_primitives.register "scope-clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
|
||||
(* Render-mode flags *)
|
||||
ignore (env_bind env "*render-active*" (Bool false));
|
||||
bind "set-render-active!" (fun args ->
|
||||
match args with [v] -> ignore (env_set env "*render-active*" v); Nil | _ -> Nil);
|
||||
bind "render-active?" (fun _args ->
|
||||
try env_get env "*render-active*" with _ -> Bool false);
|
||||
bind "definition-form?" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Bool (List.mem s ["define"; "defcomp"; "defisland"; "defmacro";
|
||||
"defstyle"; "defhandler"; "deftype"; "defeffect"; "defquery"; "defaction"; "defrelation"])
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Signal stubs for SSR — overridden when signals.sx is loaded *)
|
||||
bind "signal" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "computed" (fun args -> match args with [f] -> Sx_runtime.sx_call f [] | _ -> Nil);
|
||||
bind "deref" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "reset!" (fun _args -> Nil);
|
||||
bind "swap!" (fun _args -> Nil);
|
||||
bind "effect" (fun _args -> Nil);
|
||||
bind "batch" (fun _args -> Nil);
|
||||
|
||||
(* Type predicates — needed by adapter-sx.sx *)
|
||||
bind "callable?" (fun args ->
|
||||
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args ->
|
||||
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda-params" (fun args ->
|
||||
match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args ->
|
||||
match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-name" (fun args ->
|
||||
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
|
||||
bind "component-closure" (fun args ->
|
||||
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
bind "component-body" (fun args ->
|
||||
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with [Component c] -> String c.c_affinity
|
||||
| [Island _] -> Nil | _ -> Nil);
|
||||
bind "component-has-children?" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool (List.mem "children" c.c_params)
|
||||
| [Island i] -> Bool (List.mem "children" i.i_params)
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Evaluator bridge — needed by adapter-sx.sx *)
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args; Env _e] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; List call_args] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
|
||||
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; Env e] ->
|
||||
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
|
||||
List.iteri (fun i p ->
|
||||
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
|
||||
Hashtbl.replace body_env.bindings p v
|
||||
) m.m_params;
|
||||
Sx_ref.eval_expr m.m_body (Env body_env)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let rec resolve v = match v with
|
||||
| Thunk (body, closure_env) -> resolve (Sx_ref.eval_expr body (Env closure_env))
|
||||
| _ -> v
|
||||
in resolve v
|
||||
| _ -> raise (Eval_error "trampoline: expected 1 arg"));
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "register-special-form!" (fun args ->
|
||||
match args with
|
||||
| [String name; handler] ->
|
||||
ignore (Sx_ref.register_special_form (String name) handler); Nil
|
||||
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
|
||||
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
|
||||
|
||||
(* DOM stubs *)
|
||||
bind "create-text-node" (fun args -> match args with [String s] -> String s | _ -> Nil);
|
||||
bind "create-fragment" (fun _args -> Nil);
|
||||
bind "dom-create-element" (fun _args -> Nil);
|
||||
bind "dom-append" (fun _args -> Nil);
|
||||
bind "dom-set-attr" (fun _args -> Nil);
|
||||
bind "dom-set-prop" (fun _args -> Nil);
|
||||
bind "dom-get-attr" (fun _args -> Nil);
|
||||
bind "dom-query" (fun _args -> Nil);
|
||||
bind "dom-body" (fun _args -> Nil);
|
||||
|
||||
(* Misc stubs *)
|
||||
bind "random-int" (fun args ->
|
||||
match args with
|
||||
| [Number lo; Number hi] -> Number (lo +. Float.round (Random.float (hi -. lo)))
|
||||
| _ -> Number 0.0);
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "freeze-scope" (fun _args -> Nil);
|
||||
bind "freeze-signal" (fun _args -> Nil);
|
||||
bind "thaw-from-sx" (fun _args -> Nil);
|
||||
bind "local-storage-get" (fun _args -> Nil);
|
||||
bind "local-storage-set" (fun _args -> Nil);
|
||||
bind "schedule-idle" (fun _args -> Nil);
|
||||
bind "run-post-render-hooks" (fun _args -> Nil);
|
||||
bind "freeze-to-sx" (fun _args -> String "");
|
||||
|
||||
env
|
||||
|
||||
|
||||
let () =
|
||||
Printexc.record_backtrace true;
|
||||
|
||||
(* Find project root *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/render.sx" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () else find_root parent
|
||||
in
|
||||
let root = find_root (Sys.getcwd ()) in
|
||||
let spec p = Filename.concat (Filename.concat root "spec") p in
|
||||
let lib p = Filename.concat (Filename.concat root "lib") p in
|
||||
let web p = Filename.concat (Filename.concat root "web") p in
|
||||
|
||||
let env = make_integration_env () in
|
||||
|
||||
(* Load spec + lib + adapters *)
|
||||
Printf.printf "Loading spec + lib + adapters...\n%!";
|
||||
let load path =
|
||||
if Sys.file_exists path then begin
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr (Env env))) exprs;
|
||||
Printf.printf " loaded %s (%d defs)\n%!" (Filename.basename path) (List.length exprs)
|
||||
end else
|
||||
Printf.printf " SKIP %s (not found)\n%!" path
|
||||
in
|
||||
load (spec "parser.sx");
|
||||
load (spec "render.sx");
|
||||
load (web "signals.sx");
|
||||
load (web "adapter-html.sx");
|
||||
load (web "adapter-sx.sx");
|
||||
ignore lib; (* available for future library loading *)
|
||||
|
||||
(* Helper: render SX source string to HTML *)
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.render_to_html expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
let sx_render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "render-to-html"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | RawHTML s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: native renderer — HTML tags\n%!";
|
||||
assert_eq "div" "<div>hello</div>" (render_html "(div \"hello\")");
|
||||
assert_eq "div with class" "<div class=\"card\">text</div>" (render_html "(div :class \"card\" \"text\")");
|
||||
assert_eq "nested tags" "<div><p>inner</p></div>" (render_html "(div (p \"inner\"))");
|
||||
assert_eq "void element" "<br />" (render_html "(br)");
|
||||
assert_eq "h1" "<h1>Title</h1>" (render_html "(h1 \"Title\")");
|
||||
assert_eq "span with attrs" "<span class=\"bold\">text</span>" (render_html "(span :class \"bold\" \"text\")");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter render-to-html — HTML tags\n%!";
|
||||
assert_no_error "div doesn't throw" (fun () -> sx_render_html "(div \"hello\")");
|
||||
assert_contains "div produces tag" "<div" (sx_render_html "(div \"hello\")");
|
||||
assert_contains "div with class" "class=\"card\"" (sx_render_html "(div :class \"card\" \"text\")");
|
||||
assert_contains "nested tags" "<p>" (sx_render_html "(div (p \"inner\"))");
|
||||
assert_no_error "h1 doesn't throw" (fun () -> sx_render_html "(h1 \"Title\")");
|
||||
assert_no_error "span doesn't throw" (fun () -> sx_render_html "(span :class \"bold\" \"text\")");
|
||||
assert_no_error "table doesn't throw" (fun () -> sx_render_html "(table (tr (td \"cell\")))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — special forms in HTML context\n%!";
|
||||
assert_contains "when true renders" "<p>" (sx_render_html "(when true (p \"yes\"))");
|
||||
assert_eq "when false empty" "" (sx_render_html "(when false (p \"no\"))");
|
||||
assert_contains "if true branch" "yes" (sx_render_html "(if true (span \"yes\") (span \"no\"))");
|
||||
assert_contains "if false branch" "no" (sx_render_html "(if false (span \"yes\") (span \"no\"))");
|
||||
assert_contains "let in render" "hello" (sx_render_html "(let ((x \"hello\")) (p x))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — letrec in HTML context\n%!";
|
||||
assert_no_error "letrec with div body" (fun () ->
|
||||
sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_contains "letrec renders body" "<div>" (sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_no_error "letrec with side effects then div" (fun () ->
|
||||
sx_render_html "(letrec ((x 1) (y 2)) (let ((z (+ x y))) (div (str z))))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — components\n%!";
|
||||
(try
|
||||
assert_no_error "defcomp + render" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all "(defcomp ~test-card (&key title &rest children) (div :class \"card\" (h2 title) children))"))
|
||||
(Env env));
|
||||
sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders div" "<div" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders title" "Hi" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))")
|
||||
with Eval_error msg -> incr fail_count; Printf.printf " FAIL: components — %s\n%!" msg);
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: eval-expr with HTML tag functions\n%!";
|
||||
assert_no_error "eval (div) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "div"; Keyword "class"; String "foo"; String "hi"]) (Env env));
|
||||
assert_no_error "eval (span) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "span"; String "text"]) (Env env));
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Regression: call-lambda re-evaluated Dict args through eval_expr,
|
||||
which copies dicts. Mutations inside the lambda (e.g. signal
|
||||
reset!) operated on the copy, not the original. This broke
|
||||
island SSR where aser processes multi-body let forms. *)
|
||||
Printf.printf "\nSuite: call-lambda dict identity (aser mode)\n%!";
|
||||
let aser_eval src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "aser"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | SxExpr s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
assert_eq "lambda dict mutation in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((mutate! (fn (d k v) (dict-set! d k v)))
|
||||
(d (dict \"x\" 1)))
|
||||
(mutate! d \"x\" 99)
|
||||
(get d \"x\"))");
|
||||
assert_eq "signal reset! in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((s (signal 42)))
|
||||
(reset! s 99)
|
||||
(deref s))");
|
||||
assert_eq "signal reset! then len of deref"
|
||||
"3"
|
||||
(aser_eval
|
||||
"(let ((s (signal (list))))
|
||||
(reset! s (list 1 2 3))
|
||||
(len (deref s)))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\n";
|
||||
Printf.printf "============================================================\n";
|
||||
Printf.printf "Integration: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "============================================================\n";
|
||||
if !fail_count > 0 then exit 1
|
||||
@@ -10,13 +10,6 @@
|
||||
dune exec bin/run_tests.exe -- test-primitives # specific test
|
||||
dune exec bin/run_tests.exe -- --foundation # foundation only *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
open Sx_parser
|
||||
open Sx_primitives
|
||||
@@ -177,44 +170,38 @@ let make_test_env () =
|
||||
|
||||
(* --- Environment operations --- *)
|
||||
|
||||
(* Env operations — accept both Env and Dict *)
|
||||
let uw = Sx_runtime.unwrap_env in
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [e; String k] -> Sx_types.env_get (uw e) k
|
||||
| [e; Keyword k] -> Sx_types.env_get (uw e) k
|
||||
| [Env e; String k] -> Sx_types.env_get e k
|
||||
| [Env e; Keyword k] -> Sx_types.env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and string"));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [e; String k] -> Bool (Sx_types.env_has (uw e) k)
|
||||
| [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k)
|
||||
| [Env e; String k] -> Bool (Sx_types.env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (Sx_types.env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [e; String k; v] ->
|
||||
let ue = uw e in
|
||||
if k = "x" || k = "children" || k = "i" then
|
||||
Printf.eprintf "[env-bind!] '%s' env-id=%d bindings-before=%d\n%!" k (Obj.obj (Obj.repr ue) : int) (Hashtbl.length ue.Sx_types.bindings);
|
||||
Sx_types.env_bind ue k v
|
||||
| [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v
|
||||
| [Env e; String k; v] -> Sx_types.env_bind e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [e; String k; v] -> Sx_types.env_set (uw e) k v
|
||||
| [e; Keyword k; v] -> Sx_types.env_set (uw e) k v
|
||||
| [Env e; String k; v] -> Sx_types.env_set e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [e] -> Env (Sx_types.env_extend (uw e))
|
||||
| [Env e] -> Env (Sx_types.env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Sx_runtime.env_merge a b
|
||||
| [Env a; Env b] -> Env (Sx_types.env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Equality --- *)
|
||||
@@ -273,94 +260,7 @@ let make_test_env () =
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- HTML Renderer (from sx_render.ml library module) --- *)
|
||||
Sx.Sx_render.setup_render_env env;
|
||||
|
||||
(* Stubs needed by adapter-html.sx when loaded at test time *)
|
||||
bind "set-render-active!" (fun _args -> Nil);
|
||||
bind "render-active?" (fun _args -> Bool true);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (expr, e)] -> eval_expr expr (Env e)
|
||||
| [v] -> v
|
||||
| _ -> Nil);
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] ->
|
||||
let ue = Sx_runtime.unwrap_env e in
|
||||
eval_expr expr (Env ue)
|
||||
| [expr] -> eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env)"));
|
||||
(* Scope primitives — use a local scope stacks table.
|
||||
Must match the same pattern as sx_server.ml's _scope_stacks. *)
|
||||
let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
bind "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (Nil :: stack); Nil
|
||||
| _ -> Nil);
|
||||
bind "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
bind "scope-emit!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
|
||||
| _ :: rest ->
|
||||
Hashtbl.replace _scope_stacks name (List [value] :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace _scope_stacks name [List [value]]);
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
bind "emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
bind "scope-emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
bind "provide-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
||||
| _ -> Nil);
|
||||
bind "provide-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
bind "cond-scheme?" (fun args ->
|
||||
match args with
|
||||
| [(List clauses | ListRef { contents = clauses })] ->
|
||||
(match clauses with
|
||||
| (List _ | ListRef _) :: _ -> Bool true
|
||||
| _ -> Bool false)
|
||||
| _ -> Bool false);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; (List a | ListRef { contents = a }); _] ->
|
||||
let local = Sx_types.env_extend m.m_closure in
|
||||
List.iteri (fun i p ->
|
||||
ignore (Sx_types.env_bind local p (if i < List.length a then List.nth a i else Nil))
|
||||
) m.m_params;
|
||||
eval_expr m.m_body (Env local)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
@@ -465,25 +365,21 @@ let make_test_env () =
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| [Island i] -> i.i_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| [Island i] -> Bool i.i_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| [Island _] -> String "client"
|
||||
| _ -> String "auto");
|
||||
|
||||
(* --- Parser test helpers --- *)
|
||||
@@ -688,7 +584,7 @@ let run_foundation_tests () =
|
||||
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
|
||||
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
|
||||
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None } in
|
||||
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
|
||||
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
|
||||
@@ -734,60 +630,28 @@ let run_spec_tests env test_files =
|
||||
Printf.printf "\nLoading test framework...\n%!";
|
||||
load_and_eval framework_path;
|
||||
|
||||
(* Load modules needed by tests *)
|
||||
let spec_dir = Filename.concat project_dir "spec" in
|
||||
let lib_dir = Filename.concat project_dir "lib" in
|
||||
let web_dir = Filename.concat project_dir "web" in
|
||||
let load_module name dir =
|
||||
let path = Filename.concat dir name in
|
||||
if Sys.file_exists path then begin
|
||||
Printf.printf "Loading %s...\n%!" name;
|
||||
(try load_and_eval path
|
||||
with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e))
|
||||
end
|
||||
in
|
||||
(* Render adapter for test-render-html.sx *)
|
||||
load_module "render.sx" spec_dir;
|
||||
load_module "adapter-html.sx" web_dir;
|
||||
(* Library modules for lib/tests/ *)
|
||||
load_module "bytecode.sx" lib_dir;
|
||||
load_module "compiler.sx" lib_dir;
|
||||
load_module "vm.sx" lib_dir;
|
||||
load_module "signals.sx" web_dir;
|
||||
load_module "freeze.sx" lib_dir;
|
||||
load_module "content.sx" lib_dir;
|
||||
load_module "types.sx" lib_dir;
|
||||
|
||||
(* Determine test files — scan spec/tests/ and lib/tests/ *)
|
||||
let lib_tests_dir = Filename.concat project_dir "lib/tests" in
|
||||
(* Determine test files *)
|
||||
let files = if test_files = [] then begin
|
||||
(* Spec tests (core language — always run) *)
|
||||
let spec_entries = Sys.readdir spec_tests_dir in
|
||||
Array.sort String.compare spec_entries;
|
||||
let spec_files = Array.to_list spec_entries
|
||||
|> List.filter (fun f ->
|
||||
String.length f > 5 &&
|
||||
String.sub f 0 5 = "test-" &&
|
||||
Filename.check_suffix f ".sx" &&
|
||||
f <> "test-framework.sx")
|
||||
|> List.map (fun f -> Filename.concat spec_tests_dir f)
|
||||
in
|
||||
spec_files
|
||||
let entries = Sys.readdir spec_tests_dir in
|
||||
Array.sort String.compare entries;
|
||||
let requires_full = ["test-continuations.sx"; "test-types.sx"; "test-freeze.sx";
|
||||
"test-continuations-advanced.sx"; "test-signals-advanced.sx"] in
|
||||
Array.to_list entries
|
||||
|> List.filter (fun f ->
|
||||
String.length f > 5 &&
|
||||
String.sub f 0 5 = "test-" &&
|
||||
Filename.check_suffix f ".sx" &&
|
||||
f <> "test-framework.sx" &&
|
||||
not (List.mem f requires_full))
|
||||
end else
|
||||
(* Specific test files — search all test dirs *)
|
||||
List.map (fun name ->
|
||||
let name = if Filename.check_suffix name ".sx" then name else name ^ ".sx" in
|
||||
let spec_path = Filename.concat spec_tests_dir name in
|
||||
let lib_path = Filename.concat lib_tests_dir name in
|
||||
if Sys.file_exists spec_path then spec_path
|
||||
else if Sys.file_exists lib_path then lib_path
|
||||
else Filename.concat spec_tests_dir name (* will fail with "not found" *)
|
||||
) test_files
|
||||
if Filename.check_suffix name ".sx" then name
|
||||
else name ^ ".sx") test_files
|
||||
in
|
||||
|
||||
List.iter (fun path ->
|
||||
List.iter (fun name ->
|
||||
let path = Filename.concat spec_tests_dir name in
|
||||
if Sys.file_exists path then begin
|
||||
let name = Filename.basename path in
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Running %s\n" name;
|
||||
Printf.printf "%s\n%!" (String.make 60 '=');
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -22,14 +22,22 @@ from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines.
|
||||
Strips :effects [...] annotations from defines."""
|
||||
from shared.sx.types import Keyword
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
# Strip :effects [...] annotation if present
|
||||
# (define name :effects [...] body) → (define name body)
|
||||
cleaned = list(expr)
|
||||
if (len(cleaned) >= 4 and isinstance(cleaned[2], Keyword)
|
||||
and cleaned[2].name == "effects"):
|
||||
cleaned = [cleaned[0], cleaned[1]] + cleaned[4:]
|
||||
defines.append((name, cleaned))
|
||||
return defines
|
||||
|
||||
|
||||
@@ -43,38 +51,16 @@ PREAMBLE = """\
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* Trampoline — forward ref, resolved after eval_expr is defined. *)
|
||||
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
|
||||
let trampoline v = !trampoline_fn v
|
||||
|
||||
|
||||
|
||||
(* === Mutable state for strict mode === *)
|
||||
(* These are defined as top-level refs because the transpiler cannot handle
|
||||
global set! mutation (it creates local refs that shadow the global). *)
|
||||
let _strict_ref = ref (Bool false)
|
||||
let _prim_param_types_ref = ref Nil
|
||||
|
||||
(* JIT call hook — cek_call checks this before CEK dispatch for named
|
||||
lambdas. Registered by sx_server.ml after compiler loads. Tests
|
||||
run with hook = None (pure CEK, no compilation dependency). *)
|
||||
let jit_call_hook : (value -> value list -> value option) option ref = ref None
|
||||
(* Trampoline — evaluates thunks via the CEK machine.
|
||||
eval_expr is defined in the transpiled block below. *)
|
||||
let trampoline v = v (* CEK machine doesn't produce thunks *)
|
||||
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — wire up trampoline + iterative CEK run + JIT hook
|
||||
# OCaml fixups — override iterative CEK run + reactive subscriber fix
|
||||
FIXUPS = """\
|
||||
|
||||
(* Wire up trampoline to resolve thunks via the CEK machine *)
|
||||
let () = trampoline_fn := (fun v ->
|
||||
match v with
|
||||
| Thunk (expr, env) -> eval_expr expr (Env env)
|
||||
| _ -> v)
|
||||
|
||||
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
|
||||
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
@@ -83,28 +69,59 @@ let cek_run_iterative state =
|
||||
done;
|
||||
cek_value !s
|
||||
|
||||
(* Strict mode refs — used by test runner, stubbed here *)
|
||||
let _strict_ref = ref Nil
|
||||
let _prim_param_types_ref = ref Nil
|
||||
let value_matches_type_p _v _t = Bool true
|
||||
|
||||
(* Override reactive_shift_deref to wrap subscriber as NativeFn.
|
||||
The transpiler emits bare OCaml closures for (fn () ...) but
|
||||
signal_add_sub_b expects SX values. *)
|
||||
let reactive_shift_deref sig' env kont =
|
||||
let scan_result = kont_capture_to_reactive_reset kont in
|
||||
let captured_frames = first scan_result in
|
||||
let reset_frame = nth scan_result (Number 1.0) in
|
||||
let remaining_kont = nth scan_result (Number 2.0) in
|
||||
let update_fn = get reset_frame (String "update-fn") in
|
||||
let sub_disposers = ref (List []) in
|
||||
let subscriber_fn () =
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
sub_disposers := List [];
|
||||
let new_reset = make_reactive_reset_frame env update_fn (Bool false) in
|
||||
let new_kont = prim_call "concat" [captured_frames; List [new_reset]; remaining_kont] in
|
||||
ignore (with_island_scope
|
||||
(fun d -> sub_disposers := sx_append_b !sub_disposers d; Nil)
|
||||
(fun () -> cek_run (make_cek_value (signal_value sig') env new_kont)));
|
||||
Nil
|
||||
in
|
||||
let subscriber = NativeFn ("reactive-subscriber", fun _args -> subscriber_fn ()) in
|
||||
ignore (signal_add_sub_b sig' subscriber);
|
||||
ignore (register_in_scope (fun () ->
|
||||
ignore (signal_remove_sub_b sig' subscriber);
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
Nil));
|
||||
let initial_kont = prim_call "concat" [captured_frames; List [reset_frame]; remaining_kont] in
|
||||
make_cek_value (signal_value sig') env initial_kont
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
"""Compile the SX spec to OCaml source."""
|
||||
import tempfile
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
from shared.sx.parser import serialize
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if spec_dir is None:
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
bridge.load(transpiler_path)
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Spec files to transpile (in dependency order)
|
||||
# stdlib.sx functions are already registered as OCaml primitives —
|
||||
# only the evaluator needs transpilation.
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
]
|
||||
@@ -121,14 +138,15 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip defines provided by preamble, fixups, or already-registered primitives
|
||||
# Skip: preamble-provided, math primitives, and stdlib functions
|
||||
# that use loop/named-let (transpiler can't handle those yet)
|
||||
skip = {"trampoline", "ceil", "floor", "round", "abs", "min", "max",
|
||||
"debug-log", "debug_log", "range", "chunk-every", "zip-pairs",
|
||||
"string-contains?", "starts-with?", "ends-with?",
|
||||
"string-replace", "trim", "split", "index-of",
|
||||
"pad-left", "pad-right", "char-at", "substring"}
|
||||
# Skip defines provided by preamble/fixups or that belong in web module
|
||||
skip = {"trampoline",
|
||||
# Freeze functions depend on signals.sx (web spec)
|
||||
"freeze-registry", "freeze-signal", "freeze-scope",
|
||||
"cek-freeze-scope", "cek-freeze-all",
|
||||
"cek-thaw-scope", "cek-thaw-all",
|
||||
"freeze-to-sx", "thaw-from-sx",
|
||||
"freeze-to-cid", "thaw-from-cid",
|
||||
"content-hash", "content-put", "content-get", "content-store"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
@@ -137,118 +155,177 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
# Build the defines list and known names for the transpiler
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
known_names = [name for name, _ in defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Serialize defines + known names to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines \'{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
# Pass known define names so the transpiler can distinguish
|
||||
# static (OCaml fn) calls from dynamic (SX value) calls
|
||||
env["_known_defines"] = [name for name, _ in defines]
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append(f"\n(* === Transpiled from {label} === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
bridge.stop()
|
||||
parts.append(FIXUPS)
|
||||
output = "\n".join(parts)
|
||||
return "\n".join(parts)
|
||||
|
||||
# Post-process: fix mutable globals that the transpiler can't handle.
|
||||
# The transpiler emits local refs for set! targets within functions,
|
||||
# but top-level globals (*strict*, *prim-param-types*) need to use
|
||||
# the pre-declared refs from the preamble.
|
||||
import re
|
||||
|
||||
# Fix *strict*: use _strict_ref instead of immutable let rec binding
|
||||
output = re.sub(
|
||||
r'and _strict_ =\n \(Bool false\)',
|
||||
'and _strict_ = !_strict_ref',
|
||||
output,
|
||||
)
|
||||
# Fix set-strict!: use _strict_ref instead of local ref
|
||||
output = re.sub(
|
||||
r'and set_strict_b val\' =\n let _strict_ = ref Nil in \(_strict_ := val\'; Nil\)',
|
||||
"and set_strict_b val' =\n _strict_ref := val'; Nil",
|
||||
output,
|
||||
)
|
||||
# Fix *prim-param-types*: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and _prim_param_types_ =\n Nil',
|
||||
'and _prim_param_types_ = !_prim_param_types_ref',
|
||||
output,
|
||||
)
|
||||
# Fix set-prim-param-types!: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and set_prim_param_types_b types =\n let _prim_param_types_ = ref Nil in \(_prim_param_types_ := types; Nil\)',
|
||||
"and set_prim_param_types_b types =\n _prim_param_types_ref := types; Nil",
|
||||
output,
|
||||
)
|
||||
WEB_PREAMBLE = """\
|
||||
(* sx_web.ml — Auto-generated from web adapters by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py --web *)
|
||||
|
||||
# Fix all runtime reads of _strict_ and _prim_param_types_ to deref
|
||||
# the mutable refs instead of using the stale let-rec bindings.
|
||||
# This is needed because let-rec value bindings capture initial values.
|
||||
# Use regex with word boundary to avoid replacing _strict_ref with
|
||||
# !_strict_refref.
|
||||
def fix_mutable_reads(text):
|
||||
lines = text.split('\n')
|
||||
fixed = []
|
||||
for line in lines:
|
||||
# Skip the definition lines
|
||||
stripped = line.strip()
|
||||
if stripped.startswith('and _strict_ =') or stripped.startswith('and _prim_param_types_ ='):
|
||||
fixed.append(line)
|
||||
continue
|
||||
# Replace _strict_ as a standalone identifier only (not inside
|
||||
# other names like set_strict_b). Match when preceded by space,
|
||||
# paren, or start-of-line, and followed by space, paren, or ;.
|
||||
line = re.sub(r'(?<=[ (])_strict_(?=[ );])', '!_strict_ref', line)
|
||||
line = re.sub(r'(?<=[ (])_prim_param_types_(?=[ );])', '!_prim_param_types_ref', line)
|
||||
fixed.append(line)
|
||||
return '\n'.join(fixed)
|
||||
output = fix_mutable_reads(output)
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
# Fix cek_call: the spec passes (make-env) as the env arg to
|
||||
# continue_with_call, but the transpiler evaluates make-env at
|
||||
# transpile time (it's a primitive), producing Dict instead of Env.
|
||||
output = output.replace(
|
||||
"((Dict (Hashtbl.create 0))) (a) ((List []))",
|
||||
"(Env (Sx_types.make_env ())) (a) ((List []))",
|
||||
)
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
# Inject JIT dispatch into continue_with_call's lambda branch.
|
||||
# After params are bound, check jit_call_hook before creating CEK state.
|
||||
lambda_body_pattern = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
lambda_body_jit = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(match !jit_call_hook, f with '
|
||||
'| Some hook, Lambda l when l.l_name <> None -> '
|
||||
'let args_list = match args with '
|
||||
'List a | ListRef { contents = a } -> a | _ -> [] in '
|
||||
'(match hook f args_list with '
|
||||
'Some result -> make_cek_value result local kont '
|
||||
'| None -> make_cek_state (lambda_body f) local kont) '
|
||||
'| _ -> make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
if lambda_body_pattern in output:
|
||||
output = output.replace(lambda_body_pattern, lambda_body_jit, 1)
|
||||
"""
|
||||
|
||||
# Web adapter files to transpile (dependency order)
|
||||
WEB_ADAPTER_FILES = [
|
||||
("signals.sx", "signals (reactive signal runtime)"),
|
||||
("deps.sx", "deps (component dependency analysis)"),
|
||||
("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
("router.sx", "router (client-side route matching)"),
|
||||
("adapter-html.sx", "adapter-html (HTML rendering adapter)"),
|
||||
]
|
||||
|
||||
|
||||
def compile_web_to_ml(web_dir: str | None = None) -> str:
|
||||
"""Compile web adapter SX files to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if web_dir is None:
|
||||
web_dir = os.path.join(_PROJECT, "web")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Also load the evaluator defines so the transpiler knows about them
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
eval_path = os.path.join(spec_dir, "evaluator.sx")
|
||||
if os.path.exists(eval_path):
|
||||
with open(eval_path) as f:
|
||||
eval_defines = extract_defines(f.read())
|
||||
eval_names = [n for n, _ in eval_defines]
|
||||
else:
|
||||
import sys
|
||||
print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr)
|
||||
eval_names = []
|
||||
|
||||
return output
|
||||
parts = [WEB_PREAMBLE]
|
||||
|
||||
# Collect all web adapter defines
|
||||
all_defines = []
|
||||
for filename, label in WEB_ADAPTER_FILES:
|
||||
filepath = os.path.join(web_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Deduplicate within file
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
all_defines.extend(defines)
|
||||
print(f" {filename}: {len(defines)} defines", file=sys.stderr)
|
||||
|
||||
# Deduplicate across files (last wins)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(all_defines):
|
||||
seen[n] = i
|
||||
all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i]
|
||||
|
||||
print(f" Total: {len(all_defines)} unique defines", file=sys.stderr)
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in all_defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Known defines = evaluator names + web adapter names
|
||||
env["_known_defines"] = eval_names + [name for name, _ in all_defines]
|
||||
|
||||
# Translate
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append("\n(* === Transpiled from web adapters === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
# Registration function — extract actual OCaml names from transpiled output
|
||||
# by using the same transpiler mangling.
|
||||
# Ask the transpiler for the mangled name of each define.
|
||||
name_map = {}
|
||||
for name, _ in all_defines:
|
||||
mangle_expr = sx_parse(f'(ml-mangle "{name}")')[0]
|
||||
mangled = trampoline(eval_expr(mangle_expr, env))
|
||||
name_map[name] = mangled
|
||||
|
||||
def count_params(expr):
|
||||
"""Count actual params from a (define name [annotations] (fn (params...) body)) form."""
|
||||
# Find the (fn ...) form — it might be at index 2, 3, or 4 depending on annotations
|
||||
fn_expr = None
|
||||
for i in range(2, min(len(expr), 6)):
|
||||
if (isinstance(expr[i], list) and expr[i] and
|
||||
isinstance(expr[i][0], Symbol) and expr[i][0].name in ("fn", "lambda")):
|
||||
fn_expr = expr[i]
|
||||
break
|
||||
if fn_expr is None:
|
||||
return -1 # not a function
|
||||
params = fn_expr[1] if isinstance(fn_expr[1], list) else []
|
||||
n = 0
|
||||
skip = False
|
||||
for p in params:
|
||||
if skip:
|
||||
skip = False
|
||||
continue
|
||||
if isinstance(p, Symbol) and p.name in ("&key", "&rest"):
|
||||
skip = True
|
||||
continue
|
||||
if isinstance(p, list) and len(p) >= 3: # (name :as type)
|
||||
n += 1
|
||||
elif isinstance(p, Symbol):
|
||||
n += 1
|
||||
return n
|
||||
|
||||
parts.append("\n\n(* Register all web adapter functions into an environment *)\n")
|
||||
parts.append("let register_web_adapters env =\n")
|
||||
for name, expr in all_defines:
|
||||
mangled = name_map[name]
|
||||
n = count_params(expr)
|
||||
if n < 0:
|
||||
# Non-function define (constant)
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" {mangled});\n')
|
||||
elif n == 0:
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun _args -> {mangled} Nil)));\n')
|
||||
else:
|
||||
# Generate match with correct arity
|
||||
arg_names = [chr(97 + i) for i in range(n)] # a, b, c, ...
|
||||
pat = "; ".join(arg_names)
|
||||
call = " ".join(arg_names)
|
||||
# Pad with Nil for partial application
|
||||
pad_call = " ".join(arg_names[:1] + ["Nil"] * (n - 1)) if n > 1 else arg_names[0]
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun args -> match args with '
|
||||
f'| [{pat}] -> {mangled} {call} '
|
||||
f'| _ -> raise (Eval_error "{name}: expected {n} args"))));\n')
|
||||
parts.append(" ()\n")
|
||||
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
def main():
|
||||
@@ -259,17 +336,37 @@ def main():
|
||||
default=None,
|
||||
help="Output file (default: stdout)",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web",
|
||||
action="store_true",
|
||||
help="Compile web adapters instead of evaluator spec",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web-output",
|
||||
default=None,
|
||||
help="Output file for web adapters (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
result = compile_spec_to_ml()
|
||||
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
if args.web or args.web_output:
|
||||
result = compile_web_to_ml()
|
||||
out = args.web_output or args.output
|
||||
if out:
|
||||
with open(out, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(out)
|
||||
print(f"Wrote {out} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
else:
|
||||
print(result)
|
||||
result = compile_spec_to_ml()
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
|
||||
37
hosts/ocaml/browser/build.sh
Executable file
37
hosts/ocaml/browser/build.sh
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/env bash
|
||||
# Build the OCaml SX engine for browser use (WASM + JS fallback).
|
||||
#
|
||||
# Outputs:
|
||||
# _build/default/browser/sx_browser.bc.wasm.js WASM loader
|
||||
# _build/default/browser/sx_browser.bc.wasm.assets/ WASM modules
|
||||
# _build/default/browser/sx_browser.bc.js JS fallback
|
||||
#
|
||||
# Usage:
|
||||
# cd hosts/ocaml && ./browser/build.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
eval $(opam env 2>/dev/null || true)
|
||||
|
||||
echo "=== Building OCaml SX browser engine ==="
|
||||
|
||||
# Build all targets: bytecode, JS, WASM
|
||||
dune build browser/sx_browser.bc.js browser/sx_browser.bc.wasm.js
|
||||
|
||||
echo ""
|
||||
echo "--- Output sizes ---"
|
||||
echo -n "JS (unoptimized): "; ls -lh _build/default/browser/sx_browser.bc.js | awk '{print $5}'
|
||||
echo -n "WASM loader: "; ls -lh _build/default/browser/sx_browser.bc.wasm.js | awk '{print $5}'
|
||||
echo -n "WASM modules: "; du -sh _build/default/browser/sx_browser.bc.wasm.assets/*.wasm | awk '{s+=$1}END{print s"K"}'
|
||||
|
||||
# Optimized JS build
|
||||
js_of_ocaml --opt=3 -o _build/default/browser/sx_browser.opt.js _build/default/browser/sx_browser.bc
|
||||
echo -n "JS (optimized): "; ls -lh _build/default/browser/sx_browser.opt.js | awk '{print $5}'
|
||||
|
||||
echo ""
|
||||
echo "=== Build complete ==="
|
||||
echo ""
|
||||
echo "Test with:"
|
||||
echo " node hosts/ocaml/browser/run_tests_js.js # JS"
|
||||
echo " node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js # WASM"
|
||||
139
hosts/ocaml/browser/bundle.sh
Executable file
139
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,139 @@
|
||||
#!/usr/bin/env bash
|
||||
# Bundle the WASM engine + platform + web adapters into shared/static/scripts/
|
||||
#
|
||||
# Usage: hosts/ocaml/browser/bundle.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
WASM_LOADER="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.js"
|
||||
WASM_ASSETS="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.assets"
|
||||
PLATFORM="hosts/ocaml/browser/sx-platform.js"
|
||||
OUT="shared/static/scripts/sx-wasm.js"
|
||||
ASSET_DIR="shared/static/scripts/sx-wasm-assets"
|
||||
|
||||
if [ ! -f "$WASM_LOADER" ]; then
|
||||
echo "Build first: cd hosts/ocaml && eval \$(opam env) && dune build browser/sx_browser.bc.wasm.js"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# 1. WASM loader (patched asset path)
|
||||
sed 's|"src":"sx_browser.bc.wasm.assets"|"src":"sx-wasm-assets"|' \
|
||||
"$WASM_LOADER" > "$OUT"
|
||||
|
||||
# 2. Platform layer
|
||||
echo "" >> "$OUT"
|
||||
cat "$PLATFORM" >> "$OUT"
|
||||
|
||||
# 3. Embedded web adapters — SX source as JS string constants
|
||||
echo "" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "// Embedded web adapters (loaded into WASM engine at boot)" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "globalThis.__sxAdapters = {};" >> "$OUT"
|
||||
|
||||
# Adapters to embed (order matters for dependencies)
|
||||
ADAPTERS="signals deps page-helpers router adapter-html"
|
||||
|
||||
for name in $ADAPTERS; do
|
||||
file="web/${name}.sx"
|
||||
if [ -f "$file" ]; then
|
||||
echo -n "globalThis.__sxAdapters[\"${name}\"] = " >> "$OUT"
|
||||
# Escape the SX source for embedding in a JS string
|
||||
python3 -c "
|
||||
import json, sys
|
||||
with open('$file') as f:
|
||||
print(json.dumps(f.read()) + ';')
|
||||
" >> "$OUT"
|
||||
fi
|
||||
done
|
||||
|
||||
# 4. Boot shim
|
||||
cat >> "$OUT" << 'BOOT'
|
||||
|
||||
// =========================================================================
|
||||
// WASM Boot: load adapters, then process inline <script type="text/sx">
|
||||
// =========================================================================
|
||||
(function() {
|
||||
"use strict";
|
||||
if (typeof document === "undefined") return;
|
||||
|
||||
function sxWasmBoot() {
|
||||
var K = globalThis.SxKernel;
|
||||
if (!K || !globalThis.Sx) { setTimeout(sxWasmBoot, 50); return; }
|
||||
|
||||
console.log("[sx-wasm] booting, engine:", K.engine());
|
||||
|
||||
// Load embedded web adapters
|
||||
var adapters = globalThis.__sxAdapters || {};
|
||||
var adapterOrder = ["signals", "deps", "page-helpers", "router", "adapter-html"];
|
||||
for (var j = 0; j < adapterOrder.length; j++) {
|
||||
var name = adapterOrder[j];
|
||||
if (adapters[name]) {
|
||||
var r = K.loadSource(adapters[name]);
|
||||
if (typeof r === "string" && r.startsWith("Error:")) {
|
||||
console.error("[sx-wasm] adapter " + name + " error:", r);
|
||||
} else {
|
||||
console.log("[sx-wasm] loaded " + name + " (" + r + " defs)");
|
||||
}
|
||||
}
|
||||
}
|
||||
delete globalThis.__sxAdapters; // Free memory
|
||||
|
||||
// Process <script type="text/sx" data-components>
|
||||
var scripts = document.querySelectorAll('script[type="text/sx"]');
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i], src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
if (s.hasAttribute("data-components")) {
|
||||
var result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:"))
|
||||
console.error("[sx-wasm] component load error:", result);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-init>
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-init")) {
|
||||
var src = s.textContent.trim();
|
||||
if (src) K.loadSource(src);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-mount="...">
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-mount")) {
|
||||
var mount = s.getAttribute("data-mount"), src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
var target = mount === "body" ? document.body : document.querySelector(mount);
|
||||
if (!target) continue;
|
||||
try {
|
||||
var parsed = K.parse(src);
|
||||
if (parsed && parsed.length > 0) {
|
||||
var html = K.renderToHtml(parsed[0]);
|
||||
if (html && typeof html === "string") {
|
||||
target.innerHTML = html;
|
||||
console.log("[sx-wasm] mounted to", mount);
|
||||
}
|
||||
}
|
||||
} catch(e) { console.error("[sx-wasm] mount error:", e); }
|
||||
}
|
||||
}
|
||||
|
||||
console.log("[sx-wasm] boot complete");
|
||||
}
|
||||
|
||||
if (document.readyState === "loading") document.addEventListener("DOMContentLoaded", sxWasmBoot);
|
||||
else sxWasmBoot();
|
||||
})();
|
||||
BOOT
|
||||
|
||||
# 5. Copy WASM assets
|
||||
mkdir -p "$ASSET_DIR"
|
||||
cp "$WASM_ASSETS"/*.wasm "$ASSET_DIR/"
|
||||
|
||||
echo "=== Bundle complete ==="
|
||||
ls -lh "$OUT"
|
||||
echo -n "WASM assets: "; du -sh "$ASSET_DIR" | awk '{print $1}'
|
||||
5
hosts/ocaml/browser/dune
Normal file
5
hosts/ocaml/browser/dune
Normal file
@@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name sx_browser)
|
||||
(libraries sx js_of_ocaml)
|
||||
(modes byte js wasm)
|
||||
(preprocess (pps js_of_ocaml-ppx)))
|
||||
149
hosts/ocaml/browser/run_tests_js.js
Normal file
149
hosts/ocaml/browser/run_tests_js.js
Normal file
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the js_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to JS) and runs the spec test suite.
|
||||
*
|
||||
* Usage:
|
||||
* node hosts/ocaml/browser/run_tests_js.js # standard tests
|
||||
* node hosts/ocaml/browser/run_tests_js.js --full # full suite
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
// Load the compiled OCaml engine
|
||||
const enginePath = path.join(__dirname, "../_build/default/browser/sx_browser.bc.js");
|
||||
if (!fs.existsSync(enginePath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.js");
|
||||
process.exit(1);
|
||||
}
|
||||
require(enginePath);
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// Test state
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→JS Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
// Load a .sx file by reading it from disk and evaluating via loadSource
|
||||
function loadFile(filePath) {
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
return K.loadSource(src);
|
||||
}
|
||||
|
||||
// Test files
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx",
|
||||
"test-eval.sx",
|
||||
"test-parser.sx",
|
||||
"test-primitives.sx",
|
||||
"test-collections.sx",
|
||||
"test-closures.sx",
|
||||
"test-defcomp.sx",
|
||||
"test-macros.sx",
|
||||
"test-errors.sx",
|
||||
"test-render.sx",
|
||||
"test-tco.sx",
|
||||
"test-scope.sx",
|
||||
"test-cek.sx",
|
||||
"test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx",
|
||||
"test-continuations.sx",
|
||||
"test-continuations-advanced.sx",
|
||||
"test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx",
|
||||
"test-render-advanced.sx",
|
||||
"test-integration.sx",
|
||||
"test-strict.sx",
|
||||
"test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const result = loadFile(filePath);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the wasm_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to WASM) and runs the spec test suite.
|
||||
* Requires Node.js 22+ with --experimental-wasm-imported-strings flag.
|
||||
*
|
||||
* Usage:
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js --full
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
const wasmDir = path.join(__dirname, "../_build/default/browser");
|
||||
const loaderPath = path.join(wasmDir, "sx_browser.bc.wasm.js");
|
||||
|
||||
if (!fs.existsSync(loaderPath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.wasm.js");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Set require.main.filename so the WASM loader can find .wasm assets
|
||||
if (!require.main) {
|
||||
require.main = { filename: path.join(wasmDir, "test.js") };
|
||||
} else {
|
||||
require.main.filename = path.join(wasmDir, "test.js");
|
||||
}
|
||||
|
||||
require(loaderPath);
|
||||
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// WASM loader is async — wait for SxKernel to be available
|
||||
setTimeout(() => {
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) {
|
||||
console.error("SxKernel not available — WASM initialization failed");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→WASM Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx", "test-eval.sx", "test-parser.sx",
|
||||
"test-primitives.sx", "test-collections.sx", "test-closures.sx",
|
||||
"test-defcomp.sx", "test-macros.sx", "test-errors.sx",
|
||||
"test-render.sx", "test-tco.sx", "test-scope.sx",
|
||||
"test-cek.sx", "test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx", "test-continuations.sx",
|
||||
"test-continuations-advanced.sx", "test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx", "test-render-advanced.sx",
|
||||
"test-integration.sx", "test-strict.sx", "test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
const result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
}, 1000);
|
||||
676
hosts/ocaml/browser/sx-platform.js
Normal file
676
hosts/ocaml/browser/sx-platform.js
Normal file
@@ -0,0 +1,676 @@
|
||||
/**
|
||||
* sx-platform.js — Thin JS platform layer for the OCaml SX WASM engine.
|
||||
*
|
||||
* This file provides browser-native primitives (DOM, fetch, timers, etc.)
|
||||
* to the WASM-compiled OCaml CEK machine. It:
|
||||
* 1. Loads the WASM module (SxKernel)
|
||||
* 2. Registers ~80 native browser functions via registerNative
|
||||
* 3. Loads web adapters (.sx files) into the engine
|
||||
* 4. Exports the public Sx API
|
||||
*
|
||||
* Both wasm_of_ocaml and js_of_ocaml targets bind to this same layer.
|
||||
*/
|
||||
|
||||
(function(global) {
|
||||
"use strict";
|
||||
|
||||
function initPlatform() {
|
||||
var K = global.SxKernel;
|
||||
if (!K) {
|
||||
// WASM loader is async — wait and retry
|
||||
setTimeout(initPlatform, 20);
|
||||
return;
|
||||
}
|
||||
|
||||
var _hasDom = typeof document !== "undefined";
|
||||
var NIL = null;
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
|
||||
// =========================================================================
|
||||
// Helper: wrap SX lambda for use as JS callback
|
||||
// =========================================================================
|
||||
|
||||
function wrapLambda(fn) {
|
||||
// For now, SX lambdas from registerNative are opaque — we can't call them
|
||||
// directly from JS. They need to go through the engine.
|
||||
// TODO: add callLambda API to SxKernel
|
||||
return fn;
|
||||
}
|
||||
|
||||
// =========================================================================
|
||||
// 1. DOM Creation & Manipulation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-create-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tag = args[0], ns = args[1];
|
||||
if (ns && ns !== NIL) return document.createElementNS(ns, tag);
|
||||
return document.createElement(tag);
|
||||
});
|
||||
|
||||
K.registerNative("create-text-node", function(args) {
|
||||
return _hasDom ? document.createTextNode(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-comment", function(args) {
|
||||
return _hasDom ? document.createComment(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-fragment", function(_args) {
|
||||
return _hasDom ? document.createDocumentFragment() : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-clone", function(args) {
|
||||
var node = args[0];
|
||||
return node && node.cloneNode ? node.cloneNode(true) : node;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tpl = document.createElement("template");
|
||||
tpl.innerHTML = args[0] || "";
|
||||
return tpl.content;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html-document", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var parser = new DOMParser();
|
||||
return parser.parseFromString(args[0] || "", "text/html");
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 2. DOM Queries
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-query", function(args) {
|
||||
return _hasDom ? document.querySelector(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-all", function(args) {
|
||||
var root = args[0] || (_hasDom ? document : null);
|
||||
if (!root || !root.querySelectorAll) return [];
|
||||
return Array.prototype.slice.call(root.querySelectorAll(args[1] || args[0]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-by-id", function(args) {
|
||||
return _hasDom ? document.getElementById(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body", function(_args) {
|
||||
return _hasDom ? document.body : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-ensure-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var sel = args[0];
|
||||
var el = document.querySelector(sel);
|
||||
if (el) return el;
|
||||
if (sel.charAt(0) === "#") {
|
||||
el = document.createElement("div");
|
||||
el.id = sel.slice(1);
|
||||
document.body.appendChild(el);
|
||||
return el;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 3. DOM Attributes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-attr", function(args) {
|
||||
var el = args[0], name = args[1];
|
||||
if (!el || !el.getAttribute) return NIL;
|
||||
var v = el.getAttribute(name);
|
||||
return v === null ? NIL : v;
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-attr", function(args) {
|
||||
var el = args[0], name = args[1], val = args[2];
|
||||
if (el && el.setAttribute) el.setAttribute(name, val);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-attr", function(args) {
|
||||
if (args[0] && args[0].removeAttribute) args[0].removeAttribute(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-attr?", function(args) {
|
||||
return !!(args[0] && args[0].hasAttribute && args[0].hasAttribute(args[1]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-attr-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.attributes) return [];
|
||||
var r = [];
|
||||
for (var i = 0; i < el.attributes.length; i++) {
|
||||
r.push([el.attributes[i].name, el.attributes[i].value]);
|
||||
}
|
||||
return r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 4. DOM Content
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-text-content", function(args) {
|
||||
var el = args[0];
|
||||
return el ? el.textContent || el.nodeValue || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-text-content", function(args) {
|
||||
var el = args[0], s = args[1];
|
||||
if (el) {
|
||||
if (el.nodeType === 3 || el.nodeType === 8) el.nodeValue = s;
|
||||
else el.textContent = s;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-inner-html", function(args) {
|
||||
return args[0] && args[0].innerHTML != null ? args[0].innerHTML : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-inner-html", function(args) {
|
||||
if (args[0]) args[0].innerHTML = args[1] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-adjacent-html", function(args) {
|
||||
var el = args[0], pos = args[1], html = args[2];
|
||||
if (el && el.insertAdjacentHTML) el.insertAdjacentHTML(pos, html);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body-inner-html", function(args) {
|
||||
var doc = args[0];
|
||||
return doc && doc.body ? doc.body.innerHTML : "";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 5. DOM Structure & Navigation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-parent", function(args) { return args[0] ? args[0].parentNode || NIL : NIL; });
|
||||
K.registerNative("dom-first-child", function(args) { return args[0] ? args[0].firstChild || NIL : NIL; });
|
||||
K.registerNative("dom-next-sibling", function(args) { return args[0] ? args[0].nextSibling || NIL : NIL; });
|
||||
K.registerNative("dom-id", function(args) { return args[0] && args[0].id ? args[0].id : NIL; });
|
||||
K.registerNative("dom-node-type", function(args) { return args[0] ? args[0].nodeType : 0; });
|
||||
K.registerNative("dom-node-name", function(args) { return args[0] ? args[0].nodeName : ""; });
|
||||
K.registerNative("dom-tag-name", function(args) { return args[0] && args[0].tagName ? args[0].tagName : ""; });
|
||||
|
||||
K.registerNative("dom-child-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
K.registerNative("dom-child-nodes", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 6. DOM Insertion & Removal
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-append", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.appendChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-prepend", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.insertBefore(child, parent.firstChild);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-before", function(args) {
|
||||
var parent = args[0], node = args[1], ref = args[2];
|
||||
if (parent && node) parent.insertBefore(node, ref || null);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-after", function(args) {
|
||||
var ref = args[0], node = args[1];
|
||||
if (ref && ref.parentNode && node) {
|
||||
ref.parentNode.insertBefore(node, ref.nextSibling);
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove", function(args) {
|
||||
var node = args[0];
|
||||
if (node && node.parentNode) node.parentNode.removeChild(node);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-child", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child && child.parentNode === parent) parent.removeChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-replace-child", function(args) {
|
||||
var parent = args[0], newC = args[1], oldC = args[2];
|
||||
if (parent && newC && oldC) parent.replaceChild(newC, oldC);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-children-after", function(args) {
|
||||
var marker = args[0];
|
||||
if (!marker || !marker.parentNode) return NIL;
|
||||
var parent = marker.parentNode;
|
||||
while (marker.nextSibling) parent.removeChild(marker.nextSibling);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-append-to-head", function(args) {
|
||||
if (_hasDom && args[0]) document.head.appendChild(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 7. DOM Type Checks
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-is-fragment?", function(args) { return args[0] ? args[0].nodeType === 11 : false; });
|
||||
K.registerNative("dom-is-child-of?", function(args) { return !!(args[1] && args[0] && args[0].parentNode === args[1]); });
|
||||
K.registerNative("dom-is-active-element?", function(args) { return _hasDom && args[0] === document.activeElement; });
|
||||
K.registerNative("dom-is-input-element?", function(args) {
|
||||
if (!args[0] || !args[0].tagName) return false;
|
||||
var t = args[0].tagName;
|
||||
return t === "INPUT" || t === "TEXTAREA" || t === "SELECT";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 8. DOM Styles & Classes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-style", function(args) {
|
||||
return args[0] && args[0].style ? args[0].style[args[1]] || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-style", function(args) {
|
||||
if (args[0] && args[0].style) args[0].style[args[1]] = args[2];
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-add-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.add(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.remove(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-class?", function(args) {
|
||||
return !!(args[0] && args[0].classList && args[0].classList.contains(args[1]));
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 9. DOM Properties & Data
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-prop", function(args) { return args[0] ? args[0][args[1]] : NIL; });
|
||||
K.registerNative("dom-set-prop", function(args) { if (args[0]) args[0][args[1]] = args[2]; return NIL; });
|
||||
|
||||
K.registerNative("dom-set-data", function(args) {
|
||||
var el = args[0], key = args[1], val = args[2];
|
||||
if (el) { if (!el._sxData) el._sxData = {}; el._sxData[key] = val; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-get-data", function(args) {
|
||||
var el = args[0], key = args[1];
|
||||
return (el && el._sxData) ? (el._sxData[key] != null ? el._sxData[key] : NIL) : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-call-method", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj && typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, callArgs); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 10. DOM Events
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-listen", function(args) {
|
||||
var el = args[0], name = args[1], handler = args[2];
|
||||
if (!_hasDom || !el) return function() {};
|
||||
|
||||
// handler is a wrapped SX lambda (JS function with __sx_handle).
|
||||
// Wrap it to:
|
||||
// - Pass the event object as arg (or no args for 0-arity handlers)
|
||||
// - Catch errors from the CEK machine
|
||||
var arity = K.fnArity(handler);
|
||||
var wrapped;
|
||||
if (arity === 0) {
|
||||
wrapped = function(_e) {
|
||||
try { K.callFn(handler, []); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
} else {
|
||||
wrapped = function(e) {
|
||||
try { K.callFn(handler, [e]); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
}
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
});
|
||||
|
||||
K.registerNative("dom-dispatch", function(args) {
|
||||
if (!_hasDom || !args[0]) return false;
|
||||
var evt = new CustomEvent(args[1], { bubbles: true, cancelable: true, detail: args[2] || {} });
|
||||
return args[0].dispatchEvent(evt);
|
||||
});
|
||||
|
||||
K.registerNative("event-detail", function(args) {
|
||||
return (args[0] && args[0].detail != null) ? args[0].detail : NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 11. Browser Navigation & History
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("browser-location-href", function(_args) {
|
||||
return typeof location !== "undefined" ? location.href : "";
|
||||
});
|
||||
|
||||
K.registerNative("browser-same-origin?", function(args) {
|
||||
try { return new URL(args[0], location.href).origin === location.origin; }
|
||||
catch (e) { return true; }
|
||||
});
|
||||
|
||||
K.registerNative("browser-push-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.pushState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-replace-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.replaceState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-navigate", function(args) {
|
||||
if (typeof location !== "undefined") location.assign(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-reload", function(_args) {
|
||||
if (typeof location !== "undefined") location.reload();
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-scroll-to", function(args) {
|
||||
if (typeof window !== "undefined") window.scrollTo(args[0] || 0, args[1] || 0);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-media-matches?", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.matchMedia(args[0]).matches;
|
||||
});
|
||||
|
||||
K.registerNative("browser-confirm", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.confirm(args[0]);
|
||||
});
|
||||
|
||||
K.registerNative("browser-prompt", function(args) {
|
||||
if (typeof window === "undefined") return NIL;
|
||||
var r = window.prompt(args[0]);
|
||||
return r === null ? NIL : r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 12. Timers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-timeout", function(args) {
|
||||
var fn = args[0], ms = args[1] || 0;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] timeout error:", e); } }
|
||||
: fn;
|
||||
return setTimeout(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("set-interval", function(args) {
|
||||
var fn = args[0], ms = args[1] || 1000;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] interval error:", e); } }
|
||||
: fn;
|
||||
return setInterval(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("clear-timeout", function(args) { clearTimeout(args[0]); return NIL; });
|
||||
K.registerNative("clear-interval", function(args) { clearInterval(args[0]); return NIL; });
|
||||
K.registerNative("now-ms", function(_args) {
|
||||
return (typeof performance !== "undefined") ? performance.now() : Date.now();
|
||||
});
|
||||
|
||||
K.registerNative("request-animation-frame", function(args) {
|
||||
var fn = args[0];
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] raf error:", e); } }
|
||||
: fn;
|
||||
if (typeof requestAnimationFrame !== "undefined") requestAnimationFrame(cb);
|
||||
else setTimeout(cb, 16);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 13. Promises
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("promise-resolve", function(args) { return Promise.resolve(args[0]); });
|
||||
|
||||
K.registerNative("promise-then", function(args) {
|
||||
var p = args[0];
|
||||
if (!p || !p.then) return p;
|
||||
var onResolve = function(v) { return K.callFn(args[1], [v]); };
|
||||
var onReject = args[2] ? function(e) { return K.callFn(args[2], [e]); } : undefined;
|
||||
return onReject ? p.then(onResolve, onReject) : p.then(onResolve);
|
||||
});
|
||||
|
||||
K.registerNative("promise-catch", function(args) {
|
||||
if (!args[0] || !args[0].catch) return args[0];
|
||||
return args[0].catch(function(e) { return K.callFn(args[1], [e]); });
|
||||
});
|
||||
|
||||
K.registerNative("promise-delayed", function(args) {
|
||||
return new Promise(function(resolve) {
|
||||
setTimeout(function() { resolve(args[1]); }, args[0]);
|
||||
});
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 14. Abort Controllers
|
||||
// =========================================================================
|
||||
|
||||
var _controllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
var _targetControllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
|
||||
K.registerNative("new-abort-controller", function(_args) {
|
||||
return typeof AbortController !== "undefined" ? new AbortController() : { signal: null, abort: function() {} };
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous", function(args) {
|
||||
if (_controllers) { var prev = _controllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller", function(args) {
|
||||
if (_controllers) _controllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous-target", function(args) {
|
||||
if (_targetControllers) { var prev = _targetControllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller-target", function(args) {
|
||||
if (_targetControllers) _targetControllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("controller-signal", function(args) { return args[0] ? args[0].signal : NIL; });
|
||||
K.registerNative("is-abort-error", function(args) { return args[0] && args[0].name === "AbortError"; });
|
||||
|
||||
// =========================================================================
|
||||
// 15. Fetch
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("fetch-request", function(args) {
|
||||
var config = args[0], successFn = args[1], errorFn = args[2];
|
||||
var opts = { method: config.method, headers: config.headers };
|
||||
if (config.signal) opts.signal = config.signal;
|
||||
if (config.body && config.method !== "GET") opts.body = config.body;
|
||||
if (config["cross-origin"]) opts.credentials = "include";
|
||||
|
||||
return fetch(config.url, opts).then(function(resp) {
|
||||
return resp.text().then(function(text) {
|
||||
var getHeader = function(name) {
|
||||
var v = resp.headers.get(name);
|
||||
return v === null ? NIL : v;
|
||||
};
|
||||
return K.callFn(successFn, [resp.ok, resp.status, getHeader, text]);
|
||||
});
|
||||
}).catch(function(err) {
|
||||
return K.callFn(errorFn, [err]);
|
||||
});
|
||||
});
|
||||
|
||||
K.registerNative("csrf-token", function(_args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var m = document.querySelector('meta[name="csrf-token"]');
|
||||
return m ? m.getAttribute("content") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-cross-origin", function(args) {
|
||||
try {
|
||||
var h = new URL(args[0], location.href).hostname;
|
||||
return h !== location.hostname &&
|
||||
(h.indexOf(".rose-ash.com") >= 0 || h.indexOf(".localhost") >= 0);
|
||||
} catch (e) { return false; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 16. localStorage
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("local-storage-get", function(args) {
|
||||
try { var v = localStorage.getItem(args[0]); return v === null ? NIL : v; }
|
||||
catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-set", function(args) {
|
||||
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-remove", function(args) {
|
||||
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 17. Document Head & Title
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-document-title", function(args) {
|
||||
if (_hasDom) document.title = args[0] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("remove-head-element", function(args) {
|
||||
if (_hasDom) {
|
||||
var el = document.head.querySelector(args[0]);
|
||||
if (el) el.remove();
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 18. Logging
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("log-info", function(args) { console.log("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-warn", function(args) { console.warn("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-error", function(args) { console.error("[sx]", args[0]); return NIL; });
|
||||
|
||||
// =========================================================================
|
||||
// 19. JSON
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("json-parse", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return {}; }
|
||||
});
|
||||
|
||||
K.registerNative("try-parse-json", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 20. Processing markers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("mark-processed!", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
if (el) { if (!el._sxProcessed) el._sxProcessed = {}; el._sxProcessed[key] = true; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-processed?", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
return !!(el && el._sxProcessed && el._sxProcessed[key]);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// Public Sx API (wraps SxKernel for compatibility with existing code)
|
||||
// =========================================================================
|
||||
|
||||
var Sx = {
|
||||
// Core (delegated to WASM engine)
|
||||
parse: K.parse,
|
||||
eval: K.eval,
|
||||
evalExpr: K.evalExpr,
|
||||
load: K.load,
|
||||
loadSource: K.loadSource,
|
||||
renderToHtml: K.renderToHtml,
|
||||
typeOf: K.typeOf,
|
||||
inspect: K.inspect,
|
||||
engine: K.engine,
|
||||
|
||||
// Will be populated after web adapters load:
|
||||
// mount, hydrate, processElements, etc.
|
||||
};
|
||||
|
||||
global.Sx = Sx;
|
||||
global.SxKernel = K; // Keep kernel available for direct access
|
||||
|
||||
console.log("[sx-platform] registered, engine:", K.engine());
|
||||
|
||||
} // end initPlatform
|
||||
|
||||
initPlatform();
|
||||
|
||||
})(typeof globalThis !== "undefined" ? globalThis : this);
|
||||
946
hosts/ocaml/browser/sx_browser.ml
Normal file
946
hosts/ocaml/browser/sx_browser.ml
Normal file
@@ -0,0 +1,946 @@
|
||||
(** sx_browser.ml — OCaml SX engine compiled to WASM/JS for browser use.
|
||||
|
||||
Exposes the CEK machine, parser, and primitives as a global [Sx] object
|
||||
that the thin JS platform layer binds to. *)
|
||||
|
||||
open Js_of_ocaml
|
||||
open Sx_types
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Value conversion: OCaml <-> JS *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Opaque value handle table *)
|
||||
(* *)
|
||||
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
|
||||
(* stored in a handle table and represented on the JS side as objects *)
|
||||
(* with an __sx_handle integer key. This preserves identity across *)
|
||||
(* the JS↔OCaml boundary — the same handle always resolves to the *)
|
||||
(* same OCaml value. *)
|
||||
(* *)
|
||||
(* Callable values (Lambda, NativeFn, Continuation) are additionally *)
|
||||
(* wrapped as JS functions so they can be used directly as event *)
|
||||
(* listeners, setTimeout callbacks, etc. *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let _next_handle = ref 0
|
||||
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
|
||||
|
||||
(** Store a value in the handle table, return its handle id. *)
|
||||
let alloc_handle (v : value) : int =
|
||||
let id = !_next_handle in
|
||||
incr _next_handle;
|
||||
Hashtbl.replace _handle_table id v;
|
||||
id
|
||||
|
||||
(** Look up a value by handle. *)
|
||||
let get_handle (id : int) : value =
|
||||
match Hashtbl.find_opt _handle_table id with
|
||||
| Some v -> v
|
||||
| None -> raise (Eval_error (Printf.sprintf "Invalid SX handle: %d" id))
|
||||
|
||||
(** Late-bound reference to global env (set after global_env is created). *)
|
||||
let _global_env_ref : env option ref = ref None
|
||||
let get_global_env () = match !_global_env_ref with
|
||||
| Some e -> e | None -> raise (Eval_error "Global env not initialized")
|
||||
|
||||
(** Call an SX callable through the CEK machine.
|
||||
Constructs (fn arg1 arg2 ...) and evaluates it. *)
|
||||
let call_sx_fn (fn : value) (args : value list) : value =
|
||||
Sx_ref.eval_expr (List (fn :: args)) (Env (get_global_env ()))
|
||||
|
||||
(** Convert an OCaml SX value to a JS representation.
|
||||
Primitive types map directly.
|
||||
Callable values become JS functions (with __sx_handle).
|
||||
Other compound types become tagged objects (with __sx_handle). *)
|
||||
let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
match v with
|
||||
| Nil -> Js.Unsafe.inject Js.null
|
||||
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
||||
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
||||
| String s -> Js.Unsafe.inject (Js.string s)
|
||||
| Symbol s ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "symbol"));
|
||||
("name", Js.Unsafe.inject (Js.string s)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Keyword k ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "keyword"));
|
||||
("name", Js.Unsafe.inject (Js.string k)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| List items ->
|
||||
let arr = items |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| ListRef r ->
|
||||
let arr = !r |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Dict d ->
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "_type") (Js.string "dict");
|
||||
Hashtbl.iter (fun k v ->
|
||||
Js.Unsafe.set obj (Js.string k) (value_to_js v)
|
||||
) d;
|
||||
Js.Unsafe.inject obj
|
||||
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
||||
(* Callable values: wrap as JS functions *)
|
||||
| Lambda _ | NativeFn _ | Continuation _ ->
|
||||
let handle = alloc_handle v in
|
||||
(* Create a JS function that calls back into the CEK machine.
|
||||
Use _tagFn helper (registered on globalThis) to create a function
|
||||
with __sx_handle and _type properties that survive js_of_ocaml
|
||||
return-value wrapping. *)
|
||||
let inner = Js.wrap_callback (fun args_js ->
|
||||
try
|
||||
let arg = js_to_value args_js in
|
||||
let args = match arg with Nil -> [] | _ -> [arg] in
|
||||
let result = call_sx_fn v args in
|
||||
value_to_js result
|
||||
with Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callback error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
) in
|
||||
let tag_fn = Js.Unsafe.get Js.Unsafe.global (Js.string "__sxTagFn") in
|
||||
Js.Unsafe.fun_call tag_fn [|
|
||||
Js.Unsafe.inject inner;
|
||||
Js.Unsafe.inject handle;
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|]
|
||||
(* Non-callable compound values: tagged objects with handle *)
|
||||
| Component c ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "component"));
|
||||
("name", Js.Unsafe.inject (Js.string c.c_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Island i ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "island"));
|
||||
("name", Js.Unsafe.inject (Js.string i.i_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Signal _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "signal"));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string (type_of v)));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
|
||||
(** Convert a JS value back to an OCaml SX value. *)
|
||||
and js_to_value (js : Js.Unsafe.any) : value =
|
||||
(* Check null/undefined *)
|
||||
if Js.Unsafe.equals js Js.null || Js.Unsafe.equals js Js.undefined then
|
||||
Nil
|
||||
else
|
||||
let ty = Js.to_string (Js.typeof js) in
|
||||
match ty with
|
||||
| "number" ->
|
||||
Number (Js.float_of_number (Js.Unsafe.coerce js))
|
||||
| "boolean" ->
|
||||
Bool (Js.to_bool (Js.Unsafe.coerce js))
|
||||
| "string" ->
|
||||
String (Js.to_string (Js.Unsafe.coerce js))
|
||||
| "function" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX callable *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
else
|
||||
(* Plain JS function — wrap as NativeFn *)
|
||||
NativeFn ("js-callback", fun args ->
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call js
|
||||
(Array.map (fun a -> a) js_args) in
|
||||
js_to_value result)
|
||||
| "object" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX value *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
end else begin
|
||||
(* Check for _type tag *)
|
||||
let type_field = Js.Unsafe.get js (Js.string "_type") in
|
||||
if Js.Unsafe.equals type_field Js.undefined then begin
|
||||
(* Check if it's an array *)
|
||||
let is_arr = Js.to_bool (Js.Unsafe.global##._Array##isArray js) in
|
||||
if is_arr then begin
|
||||
let len_js = Js.Unsafe.get js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len_js) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
end else begin
|
||||
(* Plain JS object — convert to dict *)
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
done;
|
||||
Dict d
|
||||
end
|
||||
end else begin
|
||||
let tag = Js.to_string (Js.Unsafe.coerce type_field) in
|
||||
match tag with
|
||||
| "symbol" ->
|
||||
Symbol (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "keyword" ->
|
||||
Keyword (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "list" ->
|
||||
let items_js = Js.Unsafe.get js (Js.string "items") in
|
||||
let len = Js.Unsafe.get items_js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
| "dict" ->
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
if k <> "_type" then begin
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
end
|
||||
done;
|
||||
Dict d
|
||||
| _ -> Nil
|
||||
end
|
||||
end
|
||||
| _ -> Nil
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Global environment *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let global_env = make_env ()
|
||||
let () = _global_env_ref := Some global_env
|
||||
|
||||
(* Render mode flag — set true during renderToHtml/loadSource calls
|
||||
that should dispatch HTML tags to the renderer. *)
|
||||
let _sx_render_mode = ref false
|
||||
|
||||
(* Register JS helpers.
|
||||
__sxTagFn: tag a function with __sx_handle and _type properties.
|
||||
__sxR: side-channel for return values (bypasses Js.wrap_callback
|
||||
which strips custom properties from function objects). *)
|
||||
let () =
|
||||
let tag_fn = Js.Unsafe.pure_js_expr
|
||||
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })" in
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxTagFn") tag_fn
|
||||
|
||||
(** Store a value in the side-channel and return a sentinel.
|
||||
The JS wrapper picks up __sxR instead of the return value. *)
|
||||
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v;
|
||||
v
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Core API functions *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(** Parse SX source string into a list of values. *)
|
||||
let api_parse src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let values = Sx_parser.parse_all src in
|
||||
let arr = values |> List.map value_to_js |> Array.of_list in
|
||||
Js.Unsafe.inject (Js.array arr)
|
||||
with Parse_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Serialize an SX value to source text. *)
|
||||
let api_stringify v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Evaluate a single SX expression in the global environment. *)
|
||||
let api_eval_expr expr_js env_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let _env = if Js.Unsafe.equals env_js Js.undefined then global_env
|
||||
else global_env in
|
||||
try
|
||||
let result = Sx_ref.eval_expr expr (Env _env) in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Evaluate SX source string and return the last result. *)
|
||||
let api_eval src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let result = List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr env
|
||||
) Nil exprs in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Run the CEK machine on an expression, return result. *)
|
||||
let api_cek_run expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
try
|
||||
let state = Sx_ref.make_cek_state expr (Env global_env) Nil in
|
||||
let result = Sx_ref.cek_run_iterative state in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Render SX expression to HTML string. *)
|
||||
let api_render_to_html expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let prev = !_sx_render_mode in
|
||||
_sx_render_mode := true;
|
||||
try
|
||||
let html = Sx_render.render_to_html expr global_env in
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string html)
|
||||
with Eval_error msg ->
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Load SX source for side effects (define, defcomp, defmacro). *)
|
||||
let api_load src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Get the type of an SX value. *)
|
||||
let api_type_of v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|
||||
(** Inspect an SX value (debug string). *)
|
||||
let api_inspect v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Get engine identity. *)
|
||||
let api_engine () =
|
||||
Js.Unsafe.inject (Js.string "ocaml-cek-wasm")
|
||||
|
||||
(** Register a JS callback as a named native function in the global env.
|
||||
JS callback receives JS-converted args and should return a JS value. *)
|
||||
let api_register_native name_js callback_js =
|
||||
let name = Js.to_string name_js in
|
||||
let native_fn args =
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call callback_js
|
||||
[| Js.Unsafe.inject (Js.array js_args) |] in
|
||||
js_to_value result
|
||||
in
|
||||
ignore (env_bind global_env name (NativeFn (name, native_fn)));
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Call an SX callable (lambda, native fn) with JS args.
|
||||
fn_js can be a wrapped SX callable (with __sx_handle) or a JS value.
|
||||
args_js is a JS array of arguments. *)
|
||||
let api_call_fn fn_js args_js =
|
||||
try
|
||||
let fn = js_to_value fn_js in
|
||||
let args_arr = Js.to_array (Js.Unsafe.coerce args_js) in
|
||||
let args = Array.to_list (Array.map js_to_value args_arr) in
|
||||
let result = call_sx_fn fn args in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" (Printexc.to_string exn))) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Check if a JS value is a wrapped SX callable. *)
|
||||
let api_is_callable fn_js =
|
||||
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
else
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
Js.Unsafe.inject (Js.bool (is_callable v))
|
||||
end else
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
|
||||
(** Get the parameter count of an SX callable (for zero-arg optimization). *)
|
||||
let api_fn_arity fn_js =
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if Js.Unsafe.equals handle_field Js.undefined then
|
||||
Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
else
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
match v with
|
||||
| Lambda l -> Js.Unsafe.inject (Js.number_of_float (float_of_int (List.length l.l_params)))
|
||||
| _ -> Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
|
||||
(** Load and evaluate SX source string with error wrapping (for test runner). *)
|
||||
let api_load_source src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Register global Sx object *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Platform test functions (registered in global env) *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let () =
|
||||
let bind name fn =
|
||||
ignore (env_bind global_env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
(* --- Deep equality --- *)
|
||||
let rec deep_equal a b =
|
||||
match a, b with
|
||||
| Nil, Nil -> true
|
||||
| Bool a, Bool b -> a = b
|
||||
| Number a, Number b -> a = b
|
||||
| String a, String b -> a = b
|
||||
| Symbol a, Symbol b -> a = b
|
||||
| Keyword a, Keyword b -> a = b
|
||||
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
||||
List.length a = List.length b && List.for_all2 deep_equal a b
|
||||
| Dict a, Dict b ->
|
||||
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
||||
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
||||
List.length ka = List.length kb &&
|
||||
List.for_all (fun k ->
|
||||
Hashtbl.mem b k &&
|
||||
deep_equal
|
||||
(match Hashtbl.find_opt a k with Some v -> v | None -> Nil)
|
||||
(match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka
|
||||
| Lambda _, Lambda _ -> a == b
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
in
|
||||
|
||||
(* --- try-call --- *)
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
ignore (Sx_ref.eval_expr (List [thunk]) (Env global_env));
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true); Dict d
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String msg); Dict d
|
||||
| exn ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String (Printexc.to_string exn)); Dict d)
|
||||
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
||||
|
||||
(* --- Evaluation --- *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String src] -> List (Sx_parser.parse_all src)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
(* --- Equality and assertions --- *)
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (deep_equal a b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
(* --- List mutation --- *)
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- Environment ops --- *)
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and key"));
|
||||
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> env_get e k
|
||||
| [Env e; Keyword k] -> env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and key"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_bind e k v
|
||||
| [Env e; Keyword k; v] -> env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_set e k v
|
||||
| [Env e; Keyword k; v] -> env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Continuation support --- *)
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = Sx_runtime.sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "continuation-fn" (fun args ->
|
||||
match args with
|
||||
| [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args ->
|
||||
(match args with [v] -> f v | _ -> f Nil))
|
||||
| _ -> raise (Eval_error "continuation-fn: expected continuation"));
|
||||
|
||||
(* --- Missing primitives --- *)
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* --- Test helpers --- *)
|
||||
bind "sx-parse-one" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
(match exprs with e :: _ -> e | [] -> Nil)
|
||||
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
||||
|
||||
bind "test-env" (fun _args -> Env (env_extend global_env));
|
||||
|
||||
(* cek-eval takes a string in the native runner *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = Sx_parser.parse_all s in
|
||||
(match exprs with
|
||||
| e :: _ -> Sx_ref.eval_expr e (Env global_env)
|
||||
| [] -> Nil)
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
(* --- Component accessors --- *)
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
(* --- Parser/symbol helpers --- *)
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
(* --- CEK stepping / introspection --- *)
|
||||
bind "make-cek-state" (fun args ->
|
||||
match args with
|
||||
| [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont
|
||||
| _ -> raise (Eval_error "make-cek-state: expected 3 args"));
|
||||
|
||||
bind "cek-step" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_step state
|
||||
| _ -> raise (Eval_error "cek-step: expected 1 arg"));
|
||||
|
||||
bind "cek-phase" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_phase state
|
||||
| _ -> raise (Eval_error "cek-phase: expected 1 arg"));
|
||||
|
||||
bind "cek-value" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_value state
|
||||
| _ -> raise (Eval_error "cek-value: expected 1 arg"));
|
||||
|
||||
bind "cek-terminal?" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_terminal_p state
|
||||
| _ -> raise (Eval_error "cek-terminal?: expected 1 arg"));
|
||||
|
||||
bind "cek-kont" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_kont state
|
||||
| _ -> raise (Eval_error "cek-kont: expected 1 arg"));
|
||||
|
||||
bind "frame-type" (fun args ->
|
||||
match args with
|
||||
| [frame] -> Sx_ref.frame_type frame
|
||||
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
|
||||
|
||||
(* --- Strict mode --- *)
|
||||
ignore (env_bind global_env "*strict*" (Bool false));
|
||||
ignore (env_bind global_env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (env_set global_env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (env_set global_env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "value-matches-type?" (fun args ->
|
||||
match args with
|
||||
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
|
||||
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
|
||||
|
||||
(* --- Apply --- *)
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
Sx_runtime.sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
(* --- Type system test helpers (for --full tests) --- *)
|
||||
bind "test-prim-types" (fun _args ->
|
||||
let d = Hashtbl.create 40 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [
|
||||
"+", "number"; "-", "number"; "*", "number"; "/", "number";
|
||||
"mod", "number"; "inc", "number"; "dec", "number";
|
||||
"abs", "number"; "min", "number"; "max", "number";
|
||||
"floor", "number"; "ceil", "number"; "round", "number";
|
||||
"str", "string"; "upper", "string"; "lower", "string";
|
||||
"trim", "string"; "join", "string"; "replace", "string";
|
||||
"format", "string"; "substr", "string";
|
||||
"=", "boolean"; "<", "boolean"; ">", "boolean";
|
||||
"<=", "boolean"; ">=", "boolean"; "!=", "boolean";
|
||||
"not", "boolean"; "nil?", "boolean"; "empty?", "boolean";
|
||||
"number?", "boolean"; "string?", "boolean"; "boolean?", "boolean";
|
||||
"list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean";
|
||||
"keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean";
|
||||
"starts-with?", "boolean"; "ends-with?", "boolean";
|
||||
"len", "number"; "first", "any"; "rest", "list";
|
||||
"last", "any"; "nth", "any"; "cons", "list";
|
||||
"append", "list"; "concat", "list"; "reverse", "list";
|
||||
"sort", "list"; "slice", "list"; "range", "list";
|
||||
"flatten", "list"; "keys", "list"; "vals", "list";
|
||||
"map-dict", "dict"; "assoc", "dict"; "dissoc", "dict";
|
||||
"merge", "dict"; "dict", "dict";
|
||||
"get", "any"; "type-of", "string";
|
||||
];
|
||||
Dict d);
|
||||
|
||||
bind "test-prim-param-types" (fun _args ->
|
||||
let d = Hashtbl.create 10 in
|
||||
let pos name typ =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" Nil; Dict d2
|
||||
in
|
||||
let pos_rest name typ rt =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" (String rt); Dict d2
|
||||
in
|
||||
Hashtbl.replace d "+" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "-" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "*" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "/" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "inc" (pos "n" "number");
|
||||
Hashtbl.replace d "dec" (pos "n" "number");
|
||||
Hashtbl.replace d "upper" (pos "s" "string");
|
||||
Hashtbl.replace d "lower" (pos "s" "string");
|
||||
Hashtbl.replace d "keys" (pos "d" "dict");
|
||||
Hashtbl.replace d "vals" (pos "d" "dict");
|
||||
Dict d);
|
||||
|
||||
(* --- HTML renderer --- *)
|
||||
Sx_render.setup_render_env global_env;
|
||||
|
||||
(* Web adapters loaded as SX source at boot time via bundle.sh *)
|
||||
|
||||
(* Wire up render mode — the CEK machine checks these to dispatch
|
||||
HTML tags and components to the renderer instead of eval. *)
|
||||
Sx_runtime._render_active_p_fn :=
|
||||
(fun () -> Bool !_sx_render_mode);
|
||||
Sx_runtime._is_render_expr_fn :=
|
||||
(fun expr -> match expr with
|
||||
| List (Symbol tag :: _) ->
|
||||
Bool (Sx_render.is_html_tag tag || tag = "<>" || tag = "raw!")
|
||||
| _ -> Bool false);
|
||||
Sx_runtime._render_expr_fn :=
|
||||
(fun expr env -> match env with
|
||||
| Env e -> RawHTML (Sx_render.render_to_html expr e)
|
||||
| _ -> RawHTML (Sx_render.render_to_html expr global_env));
|
||||
|
||||
(* --- Scope stack primitives (called by transpiled evaluator via prim_call) --- *)
|
||||
Sx_primitives.register "collect!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_collect a b | _ -> Nil);
|
||||
Sx_primitives.register "collected" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_collected a | _ -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_clear_collected a | _ -> Nil);
|
||||
Sx_primitives.register "emit!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_emit a b | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_emitted a | _ -> List []);
|
||||
Sx_primitives.register "context" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_context a b | [a] -> Sx_runtime.sx_context a Nil | _ -> Nil);
|
||||
|
||||
(* --- Fragment and raw HTML (always available, not just in render mode) --- *)
|
||||
bind "<>" (fun args ->
|
||||
let parts = List.map (fun a ->
|
||||
match a with
|
||||
| String s -> s
|
||||
| RawHTML s -> s
|
||||
| Nil -> ""
|
||||
| List _ -> Sx_render.render_to_html a global_env
|
||||
| _ -> value_to_string a
|
||||
) args in
|
||||
RawHTML (String.concat "" parts));
|
||||
|
||||
bind "raw!" (fun args ->
|
||||
match args with
|
||||
| [String s] -> RawHTML s
|
||||
| [RawHTML s] -> RawHTML s
|
||||
| [Nil] -> RawHTML ""
|
||||
| _ -> RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | _ -> value_to_string a
|
||||
) args)));
|
||||
|
||||
(* --- Scope stack functions (used by signals.sx, evaluator scope forms) --- *)
|
||||
bind "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.scope_push name value
|
||||
| _ -> raise (Eval_error "scope-push!: expected 2 args"));
|
||||
|
||||
bind "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.scope_pop _name
|
||||
| _ -> raise (Eval_error "scope-pop!: expected 1 arg"));
|
||||
|
||||
bind "provide-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.provide_push name value
|
||||
| _ -> raise (Eval_error "provide-push!: expected 2 args"));
|
||||
|
||||
bind "provide-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.provide_pop _name
|
||||
| _ -> raise (Eval_error "provide-pop!: expected 1 arg"));
|
||||
|
||||
(* define-page-helper: registers a named page helper — stub for browser *)
|
||||
bind "define-page-helper" (fun args ->
|
||||
match args with
|
||||
| [String _name; _body] -> Nil (* Page helpers are server-side; noop in browser *)
|
||||
| _ -> Nil);
|
||||
|
||||
(* cek-call: call a function via the CEK machine (used by signals, orchestration)
|
||||
(cek-call fn nil) → call with no args
|
||||
(cek-call fn (list a)) → call with args list
|
||||
(cek-call fn a) → call with single arg *)
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [f; Nil] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| [f; List arg_list] -> Sx_ref.eval_expr (List (f :: arg_list)) (Env global_env)
|
||||
| [f; a] -> Sx_ref.eval_expr (List [f; a]) (Env global_env)
|
||||
| [f] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| f :: rest -> Sx_ref.eval_expr (List (f :: rest)) (Env global_env)
|
||||
| _ -> raise (Eval_error "cek-call: expected function and args"));
|
||||
|
||||
(* not : logical negation (sometimes missing from evaluator prims) *)
|
||||
(if not (Sx_primitives.is_primitive "not") then
|
||||
bind "not" (fun args ->
|
||||
match args with
|
||||
| [v] -> Bool (not (sx_truthy v))
|
||||
| _ -> raise (Eval_error "not: expected 1 arg")))
|
||||
|
||||
let () =
|
||||
let sx = Js.Unsafe.obj [||] in
|
||||
|
||||
(* __sxWrap: wraps an OCaml API function so that after calling it,
|
||||
the JS side picks up the result from globalThis.__sxR if set.
|
||||
This bypasses js_of_ocaml stripping properties from function return values. *)
|
||||
let wrap = Js.Unsafe.pure_js_expr
|
||||
{|(function(fn) {
|
||||
return function() {
|
||||
globalThis.__sxR = undefined;
|
||||
var r = fn.apply(null, arguments);
|
||||
return globalThis.__sxR !== undefined ? globalThis.__sxR : r;
|
||||
};
|
||||
})|} in
|
||||
let w fn = Js.Unsafe.fun_call wrap [| Js.Unsafe.inject (Js.wrap_callback fn) |] in
|
||||
|
||||
(* Core evaluation *)
|
||||
Js.Unsafe.set sx (Js.string "parse")
|
||||
(Js.wrap_callback api_parse);
|
||||
Js.Unsafe.set sx (Js.string "stringify")
|
||||
(Js.wrap_callback api_stringify);
|
||||
Js.Unsafe.set sx (Js.string "eval")
|
||||
(w api_eval);
|
||||
Js.Unsafe.set sx (Js.string "evalExpr")
|
||||
(w api_eval_expr);
|
||||
Js.Unsafe.set sx (Js.string "cekRun")
|
||||
(w api_cek_run);
|
||||
Js.Unsafe.set sx (Js.string "renderToHtml")
|
||||
(Js.wrap_callback api_render_to_html);
|
||||
Js.Unsafe.set sx (Js.string "load")
|
||||
(Js.wrap_callback api_load);
|
||||
Js.Unsafe.set sx (Js.string "typeOf")
|
||||
(Js.wrap_callback api_type_of);
|
||||
Js.Unsafe.set sx (Js.string "inspect")
|
||||
(Js.wrap_callback api_inspect);
|
||||
Js.Unsafe.set sx (Js.string "engine")
|
||||
(Js.wrap_callback api_engine);
|
||||
Js.Unsafe.set sx (Js.string "registerNative")
|
||||
(Js.wrap_callback api_register_native);
|
||||
Js.Unsafe.set sx (Js.string "loadSource")
|
||||
(Js.wrap_callback api_load_source);
|
||||
Js.Unsafe.set sx (Js.string "callFn")
|
||||
(w api_call_fn);
|
||||
Js.Unsafe.set sx (Js.string "isCallable")
|
||||
(Js.wrap_callback api_is_callable);
|
||||
Js.Unsafe.set sx (Js.string "fnArity")
|
||||
(Js.wrap_callback api_fn_arity);
|
||||
|
||||
(* Expose globally *)
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||
@@ -1,18 +0,0 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
K.loadSource(fs.readFileSync("/tmp/comp_defs.txt","utf8"));
|
||||
|
||||
const pageSx = fs.readFileSync("/tmp/page_sx.txt","utf8");
|
||||
const parsed = K.parse(pageSx);
|
||||
const html = K.renderToHtml(parsed[0]);
|
||||
if (typeof html === "string" && !html.startsWith("Error:")) {
|
||||
console.log("SUCCESS! Rendered", html.length, "chars of HTML");
|
||||
console.log("Preview:", html.substring(0, 200));
|
||||
} else {
|
||||
console.log("Error:", html);
|
||||
}
|
||||
@@ -1,25 +0,0 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
|
||||
// Test signal basics
|
||||
const tests = [
|
||||
'(signal 42)',
|
||||
'(let ((s (signal 42))) (deref s))',
|
||||
'(let ((s (signal 42))) (reset! s 100) (deref s))',
|
||||
'(let ((s (signal 10))) (swap! s (fn (v) (* v 2))) (deref s))',
|
||||
'(let ((s (signal 0))) (computed (fn () (+ (deref s) 1))))',
|
||||
'(let ((idx (signal 0))) (let ((c (computed (fn () (+ (deref idx) 10))))) (deref c)))',
|
||||
];
|
||||
|
||||
for (const t of tests) {
|
||||
const r = K.eval(t);
|
||||
const s = JSON.stringify(r);
|
||||
console.log(`${t.substring(0,60)}`);
|
||||
console.log(` => ${s && s.length > 100 ? s.substring(0,100) + '...' : s}`);
|
||||
console.log();
|
||||
}
|
||||
@@ -1,2 +1,2 @@
|
||||
(lang dune 3.0)
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
|
||||
@@ -1,2 +1,3 @@
|
||||
(library
|
||||
(name sx))
|
||||
(name sx)
|
||||
(wrapped false))
|
||||
|
||||
@@ -30,21 +30,10 @@ let skip_whitespace_and_comments s =
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
(* Character classification — matches spec/parser.sx ident-start/ident-char.
|
||||
ident-start: a-z A-Z _ ~ * + - > < = / ! ? &
|
||||
ident-char: ident-start plus 0-9 . : / # , *)
|
||||
let is_ident_start = function
|
||||
| 'a'..'z' | 'A'..'Z' | '_' | '~' | '*' | '+' | '-'
|
||||
| '>' | '<' | '=' | '/' | '!' | '?' | '&' -> true
|
||||
| _ -> false
|
||||
|
||||
let is_ident_char = function
|
||||
| c when is_ident_start c -> true
|
||||
| '0'..'9' | '.' | ':' | '#' | ',' -> true
|
||||
| _ -> false
|
||||
|
||||
(* Symbol reading uses ident_char; first char must be ident_start or digit/colon *)
|
||||
let is_symbol_char = is_ident_char
|
||||
let is_symbol_char = function
|
||||
| '(' | ')' | '[' | ']' | '{' | '}' | '"' | '\'' | '`'
|
||||
| ' ' | '\t' | '\n' | '\r' | ',' | ';' -> false
|
||||
| _ -> true
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
@@ -127,16 +116,20 @@ let rec read_value s : value =
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
| ',' ->
|
||||
(* Unquote / splice-unquote — matches spec: , always triggers unquote *)
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
| '~' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '@' ->
|
||||
advance s; advance s; (* skip ~@ *)
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
| _ ->
|
||||
begin
|
||||
(* Check for unquote: , followed by non-whitespace *)
|
||||
if s.src.[s.pos] = ',' && s.pos + 1 < s.len &&
|
||||
s.src.[s.pos + 1] <> ' ' && s.src.[s.pos + 1] <> '\n' then begin
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
end else begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
|
||||
|
||||
@@ -7,12 +7,6 @@ open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
(** Forward refs for calling SX functions from primitives (breaks cycle). *)
|
||||
let _sx_call_fn : (value -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Eval_error "sx_call not initialized"))
|
||||
let _sx_trampoline_fn : (value -> value) ref =
|
||||
ref (fun v -> v)
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
@@ -30,17 +24,16 @@ let as_number = function
|
||||
| Bool false -> 0.0
|
||||
| Nil -> 0.0
|
||||
| String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan)
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v ^ ": " ^ (match v with Dict d -> (match Hashtbl.find_opt d "__signal" with Some _ -> "signal{value=" ^ (match Hashtbl.find_opt d "value" with Some v' -> value_to_string v' | None -> "?") ^ "}" | None -> "dict") | _ -> "")))
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
|
||||
|
||||
let as_string = function
|
||||
| String s -> s
|
||||
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
||||
|
||||
let rec as_list = function
|
||||
let as_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| Thunk _ as t -> as_list (!_sx_trampoline_fn t)
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
let as_bool = function
|
||||
@@ -85,10 +78,10 @@ let () =
|
||||
register "abs" (fun args ->
|
||||
match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg"));
|
||||
register "floor" (fun args ->
|
||||
match args with [a] -> Number (floor (as_number a))
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a -. 0.5))))
|
||||
| _ -> raise (Eval_error "floor: 1 arg"));
|
||||
register "ceil" (fun args ->
|
||||
match args with [a] -> Number (ceil (as_number a))
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a +. 0.5))))
|
||||
| _ -> raise (Eval_error "ceil: 1 arg"));
|
||||
register "round" (fun args ->
|
||||
match args with
|
||||
@@ -120,10 +113,7 @@ let () =
|
||||
register "parse-int" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
|
||||
| [String s; default_val] ->
|
||||
(match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> default_val)
|
||||
| [Number n] | [Number n; _] -> Number (float_of_int (int_of_float n))
|
||||
| [_; default_val] -> default_val
|
||||
| [Number n] -> Number (float_of_int (int_of_float n))
|
||||
| _ -> Nil);
|
||||
register "parse-float" (fun args ->
|
||||
match args with
|
||||
@@ -283,17 +273,8 @@ let () =
|
||||
String (String.concat sep (List.map to_string items))
|
||||
| _ -> raise (Eval_error "join: 2 args"));
|
||||
register "replace" (fun args ->
|
||||
let to_str = function
|
||||
| String s -> s | SxExpr s -> s | RawHTML s -> s
|
||||
| Keyword k -> k | Symbol s -> s
|
||||
| Nil -> "" | Bool true -> "true" | Bool false -> "false"
|
||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
||||
| Thunk _ as t -> (match !_sx_trampoline_fn t with String s -> s | v -> to_string v)
|
||||
| v -> to_string v
|
||||
in
|
||||
match args with
|
||||
| [s; old_s; new_s] ->
|
||||
let s = to_str s and old_s = to_str old_s and new_s = to_str new_s in
|
||||
| [String s; String old_s; String new_s] ->
|
||||
let ol = String.length old_s in
|
||||
if ol = 0 then String s
|
||||
else begin
|
||||
@@ -326,16 +307,8 @@ let () =
|
||||
| [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l))
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| [Dict d] -> Number (float_of_int (Hashtbl.length d))
|
||||
| [Nil] | [Bool false] -> Number 0.0
|
||||
| [Bool true] -> Number 1.0
|
||||
| [Number _] -> Number 1.0
|
||||
| [RawHTML s] -> Number (float_of_int (String.length s))
|
||||
| [SxExpr s] -> Number (float_of_int (String.length s))
|
||||
| [Spread pairs] -> Number (float_of_int (List.length pairs))
|
||||
| [Component _] | [Island _] | [Lambda _] | [NativeFn _]
|
||||
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0
|
||||
| _ -> raise (Eval_error (Printf.sprintf "len: %d args"
|
||||
(List.length args))));
|
||||
| [Nil] -> Number 0.0
|
||||
| _ -> raise (Eval_error "len: 1 arg"));
|
||||
register "first" (fun args ->
|
||||
match args with
|
||||
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
||||
@@ -351,36 +324,19 @@ let () =
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error "last: 1 list arg"));
|
||||
register "init" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with _ :: rest -> List (List.rev rest) | [] -> List [])
|
||||
| _ -> raise (Eval_error "init: 1 list arg"));
|
||||
register "nth" (fun args ->
|
||||
match args with
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| [String s; Number n] ->
|
||||
let i = int_of_float n in
|
||||
if i >= 0 && i < String.length s then String (String.make 1 s.[i])
|
||||
else Nil
|
||||
| _ -> raise (Eval_error "nth: list/string and number"));
|
||||
| _ -> raise (Eval_error "nth: list and number"));
|
||||
register "cons" (fun args ->
|
||||
match args with
|
||||
| [x; List l] | [x; ListRef { contents = l }] -> List (x :: l)
|
||||
| [x; Nil] -> List [x]
|
||||
| _ -> raise (Eval_error "cons: value and list"));
|
||||
register "append" (fun args ->
|
||||
match args with
|
||||
| [List la | ListRef { contents = la }; List lb | ListRef { contents = lb }] ->
|
||||
List (la @ lb)
|
||||
| [List la | ListRef { contents = la }; Nil] -> List la
|
||||
| [Nil; List lb | ListRef { contents = lb }] -> List lb
|
||||
| [List la | ListRef { contents = la }; v] -> List (la @ [v])
|
||||
| [v; List lb | ListRef { contents = lb }] -> List ([v] @ lb)
|
||||
| _ ->
|
||||
let all = List.concat_map as_list args in
|
||||
List all);
|
||||
let all = List.concat_map (fun a -> as_list a) args in
|
||||
List all);
|
||||
register "reverse" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
||||
@@ -534,9 +490,7 @@ let () =
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| [Nil; _] -> Nil (* nil.anything → nil *)
|
||||
| [_; _] -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
||||
| _ -> Nil);
|
||||
| _ -> raise (Eval_error "get: dict+key or list+index"));
|
||||
register "has-key?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
@@ -571,17 +525,6 @@ let () =
|
||||
match args with [Dict d] -> List (dict_keys d) | _ -> raise (Eval_error "keys: 1 dict"));
|
||||
register "vals" (fun args ->
|
||||
match args with [Dict d] -> List (dict_vals d) | _ -> raise (Eval_error "vals: 1 dict"));
|
||||
register "mutable-list" (fun _args -> ListRef (ref []));
|
||||
register "set-nth!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n; v] ->
|
||||
let i = int_of_float n in
|
||||
let l = !r in
|
||||
r := List.mapi (fun j x -> if j = i then v else x) l;
|
||||
Nil
|
||||
| [List _; _; _] ->
|
||||
raise (Eval_error "set-nth!: list is immutable, use ListRef")
|
||||
| _ -> raise (Eval_error "set-nth!: expected (list idx val)"));
|
||||
register "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> dict_set d k v; v
|
||||
@@ -606,22 +549,13 @@ let () =
|
||||
match args with [a] -> String (type_of a) | _ -> raise (Eval_error "type-of: 1 arg"));
|
||||
register "inspect" (fun args ->
|
||||
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
|
||||
register "serialize" (fun args ->
|
||||
match args with
|
||||
| [a] -> String (inspect a) (* used for dedup keys in compiler *)
|
||||
| _ -> raise (Eval_error "serialize: 1 arg"));
|
||||
register "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
register "error" (fun args ->
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "error: 1 arg"));
|
||||
register "apply" (fun args ->
|
||||
match args with
|
||||
| [NativeFn (_, f); (List a | ListRef { contents = a })] -> f a
|
||||
| [NativeFn (_, f); Nil] -> f []
|
||||
| [NativeFn (_, f); List a] -> f a
|
||||
| _ -> raise (Eval_error "apply: function and list"));
|
||||
register "identical?" (fun args ->
|
||||
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
||||
@@ -641,173 +575,4 @@ let () =
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
|
||||
(* Higher-order forms as callable primitives — used by the VM.
|
||||
The CEK machine handles these as special forms with dedicated frames;
|
||||
the VM needs them as plain callable values. *)
|
||||
(* Call any SX callable — handles NativeFn, Lambda (via trampoline), VM closures *)
|
||||
let call_any f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| _ -> !_sx_trampoline_fn (!_sx_call_fn f args)
|
||||
in
|
||||
register "map" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.map (fun x -> call_any f [x]) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "map: expected (fn list)"));
|
||||
register "map-indexed" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.mapi (fun i x -> call_any f [Number (float_of_int i); x]) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "map-indexed: expected (fn list)"));
|
||||
register "filter" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.filter (fun x -> sx_truthy (call_any f [x])) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "filter: expected (fn list)"));
|
||||
register "for-each" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List.iter (fun x -> ignore (call_any f [x])) items; Nil
|
||||
| [_; Nil] -> Nil (* nil collection = no-op *)
|
||||
| _ ->
|
||||
let types = String.concat ", " (List.map (fun v -> type_of v) args) in
|
||||
raise (Eval_error (Printf.sprintf "for-each: expected (fn list), got (%s) %d args" types (List.length args))));
|
||||
register "reduce" (fun args ->
|
||||
match args with
|
||||
| [f; init; (List items | ListRef { contents = items })] ->
|
||||
List.fold_left (fun acc x -> call_any f [acc; x]) init items
|
||||
| _ -> raise (Eval_error "reduce: expected (fn init list)"));
|
||||
register "some" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
(try List.find (fun x -> sx_truthy (call_any f [x])) items
|
||||
with Not_found -> Bool false)
|
||||
| [_; Nil] -> Bool false
|
||||
| _ -> raise (Eval_error "some: expected (fn list)"));
|
||||
register "every?" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
Bool (List.for_all (fun x -> sx_truthy (call_any f [x])) items)
|
||||
| [_; Nil] -> Bool true
|
||||
| _ -> raise (Eval_error "every?: expected (fn list)"));
|
||||
|
||||
(* ---- VM stack primitives (vm.sx platform interface) ---- *)
|
||||
register "make-vm-stack" (fun args ->
|
||||
match args with
|
||||
| [Number n] -> ListRef (ref (List.init (int_of_float n) (fun _ -> Nil)))
|
||||
| _ -> raise (Eval_error "make-vm-stack: expected (size)"));
|
||||
register "vm-stack-get" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n] -> List.nth !r (int_of_float n)
|
||||
| _ -> raise (Eval_error "vm-stack-get: expected (stack idx)"));
|
||||
register "vm-stack-set!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n; v] ->
|
||||
let i = int_of_float n in
|
||||
r := List.mapi (fun j x -> if j = i then v else x) !r; Nil
|
||||
| _ -> raise (Eval_error "vm-stack-set!: expected (stack idx val)"));
|
||||
register "vm-stack-length" (fun args ->
|
||||
match args with
|
||||
| [ListRef r] -> Number (float_of_int (List.length !r))
|
||||
| _ -> raise (Eval_error "vm-stack-length: expected (stack)"));
|
||||
register "vm-stack-copy!" (fun args ->
|
||||
match args with
|
||||
| [ListRef src; ListRef dst; Number n] ->
|
||||
let count = int_of_float n in
|
||||
let src_items = !src in
|
||||
dst := List.mapi (fun i x -> if i < count then List.nth src_items i else x) !dst; Nil
|
||||
| _ -> raise (Eval_error "vm-stack-copy!: expected (src dst count)"));
|
||||
register "primitive?" (fun args ->
|
||||
match args with
|
||||
| [String name] -> Bool (Hashtbl.mem primitives name)
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Scope stack primitives are registered by sx_server.ml / run_tests.ml
|
||||
because they use a shared scope stacks table with collect!/collected. *)
|
||||
|
||||
(* ---- Predicates needed by adapter-html.sx ---- *)
|
||||
register "lambda?" (fun args ->
|
||||
match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
register "island?" (fun args ->
|
||||
match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
register "is-else-clause?" (fun args ->
|
||||
match args with
|
||||
| [Keyword "else"] -> Bool true
|
||||
| [Bool true] -> Bool true
|
||||
| _ -> Bool false);
|
||||
register "component?" (fun args ->
|
||||
match args with [Component _] -> Bool true | [Island _] -> Bool true | _ -> Bool false);
|
||||
register "lambda-closure" (fun args ->
|
||||
match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
register "component-closure" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Env c.c_closure
|
||||
| [Island i] -> Env i.i_closure
|
||||
| _ -> Nil);
|
||||
register "component-has-children?" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| [Island i] -> Bool i.i_has_children
|
||||
| _ -> Bool false);
|
||||
register "component-name" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_name
|
||||
| [Island i] -> String i.i_name
|
||||
| _ -> Nil);
|
||||
register "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> List []);
|
||||
register "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| [Island i] -> i.i_body
|
||||
| _ -> Nil);
|
||||
register "macro?" (fun args ->
|
||||
match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
register "for-each-indexed" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List.iteri (fun i x -> ignore (call_any f [Number (float_of_int i); x])) items; Nil
|
||||
| _ -> raise (Eval_error "for-each-indexed: expected (fn list)"));
|
||||
register "lambda-params" (fun args ->
|
||||
match args with
|
||||
| [Lambda l] -> List (List.map (fun s -> String s) l.l_params)
|
||||
| _ -> List []);
|
||||
register "lambda-body" (fun args ->
|
||||
match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
(* expand-macro is registered later by run_tests.ml / sx_server.ml
|
||||
because it needs eval_expr which creates a dependency cycle *);
|
||||
register "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
register "make-raw-html" (fun args ->
|
||||
match args with [String s] -> RawHTML s | _ -> Nil);
|
||||
register "raw-html-content" (fun args ->
|
||||
match args with [RawHTML s] -> String s | _ -> String "");
|
||||
register "get-primitive" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> NativeFn (name, fn)
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| _ -> raise (Eval_error "get-primitive: expected (name)"));
|
||||
register "call-primitive" (fun args ->
|
||||
match args with
|
||||
| [String name; (List a | ListRef { contents = a })] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> fn a
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| [String name; Nil] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> fn []
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| _ -> raise (Eval_error "call-primitive: expected (name args-list)"));
|
||||
()
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -131,35 +131,44 @@ let render_html_element tag args env =
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
"<" ^ tag ^ attr_str ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let render_component_generic ~params ~has_children ~body ~closure args env =
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) params;
|
||||
if has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html body local
|
||||
|
||||
let render_component comp args env =
|
||||
match comp with
|
||||
| Component c ->
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge c.c_closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) c.c_params;
|
||||
if c.c_has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html c.c_body local
|
||||
render_component_generic
|
||||
~params:c.c_params ~has_children:c.c_has_children
|
||||
~body:c.c_body ~closure:c.c_closure args env
|
||||
| Island i ->
|
||||
render_component_generic
|
||||
~params:i.i_params ~has_children:i.i_has_children
|
||||
~body:i.i_body ~closure:i.i_closure args env
|
||||
| _ -> ""
|
||||
|
||||
let expand_macro (m : macro) args _env =
|
||||
@@ -205,12 +214,6 @@ and render_list_to_html head args env =
|
||||
match head with
|
||||
| Symbol "<>" ->
|
||||
render_children args env
|
||||
| Symbol "raw!" ->
|
||||
(* Inject pre-rendered HTML without escaping *)
|
||||
let v = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
(match v with
|
||||
| String s | RawHTML s -> s
|
||||
| _ -> value_to_string v)
|
||||
| Symbol tag when is_html_tag tag ->
|
||||
render_html_element tag args env
|
||||
| Symbol "if" ->
|
||||
@@ -255,23 +258,7 @@ and render_list_to_html head args env =
|
||||
(try
|
||||
let v = env_get env name in
|
||||
(match v with
|
||||
| Component c when c.c_affinity = "client" -> "" (* skip client-only *)
|
||||
| Component _ -> render_component v args env
|
||||
| Island _i ->
|
||||
(* Islands: SSR via the SX render-to-html from adapter-html.sx.
|
||||
It handles deref/signal/computed through the CEK correctly,
|
||||
and renders island bodies with hydration markers. *)
|
||||
(try
|
||||
let call_expr = List (Symbol name :: args) in
|
||||
let quoted = List [Symbol "quote"; call_expr] in
|
||||
let render_call = List [Symbol "render-to-html"; quoted; Env env] in
|
||||
let result = Sx_ref.eval_expr render_call (Env env) in
|
||||
(match result with
|
||||
| String s | RawHTML s -> s
|
||||
| _ -> value_to_string result)
|
||||
with e ->
|
||||
Printf.eprintf "[ssr-island] ~%s FAILED: %s\n%s\n%!" _i.i_name (Printexc.to_string e) (Printexc.get_backtrace ());
|
||||
"")
|
||||
| Component _ | Island _ -> render_component v args env
|
||||
| Macro m ->
|
||||
let expanded = expand_macro m args env in
|
||||
do_render_to_html expanded env
|
||||
|
||||
@@ -43,19 +43,15 @@ let sx_to_list = function
|
||||
let sx_call f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| VmClosure cl -> !Sx_types._vm_call_closure_ref cl args
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
(* Return the body + env for the trampoline to evaluate *)
|
||||
Thunk (l.l_body, local)
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
|
||||
|
||||
(* Initialize forward ref so primitives can call SX functions *)
|
||||
let () = Sx_primitives._sx_call_fn := sx_call
|
||||
(* Trampoline ref is set by sx_ref.ml after it's loaded *)
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
@@ -78,33 +74,11 @@ let sx_dict_set_b d k v =
|
||||
(** Get from dict or list. *)
|
||||
let get_val container key =
|
||||
match container, key with
|
||||
| CekState s, String k ->
|
||||
(match k with
|
||||
| "control" -> s.cs_control | "env" -> s.cs_env
|
||||
| "kont" -> s.cs_kont | "phase" -> String s.cs_phase
|
||||
| "value" -> s.cs_value | _ -> Nil)
|
||||
| CekFrame f, String k ->
|
||||
(match k with
|
||||
| "type" -> String f.cf_type | "env" -> f.cf_env
|
||||
| "name" -> f.cf_name | "body" -> f.cf_body
|
||||
| "remaining" -> f.cf_remaining | "f" -> f.cf_f
|
||||
| "args" -> f.cf_args | "evaled" -> f.cf_args
|
||||
| "results" -> f.cf_results | "raw-args" -> f.cf_results
|
||||
| "then" -> f.cf_body | "else" -> f.cf_name
|
||||
| "ho-type" -> f.cf_extra | "scheme" -> f.cf_extra
|
||||
| "indexed" -> f.cf_extra | "value" -> f.cf_extra
|
||||
| "phase" -> f.cf_extra | "has-effects" -> f.cf_extra
|
||||
| "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
|
||||
| "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
|
||||
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
|
||||
| "first-render" -> f.cf_extra2
|
||||
| _ -> Nil)
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| Nil, _ -> Nil (* nil.anything → nil *)
|
||||
| _, _ -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
||||
| _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key))
|
||||
|
||||
(** Register get as a primitive override — transpiled code calls (get d k). *)
|
||||
let () =
|
||||
@@ -221,13 +195,59 @@ let _is_spread_prim a = _prim "spread?" [a]
|
||||
let spread_attrs a = _prim "spread-attrs" [a]
|
||||
let make_spread a = _prim "make-spread" [a]
|
||||
|
||||
(* Scope primitives — delegate to sx_ref.py's shared scope stacks *)
|
||||
let sx_collect a b = prim_call "collect!" [a; b]
|
||||
let sx_collected a = prim_call "collected" [a]
|
||||
let sx_clear_collected a = prim_call "clear-collected!" [a]
|
||||
let sx_emit a b = prim_call "emit!" [a; b]
|
||||
let sx_emitted a = prim_call "emitted" [a]
|
||||
let sx_context a b = prim_call "context" [a; b]
|
||||
(* Scope stacks — thread-local stacks keyed by name string.
|
||||
collect!/collected implement accumulator scopes.
|
||||
emit!/emitted implement event emission scopes.
|
||||
context reads the top of a named scope stack. *)
|
||||
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
let sx_collect name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(* Push value onto the top list of the stack *)
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_collected name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_clear_collected name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key (List [] :: rest)
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
let sx_emit name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_emitted name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_context name default =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (v :: _) -> v
|
||||
| _ -> default
|
||||
|
||||
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
|
||||
(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *)
|
||||
@@ -242,15 +262,7 @@ let type_of v = String (Sx_types.type_of v)
|
||||
The transpiled CEK machine stores envs in dicts as Env values. *)
|
||||
let unwrap_env = function
|
||||
| Env e -> e
|
||||
| Dict d ->
|
||||
(* Dict used as env — wrap it. Needed by adapter-html.sx which
|
||||
passes dicts as env args (e.g. empty {} as caller env). *)
|
||||
let e = Sx_types.make_env () in
|
||||
Hashtbl.iter (fun k v -> ignore (Sx_types.env_bind e k v)) d;
|
||||
e
|
||||
| Nil ->
|
||||
Sx_types.make_env ()
|
||||
| v -> raise (Eval_error ("Expected env, got " ^ Sx_types.type_of v))
|
||||
| _ -> raise (Eval_error "Expected env")
|
||||
|
||||
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
|
||||
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
|
||||
@@ -325,57 +337,100 @@ let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call after []);
|
||||
result
|
||||
|
||||
(* Scope stack — all delegated to primitives registered in sx_server.ml *)
|
||||
let scope_push name value = prim_call "scope-push!" [name; value]
|
||||
let scope_pop name = prim_call "scope-pop!" [name]
|
||||
let scope_peek name = prim_call "scope-peek" [name]
|
||||
let scope_emit name value = prim_call "scope-emit!" [name; value]
|
||||
let provide_push name value = prim_call "scope-push!" [name; value]
|
||||
let provide_pop name = prim_call "scope-pop!" [name]
|
||||
(* Scope stack stubs — delegated to primitives when available *)
|
||||
let scope_push name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
Hashtbl.replace _scope_stacks key (value :: stack);
|
||||
Nil
|
||||
|
||||
(* Custom special forms registry — mutable dict *)
|
||||
let custom_special_forms = Dict (Hashtbl.create 4)
|
||||
let scope_pop name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key rest
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
(* register-special-form! — add a handler to the custom registry *)
|
||||
let register_special_form name handler =
|
||||
(match custom_special_forms with
|
||||
| Dict tbl -> Hashtbl.replace tbl (value_to_str name) handler; handler
|
||||
| _ -> raise (Eval_error "custom_special_forms not a dict"))
|
||||
let provide_push name value = scope_push name value
|
||||
let provide_pop name = scope_pop name
|
||||
|
||||
(* Render check/fn hooks — nil by default, set by platform if needed *)
|
||||
let render_check = Nil
|
||||
let render_fn = Nil
|
||||
(* Render mode — mutable refs so browser entry point can wire up the renderer *)
|
||||
let _render_active_p_fn : (unit -> value) ref = ref (fun () -> Bool false)
|
||||
let _render_expr_fn : (value -> value -> value) ref = ref (fun _expr _env -> Nil)
|
||||
let _is_render_expr_fn : (value -> value) ref = ref (fun _expr -> Bool false)
|
||||
|
||||
(* is-else-clause? — check if a cond/case test is an else marker *)
|
||||
let is_else_clause v =
|
||||
match v with
|
||||
| Keyword k -> Bool (k = "else" || k = "default")
|
||||
| Symbol s -> Bool (s = "else" || s = "default")
|
||||
| Bool true -> Bool true
|
||||
| _ -> Bool false
|
||||
let render_active_p () = !_render_active_p_fn ()
|
||||
let render_expr expr env = !_render_expr_fn expr env
|
||||
let is_render_expr expr = !_is_render_expr_fn expr
|
||||
|
||||
(* Signal accessors — handle both native Signal type and dict-based signals
|
||||
from web/signals.sx which use {__signal: true, value: ..., subscribers: ..., deps: ...} *)
|
||||
let is_dict_signal d = Hashtbl.mem d "__signal"
|
||||
|
||||
(* Signal accessors *)
|
||||
let signal_value s = match s with
|
||||
| Signal sig' -> sig'.s_value
|
||||
| Dict d -> (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil)
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "value"
|
||||
| _ -> raise (Eval_error ("not a signal: " ^ Sx_types.type_of s))
|
||||
|
||||
let signal_set_value s v = match s with
|
||||
| Signal sig' -> sig'.s_value <- v; v
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "value" v; v
|
||||
| _ -> raise (Eval_error "not a signal")
|
||||
let signal_set_value s v = match s with Signal sig' -> sig'.s_value <- v; v | _ -> raise (Eval_error "not a signal")
|
||||
let signal_subscribers s = match s with Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers) | _ -> List []
|
||||
let signal_add_sub_b _s _f = Nil
|
||||
let signal_remove_sub_b _s _f = Nil
|
||||
let signal_deps _s = List []
|
||||
let signal_set_deps _s _d = Nil
|
||||
let notify_subscribers _s = Nil
|
||||
|
||||
let signal_subscribers s = match s with
|
||||
| Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers)
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "subscribers"
|
||||
| _ -> List []
|
||||
|
||||
(* These use Obj.magic to accept both SX values and OCaml closures.
|
||||
The transpiler generates bare (fun () -> ...) for reactive subscribers
|
||||
but signal_add_sub_b expects value. This is a known transpiler limitation. *)
|
||||
let signal_add_sub_b s (f : _ ) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (subs @ [f_val])); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_remove_sub_b s (f : _) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f_val) subs)); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_deps s = match s with
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "deps"
|
||||
| _ -> List []
|
||||
|
||||
let signal_set_deps s deps = match s with
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "deps" deps; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let notify_subscribers s = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
List.iter (fun sub ->
|
||||
match sub with
|
||||
| NativeFn (_, f) -> ignore (f [])
|
||||
| Lambda _ -> ignore (Sx_types.env_bind (Sx_types.make_env ()) "_" Nil) (* TODO: call through CEK *)
|
||||
| _ -> ()
|
||||
) subs; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let flush_subscribers _s = Nil
|
||||
let dispose_computed _s = Nil
|
||||
|
||||
(* Island scope stubs — accept both bare OCaml fns and NativeFn values
|
||||
from transpiled code (NativeFn wrapping for value-storable lambdas). *)
|
||||
let with_island_scope _register_fn body_fn =
|
||||
match body_fn with
|
||||
| NativeFn (_, f) -> f []
|
||||
| _ -> Nil
|
||||
let register_in_scope _dispose_fn = Nil
|
||||
(* Island scope stubs — accept OCaml functions from transpiled code.
|
||||
Use Obj.magic for the same reason as signal_add_sub_b. *)
|
||||
let with_island_scope (_register_fn : _) (body_fn : _) =
|
||||
let body : unit -> value = Obj.magic body_fn in
|
||||
body ()
|
||||
let register_in_scope (_dispose_fn : _) = Nil
|
||||
|
||||
(* Component type annotation stub *)
|
||||
let component_set_param_types_b _comp _types = Nil
|
||||
@@ -413,7 +468,3 @@ let strip_prefix s prefix =
|
||||
then String (String.sub s pl (String.length s - pl))
|
||||
else String s
|
||||
| _ -> s
|
||||
|
||||
(* debug_log — no-op in production, used by CEK evaluator for component warnings *)
|
||||
let debug_log _ _ = Nil
|
||||
|
||||
|
||||
@@ -1,154 +0,0 @@
|
||||
(** Scope stacks — dynamic scope for render-time effects.
|
||||
|
||||
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
|
||||
scope-emit!/emitted/scope-emitted, context, and cookie access.
|
||||
|
||||
All functions are registered as primitives so both the CEK evaluator
|
||||
and the JIT VM can find them in the same place. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** The shared scope stacks hashtable. Each key maps to a stack of values.
|
||||
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Request cookies — set by the Python bridge before each render.
|
||||
get-cookie reads from here; set-cookie is a no-op on the server. *)
|
||||
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Clear all scope stacks. Called between requests if needed. *)
|
||||
let clear_all () = Hashtbl.clear scope_stacks
|
||||
|
||||
let () =
|
||||
let register = Sx_primitives.register in
|
||||
|
||||
(* --- Cookies --- *)
|
||||
|
||||
register "get-cookie" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
(match Hashtbl.find_opt request_cookies name with
|
||||
| Some v -> String v
|
||||
| None -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
register "set-cookie" (fun _args -> Nil);
|
||||
|
||||
(* --- Core scope stack operations --- *)
|
||||
|
||||
register "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (value :: stack); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-peek" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with v :: _ -> v | [] -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Context (scope lookup with optional default) --- *)
|
||||
|
||||
register "context" (fun args ->
|
||||
match args with
|
||||
| [String name] | [String name; _] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack, args with
|
||||
| v :: _, _ -> v
|
||||
| [], [_; default_val] -> default_val
|
||||
| [], _ -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Collect / collected / clear-collected! --- *)
|
||||
|
||||
register "collect!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
if not (List.mem value items) then
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "collected" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "clear-collected!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
|
||||
| [] -> Hashtbl.replace scope_stacks name [List []]);
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
|
||||
|
||||
register "scope-emit!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| Nil :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List [value] :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "emit!" (fun args ->
|
||||
(* Alias for scope-emit! *)
|
||||
match Sx_primitives.get_primitive "scope-emit!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "scope-emitted" (fun args ->
|
||||
match Sx_primitives.get_primitive "emitted" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-collected" (fun args ->
|
||||
match Sx_primitives.get_primitive "collected" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-clear-collected!" (fun args ->
|
||||
match Sx_primitives.get_primitive "clear-collected!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
(* --- Provide aliases --- *)
|
||||
|
||||
register "provide-push!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-push!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "provide-pop!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-pop!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil)
|
||||
@@ -37,35 +37,6 @@ and value =
|
||||
| SxExpr of string (** Opaque SX wire-format string — aser output. *)
|
||||
| Env of env (** First-class environment — used by CEK machine state dicts. *)
|
||||
| ListRef of value list ref (** Mutable list — JS-style array for append! *)
|
||||
| CekState of cek_state (** Optimized CEK machine state — avoids Dict allocation. *)
|
||||
| CekFrame of cek_frame (** Optimized CEK continuation frame. *)
|
||||
| VmClosure of vm_closure (** VM-compiled closure — callable within the VM without allocating a new VM. *)
|
||||
|
||||
(** CEK machine state — record instead of Dict for performance.
|
||||
5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
|
||||
and cek_state = {
|
||||
cs_control : value;
|
||||
cs_env : value;
|
||||
cs_kont : value;
|
||||
cs_phase : string;
|
||||
cs_value : value;
|
||||
}
|
||||
|
||||
(** CEK continuation frame — tagged record covering all 29 frame types.
|
||||
Fields are named generically; not all are used by every frame type.
|
||||
Eliminates ~100K Hashtbl allocations per page render. *)
|
||||
and cek_frame = {
|
||||
cf_type : string; (* frame type tag: "if", "let", "call", etc. *)
|
||||
cf_env : value; (* environment — every frame has this *)
|
||||
cf_name : value; (* let/define/set/scope: binding name *)
|
||||
cf_body : value; (* when/let: body expr *)
|
||||
cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
|
||||
cf_f : value; (* call/map/filter/etc: function *)
|
||||
cf_args : value; (* call: raw args; arg: evaled args *)
|
||||
cf_results : value; (* map/filter/dict: accumulated results *)
|
||||
cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
|
||||
cf_extra2 : value; (* second extra: emitted, etc. *)
|
||||
}
|
||||
|
||||
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
|
||||
and dict = (string, value) Hashtbl.t
|
||||
@@ -75,7 +46,6 @@ and lambda = {
|
||||
l_body : value;
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and component = {
|
||||
@@ -85,7 +55,6 @@ and component = {
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
mutable c_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and island = {
|
||||
@@ -110,40 +79,6 @@ and signal = {
|
||||
mutable s_deps : signal list;
|
||||
}
|
||||
|
||||
(** {1 Bytecode VM types}
|
||||
|
||||
Defined here (not in sx_vm.ml) because [vm_code.constants] references
|
||||
[value] and [lambda.l_compiled] references [vm_closure] — mutual
|
||||
recursion requires all types in one [and] chain. *)
|
||||
|
||||
(** Compiled function body — bytecode + constant pool. *)
|
||||
and vm_code = {
|
||||
vc_arity : int;
|
||||
vc_locals : int;
|
||||
vc_bytecode : int array;
|
||||
vc_constants : value array;
|
||||
}
|
||||
|
||||
(** Upvalue cell — shared mutable reference to a captured variable. *)
|
||||
and vm_upvalue_cell = {
|
||||
mutable uv_value : value;
|
||||
}
|
||||
|
||||
(** Closure — compiled code + captured upvalues + live env reference. *)
|
||||
and vm_closure = {
|
||||
vm_code : vm_code;
|
||||
vm_upvalues : vm_upvalue_cell array;
|
||||
vm_name : string option;
|
||||
vm_env_ref : (string, value) Hashtbl.t;
|
||||
vm_closure_env : env option; (** Original closure env for inner functions *)
|
||||
}
|
||||
|
||||
|
||||
(** {1 Forward ref for calling VM closures from outside the VM} *)
|
||||
|
||||
let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
@@ -239,7 +174,7 @@ let make_lambda params body closure =
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
@@ -249,7 +184,6 @@ let make_component name params has_children body closure affinity =
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
c_compiled = None;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
@@ -299,9 +233,6 @@ let type_of = function
|
||||
| Spread _ -> "spread"
|
||||
| SxExpr _ -> "sx-expr"
|
||||
| Env _ -> "env"
|
||||
| CekState _ -> "dict" (* CEK state behaves as a dict for type checks *)
|
||||
| CekFrame _ -> "dict"
|
||||
| VmClosure _ -> "function"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
@@ -315,7 +246,7 @@ let is_signal = function
|
||||
| _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) | VmClosure _ -> true
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
@@ -441,18 +372,7 @@ let rec inspect = function
|
||||
| Number n ->
|
||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s ->
|
||||
let buf = Buffer.create (String.length s + 2) in
|
||||
Buffer.add_char buf '"';
|
||||
String.iter (function
|
||||
| '"' -> Buffer.add_string buf "\\\""
|
||||
| '\\' -> Buffer.add_string buf "\\\\"
|
||||
| '\n' -> Buffer.add_string buf "\\n"
|
||||
| '\r' -> Buffer.add_string buf "\\r"
|
||||
| '\t' -> Buffer.add_string buf "\\t"
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.add_char buf '"';
|
||||
Buffer.contents buf
|
||||
| String s -> Printf.sprintf "%S" s
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
@@ -479,6 +399,3 @@ let rec inspect = function
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
| CekState _ -> "<cek-state>"
|
||||
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
|
||||
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
|
||||
|
||||
@@ -1,584 +0,0 @@
|
||||
(** SX bytecode VM — stack-based interpreter.
|
||||
|
||||
Executes bytecode produced by compiler.sx.
|
||||
Designed for speed: array-based stack, direct dispatch,
|
||||
no allocation per step (unlike the CEK machine).
|
||||
|
||||
This is the platform-native execution engine. The same bytecode
|
||||
runs on all platforms (OCaml, JS, WASM).
|
||||
|
||||
VM types (vm_code, vm_upvalue_cell, vm_closure) are defined in
|
||||
sx_types.ml to share the mutual recursion block with [value]. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Call frame — one per function invocation. *)
|
||||
type frame = {
|
||||
closure : vm_closure;
|
||||
mutable ip : int;
|
||||
base : int; (* base index in value stack for locals *)
|
||||
local_cells : (int, vm_upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *)
|
||||
}
|
||||
|
||||
(** VM state. *)
|
||||
type vm = {
|
||||
mutable stack : value array;
|
||||
mutable sp : int;
|
||||
mutable frames : frame list;
|
||||
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
|
||||
}
|
||||
|
||||
(** Forward reference for JIT compilation — set after definition. *)
|
||||
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
||||
ref (fun _ _ -> None)
|
||||
|
||||
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
||||
Prevents retrying compilation on every call. *)
|
||||
let jit_failed_sentinel = {
|
||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
|
||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||
}
|
||||
|
||||
let is_jit_failed cl = cl.vm_code.vc_arity = -1
|
||||
|
||||
let create globals =
|
||||
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals }
|
||||
|
||||
(** Stack ops — inlined for speed. *)
|
||||
let push vm v =
|
||||
if vm.sp >= Array.length vm.stack then begin
|
||||
let ns = Array.make (vm.sp * 2) Nil in
|
||||
Array.blit vm.stack 0 ns 0 vm.sp;
|
||||
vm.stack <- ns
|
||||
end;
|
||||
vm.stack.(vm.sp) <- v;
|
||||
vm.sp <- vm.sp + 1
|
||||
|
||||
let[@inline] pop vm =
|
||||
vm.sp <- vm.sp - 1;
|
||||
vm.stack.(vm.sp)
|
||||
|
||||
let[@inline] peek vm = vm.stack.(vm.sp - 1)
|
||||
|
||||
(** Read operands. *)
|
||||
let[@inline] read_u8 f =
|
||||
let v = f.closure.vm_code.vc_bytecode.(f.ip) in
|
||||
f.ip <- f.ip + 1; v
|
||||
|
||||
let[@inline] read_u16 f =
|
||||
let lo = f.closure.vm_code.vc_bytecode.(f.ip) in
|
||||
let hi = f.closure.vm_code.vc_bytecode.(f.ip + 1) in
|
||||
f.ip <- f.ip + 2;
|
||||
lo lor (hi lsl 8)
|
||||
|
||||
let[@inline] read_i16 f =
|
||||
let v = read_u16 f in
|
||||
if v >= 32768 then v - 65536 else v
|
||||
|
||||
(** Wrap a VM closure as an SX value (NativeFn). *)
|
||||
let closure_to_value cl =
|
||||
NativeFn ("vm:" ^ (match cl.vm_name with Some n -> n | None -> "anon"),
|
||||
fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args))))
|
||||
(* Placeholder — actual calls go through vm_call below *)
|
||||
|
||||
let _vm_insn_count = ref 0
|
||||
let _vm_call_count = ref 0
|
||||
let _vm_cek_count = ref 0
|
||||
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0
|
||||
let vm_report_counters () =
|
||||
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!"
|
||||
!_vm_insn_count !_vm_call_count !_vm_cek_count
|
||||
|
||||
(** Push a VM closure frame onto the current VM — no new VM allocation.
|
||||
This is the fast path for intra-VM closure calls. *)
|
||||
let push_closure_frame vm cl args =
|
||||
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
|
||||
List.iter (fun a -> push vm a) args;
|
||||
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done;
|
||||
vm.frames <- frame :: vm.frames
|
||||
|
||||
(** Convert compiler output (SX dict) to a vm_code object. *)
|
||||
let code_from_value v =
|
||||
match v with
|
||||
| Dict d ->
|
||||
let bc_list = match Hashtbl.find_opt d "bytecode" with
|
||||
| Some (List l | ListRef { contents = l }) ->
|
||||
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
|
||||
| _ -> [||]
|
||||
in
|
||||
let entries = match Hashtbl.find_opt d "constants" with
|
||||
| Some (List l | ListRef { contents = l }) -> Array.of_list l
|
||||
| _ -> [||]
|
||||
in
|
||||
let constants = Array.map (fun entry ->
|
||||
match entry with
|
||||
| Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *)
|
||||
| _ -> entry
|
||||
) entries in
|
||||
let arity = match Hashtbl.find_opt d "arity" with
|
||||
| Some (Number n) -> int_of_float n | _ -> 0
|
||||
in
|
||||
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants }
|
||||
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||] }
|
||||
|
||||
(** Execute a closure with arguments — creates a fresh VM.
|
||||
Used for entry points: JIT Lambda calls, module execution, cross-boundary. *)
|
||||
let rec call_closure cl args globals =
|
||||
incr _vm_call_count;
|
||||
let vm = create globals in
|
||||
push_closure_frame vm cl args;
|
||||
(try run vm with e -> raise e);
|
||||
pop vm
|
||||
|
||||
(** Call a value as a function — dispatch by type.
|
||||
VmClosure: pushes frame on current VM (fast intra-VM path).
|
||||
Lambda: tries JIT then falls back to CEK.
|
||||
NativeFn: calls directly. *)
|
||||
and vm_call vm f args =
|
||||
match f with
|
||||
| VmClosure cl ->
|
||||
(* Fast path: push frame on current VM — no allocation, enables TCO *)
|
||||
push_closure_frame vm cl args
|
||||
| NativeFn (_name, fn) ->
|
||||
let result = fn args in
|
||||
push vm result
|
||||
| Lambda l ->
|
||||
(match l.l_compiled with
|
||||
| Some cl when not (is_jit_failed cl) ->
|
||||
(* Cached bytecode — run on VM, fall back to CEK on runtime error *)
|
||||
(try push vm (call_closure cl args vm.globals)
|
||||
with _ -> push vm (Sx_ref.cek_call f (List args)))
|
||||
| Some _ ->
|
||||
(* Compile failed — CEK *)
|
||||
push vm (Sx_ref.cek_call f (List args))
|
||||
| None ->
|
||||
if l.l_name <> None
|
||||
then begin
|
||||
(* Pre-mark before compile attempt to prevent re-entrancy *)
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(try push vm (call_closure cl args vm.globals)
|
||||
with _ ->
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
push vm (Sx_ref.cek_call f (List args)))
|
||||
| None ->
|
||||
push vm (Sx_ref.cek_call f (List args))
|
||||
end
|
||||
else
|
||||
push vm (Sx_ref.cek_call f (List args)))
|
||||
| Component _ | Island _ ->
|
||||
(* Components use keyword-arg parsing — CEK handles this *)
|
||||
incr _vm_cek_count;
|
||||
let result = Sx_ref.cek_call f (List args) in
|
||||
push vm result
|
||||
| _ ->
|
||||
raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f))
|
||||
|
||||
(** Main execution loop — iterative (no OCaml stack growth).
|
||||
VmClosure calls push frames; the loop picks them up.
|
||||
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop. *)
|
||||
and run vm =
|
||||
while vm.frames <> [] do
|
||||
match vm.frames with
|
||||
| [] -> () (* guard handled by while condition *)
|
||||
| frame :: rest_frames ->
|
||||
let bc = frame.closure.vm_code.vc_bytecode in
|
||||
let consts = frame.closure.vm_code.vc_constants in
|
||||
if frame.ip >= Array.length bc then
|
||||
vm.frames <- [] (* bytecode exhausted — stop *)
|
||||
else begin
|
||||
let saved_ip = frame.ip in
|
||||
let op = bc.(frame.ip) in
|
||||
frame.ip <- frame.ip + 1;
|
||||
(try match op with
|
||||
(* ---- Constants ---- *)
|
||||
| 1 (* OP_CONST *) ->
|
||||
let idx = read_u16 frame in
|
||||
if idx >= Array.length consts then
|
||||
raise (Eval_error (Printf.sprintf "VM: CONST index %d out of bounds (pool size %d)"
|
||||
idx (Array.length consts)));
|
||||
push vm consts.(idx)
|
||||
| 2 (* OP_NIL *) -> push vm Nil
|
||||
| 3 (* OP_TRUE *) -> push vm (Bool true)
|
||||
| 4 (* OP_FALSE *) -> push vm (Bool false)
|
||||
| 5 (* OP_POP *) -> ignore (pop vm)
|
||||
| 6 (* OP_DUP *) -> push vm (peek vm)
|
||||
|
||||
(* ---- Variable access ---- *)
|
||||
| 16 (* OP_LOCAL_GET *) ->
|
||||
let slot = read_u8 frame in
|
||||
let v = match Hashtbl.find_opt frame.local_cells slot with
|
||||
| Some cell -> cell.uv_value
|
||||
| None ->
|
||||
let idx = frame.base + slot in
|
||||
if idx >= vm.sp then
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: LOCAL_GET slot=%d base=%d sp=%d out of bounds" slot frame.base vm.sp));
|
||||
vm.stack.(idx)
|
||||
in
|
||||
push vm v
|
||||
| 17 (* OP_LOCAL_SET *) ->
|
||||
let slot = read_u8 frame in
|
||||
let v = peek vm in
|
||||
(* Write to shared cell if captured, else to stack *)
|
||||
(match Hashtbl.find_opt frame.local_cells slot with
|
||||
| Some cell -> cell.uv_value <- v
|
||||
| None -> vm.stack.(frame.base + slot) <- v)
|
||||
| 18 (* OP_UPVALUE_GET *) ->
|
||||
let idx = read_u8 frame in
|
||||
if idx >= Array.length frame.closure.vm_upvalues then
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: UPVALUE_GET idx=%d out of bounds (have %d)" idx
|
||||
(Array.length frame.closure.vm_upvalues)));
|
||||
push vm frame.closure.vm_upvalues.(idx).uv_value
|
||||
| 19 (* OP_UPVALUE_SET *) ->
|
||||
let idx = read_u8 frame in
|
||||
frame.closure.vm_upvalues.(idx).uv_value <- peek vm
|
||||
| 20 (* OP_GLOBAL_GET *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let v = try Hashtbl.find vm.globals name with Not_found ->
|
||||
(* Walk the closure env chain for inner functions *)
|
||||
let rec env_lookup e =
|
||||
try Hashtbl.find e.bindings name
|
||||
with Not_found ->
|
||||
match e.parent with Some p -> env_lookup p | None ->
|
||||
try Sx_primitives.get_primitive name
|
||||
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
||||
in
|
||||
match frame.closure.vm_closure_env with
|
||||
| Some env -> env_lookup env
|
||||
| None ->
|
||||
try Sx_primitives.get_primitive name
|
||||
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
||||
in
|
||||
push vm v
|
||||
| 21 (* OP_GLOBAL_SET *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
(* Write to closure env if the name exists there (mutable closure vars) *)
|
||||
let written = match frame.closure.vm_closure_env with
|
||||
| Some env ->
|
||||
let rec find_env e =
|
||||
if Hashtbl.mem e.bindings name then
|
||||
(Hashtbl.replace e.bindings name (peek vm); true)
|
||||
else match e.parent with Some p -> find_env p | None -> false
|
||||
in find_env env
|
||||
| None -> false
|
||||
in
|
||||
if not written then Hashtbl.replace vm.globals name (peek vm)
|
||||
|
||||
(* ---- Control flow ---- *)
|
||||
| 32 (* OP_JUMP *) ->
|
||||
let offset = read_i16 frame in
|
||||
frame.ip <- frame.ip + offset
|
||||
| 33 (* OP_JUMP_IF_FALSE *) ->
|
||||
let offset = read_i16 frame in
|
||||
let v = pop vm in
|
||||
if not (sx_truthy v) then frame.ip <- frame.ip + offset
|
||||
| 34 (* OP_JUMP_IF_TRUE *) ->
|
||||
let offset = read_i16 frame in
|
||||
let v = pop vm in
|
||||
if sx_truthy v then frame.ip <- frame.ip + offset
|
||||
|
||||
(* ---- Function calls ---- *)
|
||||
| 48 (* OP_CALL *) ->
|
||||
let argc = read_u8 frame in
|
||||
let args = Array.init argc (fun _ -> pop vm) in
|
||||
let f = pop vm in
|
||||
let args_list = List.rev (Array.to_list args) in
|
||||
vm_call vm f args_list
|
||||
(* Loop continues — if VmClosure, new frame runs next iteration *)
|
||||
| 49 (* OP_TAIL_CALL *) ->
|
||||
let argc = read_u8 frame in
|
||||
let args = Array.init argc (fun _ -> pop vm) in
|
||||
let f = pop vm in
|
||||
let args_list = List.rev (Array.to_list args) in
|
||||
(* Drop current frame, reuse stack space — true TCO for VmClosure *)
|
||||
vm.frames <- rest_frames;
|
||||
vm.sp <- frame.base;
|
||||
vm_call vm f args_list
|
||||
| 50 (* OP_RETURN *) ->
|
||||
let result = pop vm in
|
||||
vm.frames <- rest_frames;
|
||||
vm.sp <- frame.base;
|
||||
push vm result
|
||||
(* Loop continues with caller frame *)
|
||||
| 51 (* OP_CLOSURE *) ->
|
||||
let idx = read_u16 frame in
|
||||
if idx >= Array.length consts then
|
||||
raise (Eval_error (Printf.sprintf "VM: CLOSURE idx %d >= consts %d" idx (Array.length consts)));
|
||||
let code_val = consts.(idx) in
|
||||
let code = code_from_value code_val in
|
||||
(* Read upvalue descriptors from bytecode *)
|
||||
let uv_count = match code_val with
|
||||
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
|
||||
| Some (Number n) -> int_of_float n | _ -> 0)
|
||||
| _ -> 0
|
||||
in
|
||||
let upvalues = Array.init uv_count (fun _ ->
|
||||
let is_local = read_u8 frame in
|
||||
let index = read_u8 frame in
|
||||
if is_local = 1 then begin
|
||||
(* Capture from enclosing frame's local slot.
|
||||
Create a shared cell — both parent and closure
|
||||
read/write through this cell. *)
|
||||
let cell = match Hashtbl.find_opt frame.local_cells index with
|
||||
| Some existing -> existing (* reuse existing cell *)
|
||||
| None ->
|
||||
let c = { uv_value = vm.stack.(frame.base + index) } in
|
||||
Hashtbl.replace frame.local_cells index c;
|
||||
c
|
||||
in
|
||||
cell
|
||||
end else
|
||||
(* Capture from enclosing frame's upvalue — already a shared cell *)
|
||||
frame.closure.vm_upvalues.(index)
|
||||
) in
|
||||
let cl = { vm_code = code; vm_upvalues = upvalues; vm_name = None;
|
||||
vm_env_ref = vm.globals; vm_closure_env = None } in
|
||||
push vm (VmClosure cl)
|
||||
| 52 (* OP_CALL_PRIM *) ->
|
||||
let idx = read_u16 frame in
|
||||
let argc = read_u8 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let args = List.init argc (fun _ -> pop vm) |> List.rev in
|
||||
(* Resolve thunks — the CEK evaluator does this automatically
|
||||
via trampoline, but the VM must do it explicitly before
|
||||
passing args to primitives. *)
|
||||
let args = List.map (fun v ->
|
||||
match v with
|
||||
| Thunk _ -> !Sx_primitives._sx_trampoline_fn v
|
||||
| _ -> v) args in
|
||||
let result =
|
||||
try
|
||||
(* Check primitives FIRST (native implementations of map/filter/etc.),
|
||||
then globals (which may have ho_via_cek wrappers that route
|
||||
through the CEK — these can't call VM closures). *)
|
||||
let fn_val = try Sx_primitives.get_primitive name with _ ->
|
||||
try Hashtbl.find vm.globals name with Not_found ->
|
||||
raise (Eval_error ("VM: unknown primitive " ^ name))
|
||||
in
|
||||
(match fn_val with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| _ -> Nil)
|
||||
with Eval_error msg ->
|
||||
raise (Eval_error (Printf.sprintf "%s (in CALL_PRIM \"%s\" with %d args)"
|
||||
msg name argc))
|
||||
in
|
||||
push vm result
|
||||
|
||||
(* ---- Collections ---- *)
|
||||
| 64 (* OP_LIST *) ->
|
||||
let count = read_u16 frame in
|
||||
let items = List.init count (fun _ -> pop vm) |> List.rev in
|
||||
push vm (List items)
|
||||
| 65 (* OP_DICT *) ->
|
||||
let count = read_u16 frame in
|
||||
let d = Hashtbl.create count in
|
||||
for _ = 1 to count do
|
||||
let v = pop vm in
|
||||
let k = pop vm in
|
||||
let key = match k with String s -> s | Keyword s -> s | _ -> Sx_runtime.value_to_str k in
|
||||
Hashtbl.replace d key v
|
||||
done;
|
||||
push vm (Dict d)
|
||||
|
||||
(* ---- String ops ---- *)
|
||||
| 144 (* OP_STR_CONCAT *) ->
|
||||
let count = read_u8 frame in
|
||||
let parts = List.init count (fun _ -> pop vm) |> List.rev in
|
||||
let s = String.concat "" (List.map Sx_runtime.value_to_str parts) in
|
||||
push vm (String s)
|
||||
|
||||
(* ---- Define ---- *)
|
||||
| 128 (* OP_DEFINE *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let v = peek vm in
|
||||
Hashtbl.replace vm.globals name v
|
||||
|
||||
(* ---- Inline primitives (no hashtable lookup) ---- *)
|
||||
| 160 (* OP_ADD *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with
|
||||
| Number x, Number y -> Number (x +. y)
|
||||
| String x, String y -> String (x ^ y)
|
||||
| _ -> Sx_primitives.(get_primitive "+" |> function NativeFn (_, f) -> f [a; b] | _ -> Nil))
|
||||
| 161 (* OP_SUB *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x -. y) | _ -> Nil)
|
||||
| 162 (* OP_MUL *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x *. y) | _ -> Nil)
|
||||
| 163 (* OP_DIV *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x /. y) | _ -> Nil)
|
||||
| 164 (* OP_EQ *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
(* Must normalize ListRef→List before structural compare,
|
||||
same as the "=" primitive in sx_primitives.ml *)
|
||||
let rec norm = function
|
||||
| ListRef { contents = l } -> List (List.map norm l)
|
||||
| List l -> List (List.map norm l) | v -> v in
|
||||
push vm (Bool (norm a = norm b))
|
||||
| 165 (* OP_LT *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Bool (x < y) | String x, String y -> Bool (x < y) | _ -> Bool false)
|
||||
| 166 (* OP_GT *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Bool (x > y) | String x, String y -> Bool (x > y) | _ -> Bool false)
|
||||
| 167 (* OP_NOT *) ->
|
||||
let v = pop vm in
|
||||
push vm (Bool (not (sx_truthy v)))
|
||||
| 168 (* OP_LEN *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with
|
||||
| List l | ListRef { contents = l } -> Number (float_of_int (List.length l))
|
||||
| String s -> Number (float_of_int (String.length s))
|
||||
| Dict d -> Number (float_of_int (Hashtbl.length d))
|
||||
| Nil -> Number 0.0 | _ -> Number 0.0)
|
||||
| 169 (* OP_FIRST *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with List (x :: _) | ListRef { contents = x :: _ } -> x | _ -> Nil)
|
||||
| 170 (* OP_REST *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with List (_ :: xs) | ListRef { contents = _ :: xs } -> List xs | _ -> List [])
|
||||
| 171 (* OP_NTH *) ->
|
||||
let n = pop vm and coll = pop vm in
|
||||
let i = match n with Number f -> int_of_float f | _ -> 0 in
|
||||
push vm (match coll with
|
||||
| List l | ListRef { contents = l } ->
|
||||
(try List.nth l i with _ -> Nil)
|
||||
| _ -> Nil)
|
||||
| 172 (* OP_CONS *) ->
|
||||
let coll = pop vm and x = pop vm in
|
||||
push vm (match coll with
|
||||
| List l -> List (x :: l)
|
||||
| ListRef { contents = l } -> List (x :: l)
|
||||
| Nil -> List [x]
|
||||
| _ -> List [x])
|
||||
| 173 (* OP_NEG *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (-.x) | _ -> Nil)
|
||||
| 174 (* OP_INC *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (x +. 1.0) | _ -> Nil)
|
||||
| 175 (* OP_DEC *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (x -. 1.0) | _ -> Nil)
|
||||
|
||||
| opcode ->
|
||||
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
|
||||
opcode (frame.ip - 1)))
|
||||
with Invalid_argument msg ->
|
||||
let fn_name = match frame.closure.vm_name with Some n -> n | None -> "?" in
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: %s at ip=%d op=%d in %s (base=%d sp=%d bc_len=%d consts=%d)"
|
||||
msg saved_ip op fn_name frame.base vm.sp
|
||||
(Array.length bc) (Array.length consts))))
|
||||
end
|
||||
done
|
||||
|
||||
(** Execute a compiled module (top-level bytecode). *)
|
||||
let execute_module code globals =
|
||||
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module"; vm_env_ref = globals; vm_closure_env = None } in
|
||||
let vm = create globals in
|
||||
let frame = { closure = cl; ip = 0; base = 0; local_cells = Hashtbl.create 4 } in
|
||||
for _ = 0 to code.vc_locals - 1 do push vm Nil done;
|
||||
vm.frames <- [frame];
|
||||
run vm;
|
||||
pop vm
|
||||
|
||||
|
||||
(** {1 Lazy JIT compilation} *)
|
||||
|
||||
(** Compile a lambda or component body to bytecode using the SX compiler.
|
||||
Invokes [compile] from spec/compiler.sx via the CEK machine.
|
||||
Returns a [vm_closure] ready for execution, or [None] on failure
|
||||
(safe fallback to CEK interpretation).
|
||||
|
||||
The compilation cost is a single CEK evaluation of the compiler —
|
||||
microseconds per function. The result is cached in the lambda/component
|
||||
record so subsequent calls go straight to the VM. *)
|
||||
let jit_compile_lambda (l : lambda) globals =
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
||||
try
|
||||
let compile_fn = try Hashtbl.find globals "compile"
|
||||
with Not_found -> raise (Eval_error "JIT: compiler not loaded") in
|
||||
(* Reconstruct the (fn (params) body) form so the compiler produces
|
||||
a proper closure. l.l_body is the inner body; we need the full
|
||||
function form with params so the compiled code binds them. *)
|
||||
let param_syms = List (List.map (fun s -> Symbol s) l.l_params) in
|
||||
let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in
|
||||
let quoted = List [Symbol "quote"; fn_expr] in
|
||||
let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in
|
||||
(* If the lambda has closure-captured variables, merge them into globals
|
||||
so the VM can find them via GLOBAL_GET. The compiler doesn't know
|
||||
about the enclosing scope, so closure vars get compiled as globals. *)
|
||||
let effective_globals =
|
||||
let closure = l.l_closure in
|
||||
if Hashtbl.length closure.bindings = 0 && closure.parent = None then
|
||||
globals (* no closure vars — use globals directly *)
|
||||
else begin
|
||||
(* Merge: closure bindings layered on top of globals.
|
||||
Use a shallow copy so we don't pollute the real globals. *)
|
||||
let merged = Hashtbl.copy globals in
|
||||
let rec inject env =
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace merged k v) env.bindings;
|
||||
match env.parent with Some p -> inject p | None -> ()
|
||||
in
|
||||
inject closure;
|
||||
let n = Hashtbl.length merged - Hashtbl.length globals in
|
||||
if n > 0 then
|
||||
Printf.eprintf "[jit] %s: injected %d closure bindings\n%!" fn_name n;
|
||||
merged
|
||||
end
|
||||
in
|
||||
(match result with
|
||||
| Dict d when Hashtbl.mem d "bytecode" ->
|
||||
let outer_code = code_from_value result in
|
||||
let bc = outer_code.vc_bytecode in
|
||||
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
|
||||
let idx = bc.(1) lor (bc.(2) lsl 8) in
|
||||
if idx < Array.length outer_code.vc_constants then
|
||||
let inner_val = outer_code.vc_constants.(idx) in
|
||||
let code = code_from_value inner_val in
|
||||
Some { vm_code = code; vm_upvalues = [||];
|
||||
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
|
||||
else begin
|
||||
Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
|
||||
fn_name idx (Array.length outer_code.vc_constants);
|
||||
|
||||
None
|
||||
end
|
||||
end else begin
|
||||
(* Not a closure — constant expression, alias, or simple computation.
|
||||
Execute the bytecode as a module to get the value, then wrap
|
||||
as a NativeFn if it's callable (so the CEK can dispatch to it). *)
|
||||
(try
|
||||
let value = execute_module outer_code globals in
|
||||
Printf.eprintf "[jit] RESOLVED %s: %s (bc[0]=%d)\n%!"
|
||||
fn_name (type_of value) (if Array.length bc > 0 then bc.(0) else -1);
|
||||
(* If the resolved value is a NativeFn, we can't wrap it as a
|
||||
vm_closure — just let the CEK handle it directly. Return None
|
||||
so the lambda falls through to CEK, which will find the
|
||||
resolved value in the env on next lookup. *)
|
||||
None
|
||||
with _ ->
|
||||
Printf.eprintf "[jit] SKIP %s: non-closure execution failed (bc[0]=%d, len=%d)\n%!"
|
||||
fn_name (if Array.length bc > 0 then bc.(0) else -1) (Array.length bc);
|
||||
None)
|
||||
end
|
||||
| _ ->
|
||||
Printf.eprintf "[jit] FAIL %s: compiler returned %s\n%!" fn_name (type_of result);
|
||||
None)
|
||||
with e ->
|
||||
Printf.eprintf "[jit] FAIL %s: %s\n%!" fn_name (Printexc.to_string e);
|
||||
None
|
||||
|
||||
(* Wire up forward references *)
|
||||
let () = jit_compile_ref := jit_compile_lambda
|
||||
let () = _vm_call_closure_ref := (fun cl args -> call_closure cl args cl.vm_env_ref)
|
||||
@@ -120,16 +120,12 @@
|
||||
"emitted" "sx_emitted"
|
||||
"scope-push!" "scope_push"
|
||||
"scope-pop!" "scope_pop"
|
||||
"scope-peek" "scope_peek"
|
||||
"scope-emit!" "scope_emit"
|
||||
"provide-push!" "provide_push"
|
||||
"provide-pop!" "provide_pop"
|
||||
"sx-serialize" "sx_serialize"
|
||||
"*custom-special-forms*" "custom_special_forms"
|
||||
"register-special-form!" "register_special_form"
|
||||
"*render-check*" "render_check"
|
||||
"*render-fn*" "render_fn"
|
||||
"is-else-clause?" "is_else_clause"
|
||||
"render-active?" "render_active_p"
|
||||
"is-render-expr?" "is_render_expr"
|
||||
"render-expr" "render_expr"
|
||||
"HTML_TAGS" "html_tags"
|
||||
"VOID_ELEMENTS" "void_elements"
|
||||
"BOOLEAN_ATTRS" "boolean_attrs"
|
||||
@@ -196,12 +192,15 @@
|
||||
"cek-call" "cek-run" "sx-call" "sx-apply"
|
||||
"collect!" "collected" "clear-collected!" "context" "emit!" "emitted"
|
||||
"scope-push!" "scope-pop!" "provide-push!" "provide-pop!"
|
||||
"render-active?" "render-expr" "is-render-expr?"
|
||||
"with-island-scope" "register-in-scope"
|
||||
"signal-value" "signal-set-value" "signal-subscribers"
|
||||
"signal-add-sub!" "signal-remove-sub!" "signal-deps" "signal-set-deps"
|
||||
"notify-subscribers" "flush-subscribers" "dispose-computed"
|
||||
"continuation?" "continuation-data" "make-cek-continuation"
|
||||
"dynamic-wind-call" "strip-prefix"
|
||||
"sf-defhandler" "sf-defpage" "sf-defquery" "sf-defaction"
|
||||
"make-handler-def" "make-query-def" "make-action-def" "make-page-def"
|
||||
"component-set-param-types!" "parse-comp-params" "parse-macro-params"
|
||||
"parse-keyword-args"))
|
||||
|
||||
@@ -216,15 +215,6 @@
|
||||
;; Check _known_defines (set by bootstrap.py)
|
||||
(some (fn (d) (= d name)) _known_defines)))))
|
||||
|
||||
;; Dynamic globals — top-level defines that hold SX values (not functions).
|
||||
;; When these appear as callees, use cek_call for dynamic dispatch.
|
||||
(define ml-dynamic-globals
|
||||
(list "*render-check*" "*render-fn*"))
|
||||
|
||||
(define ml-is-dyn-global?
|
||||
(fn ((name :as string))
|
||||
(some (fn (g) (= g name)) ml-dynamic-globals)))
|
||||
|
||||
;; Check if a variable is "dynamic" — locally bound to a non-function expression.
|
||||
;; These variables hold SX values (from eval-expr, get, etc.) and need cek_call
|
||||
;; when used as callees. We encode this in the set-vars list as "dyn:name".
|
||||
@@ -414,68 +404,12 @@
|
||||
(define ml-emit-dict-native
|
||||
(fn ((d :as dict) (set-vars :as list))
|
||||
(let ((items (keys d)))
|
||||
;; Optimize CEK state dicts — emit CekState record instead of Hashtbl.
|
||||
;; Detected by having exactly {control, env, kont, phase, value} keys.
|
||||
(if (and (= (len items) 5)
|
||||
(some (fn (k) (= k "control")) items)
|
||||
(some (fn (k) (= k "phase")) items)
|
||||
(some (fn (k) (= k "kont")) items))
|
||||
(str "(CekState { cs_control = " (ml-expr-inner (get d "control") set-vars)
|
||||
"; cs_env = " (ml-expr-inner (get d "env") set-vars)
|
||||
"; cs_kont = " (ml-expr-inner (get d "kont") set-vars)
|
||||
"; cs_phase = " (let ((p (get d "phase")))
|
||||
(if (= (type-of p) "string")
|
||||
(ml-quote-string p)
|
||||
(str "(match " (ml-expr-inner p set-vars)
|
||||
" with String s -> s | _ -> \"\")")))
|
||||
"; cs_value = " (ml-expr-inner (get d "value") set-vars)
|
||||
" })")
|
||||
;; Optimize CEK frame dicts — detected by having a "type" string field.
|
||||
;; Maps frame fields to generic CekFrame record slots.
|
||||
(if (and (some (fn (k) (= k "type")) items)
|
||||
(= (type-of (get d "type")) "string"))
|
||||
(let ((frame-type (get d "type"))
|
||||
(ef (fn (field) (if (some (fn (k) (= k field)) items)
|
||||
(ml-expr-inner (get d field) set-vars) "Nil"))))
|
||||
(str "(CekFrame { cf_type = " (ml-quote-string frame-type)
|
||||
"; cf_env = " (ef "env")
|
||||
"; cf_name = " (if (= frame-type "if") (ef "else") (ef "name"))
|
||||
"; cf_body = " (if (= frame-type "if") (ef "then") (ef "body"))
|
||||
"; cf_remaining = " (ef "remaining")
|
||||
"; cf_f = " (ef "f")
|
||||
"; cf_args = " (cond
|
||||
(some (fn (k) (= k "evaled")) items) (ef "evaled")
|
||||
(some (fn (k) (= k "args")) items) (ef "args")
|
||||
:else "Nil")
|
||||
"; cf_results = " (cond
|
||||
(some (fn (k) (= k "results")) items) (ef "results")
|
||||
(some (fn (k) (= k "raw-args")) items) (ef "raw-args")
|
||||
:else "Nil")
|
||||
"; cf_extra = " (cond
|
||||
(some (fn (k) (= k "ho-type")) items) (ef "ho-type")
|
||||
(some (fn (k) (= k "scheme")) items) (ef "scheme")
|
||||
(some (fn (k) (= k "indexed")) items) (ef "indexed")
|
||||
(some (fn (k) (= k "value")) items) (ef "value")
|
||||
(some (fn (k) (= k "phase")) items) (ef "phase")
|
||||
(some (fn (k) (= k "has-effects")) items) (ef "has-effects")
|
||||
(some (fn (k) (= k "match-val")) items) (ef "match-val")
|
||||
(some (fn (k) (= k "current-item")) items) (ef "current-item")
|
||||
(some (fn (k) (= k "update-fn")) items) (ef "update-fn")
|
||||
(some (fn (k) (= k "head-name")) items) (ef "head-name")
|
||||
:else "Nil")
|
||||
"; cf_extra2 = " (cond
|
||||
(some (fn (k) (= k "emitted")) items) (ef "emitted")
|
||||
(some (fn (k) (= k "effect-list")) items) (ef "effect-list")
|
||||
(some (fn (k) (= k "first-render")) items) (ef "first-render")
|
||||
:else "Nil")
|
||||
" })"))
|
||||
;; Regular dict — Hashtbl
|
||||
(str "(let _d = Hashtbl.create " (str (round (len items)))
|
||||
" in " (join "; " (map (fn (k)
|
||||
(str "Hashtbl.replace _d " (ml-quote-string k)
|
||||
" " (ml-expr-inner (get d k) set-vars)))
|
||||
items))
|
||||
"; Dict _d)"))))))
|
||||
(str "(let _d = Hashtbl.create " (str (round (len items)))
|
||||
" in " (join "; " (map (fn (k)
|
||||
(str "Hashtbl.replace _d " (ml-quote-string k)
|
||||
" " (ml-expr-inner (get d k) set-vars)))
|
||||
items))
|
||||
"; Dict _d)"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -487,12 +421,8 @@
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Non-symbol head: if head is a list (call expr), dispatch via cek_call;
|
||||
;; otherwise treat as data list
|
||||
(if (list? head)
|
||||
(str "(cek_call (" (ml-expr-inner head set-vars)
|
||||
") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
||||
(str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]"))
|
||||
;; Data list
|
||||
(str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]")
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; fn/lambda
|
||||
@@ -677,8 +607,8 @@
|
||||
;; Regular function call
|
||||
:else
|
||||
(let ((callee (ml-mangle op)))
|
||||
(if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op))
|
||||
;; Dynamic callee (local var or dynamic global) — dispatch via cek_call
|
||||
(if (ml-is-dyn-var? op set-vars)
|
||||
;; Dynamic callee (local var bound to non-fn expr) — dispatch via cek_call
|
||||
(str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
||||
;; Static callee — direct OCaml call
|
||||
(if (empty? args)
|
||||
@@ -690,9 +620,7 @@
|
||||
;; fn/lambda
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; ml-emit-fn-bare: emit a plain OCaml function (fun params -> body).
|
||||
;; Used by HO form inlining where a bare OCaml closure is needed.
|
||||
(define ml-emit-fn-bare
|
||||
(define ml-emit-fn
|
||||
(fn (expr (set-vars :as list))
|
||||
(let ((params (nth expr 1))
|
||||
(body (rest (rest expr)))
|
||||
@@ -716,25 +644,6 @@
|
||||
(ml-emit-do body all-set-vars))))
|
||||
(str "(fun " params-str " -> " ref-decls body-str ")")))))))
|
||||
|
||||
;; ml-emit-fn: emit an SX-compatible NativeFn value.
|
||||
;; Wraps the OCaml closure so it can be stored as a value, passed to
|
||||
;; signal-add-sub!, etc. The args pattern-match unpacks the value list.
|
||||
(define ml-emit-fn
|
||||
(fn (expr (set-vars :as list))
|
||||
(let ((params (nth expr 1))
|
||||
(param-strs (ml-collect-params params))
|
||||
(n (len param-strs))
|
||||
(bare (ml-emit-fn-bare expr set-vars)))
|
||||
(if (= n 0)
|
||||
;; Zero-arg: NativeFn("λ", fun _args -> body)
|
||||
(str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))")
|
||||
;; N-arg: NativeFn("λ", fun args -> match args with [a;b;...] -> body | _ -> Nil)
|
||||
(let ((match-pat (str "[" (join "; " param-strs) "]"))
|
||||
(call-args (join " " param-strs)))
|
||||
(str "(NativeFn (\"\\206\\187\", fun _args -> match _args with "
|
||||
match-pat " -> " bare " " call-args
|
||||
" | _ -> Nil))"))))))
|
||||
|
||||
(define ml-collect-params
|
||||
(fn ((params :as list))
|
||||
(ml-collect-params-loop params 0 (list))))
|
||||
@@ -1008,10 +917,7 @@
|
||||
(= (symbol-name (first val-expr)) "lambda"))))
|
||||
(is-recursive (ml-is-self-recursive? name val-expr)))
|
||||
(let ((rec-kw (if is-recursive "rec " ""))
|
||||
;; Recursive fns must be bare OCaml functions (called directly)
|
||||
(val-str (if (and is-fn is-recursive)
|
||||
(ml-emit-fn-bare val-expr set-vars)
|
||||
(ml-expr-inner val-expr set-vars)))
|
||||
(val-str (ml-expr-inner val-expr set-vars))
|
||||
(rest-str (ml-emit-do-chain args (+ i 1) set-vars)))
|
||||
(str "(let " rec-kw ml-name " = " val-str " in " rest-str ")"))))
|
||||
;; Non-define expression
|
||||
@@ -1055,12 +961,12 @@
|
||||
body-str)))
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun " param-str " -> " wrapped-body
|
||||
") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))
|
||||
;; Named function — dispatch via cek_call (fn may be NativeFn value)
|
||||
;; Named function — direct call (all defines are OCaml fns)
|
||||
(let ((fn-str (ml-expr-inner fn-arg set-vars)))
|
||||
(if needs-bool
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (cek_call " fn-str " (List [_x])))"
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (" fn-str " _x))"
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> cek_call " fn-str " (List [_x]))"
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> " fn-str " _x)"
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))))
|
||||
|
||||
(define ml-emit-ho-indexed
|
||||
@@ -1078,8 +984,8 @@
|
||||
(ml-emit-do body set-vars))))
|
||||
(str "(List (List.mapi (fun " i-param " " v-param " -> let " i-param " = Number (float_of_int " i-param ") in " body-str
|
||||
") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))
|
||||
(str "(List (List.mapi (fun _i _x -> cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [Number (float_of_int _i); _x])) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))
|
||||
(str "(List (List.mapi (fun _i _x -> " (ml-expr-inner fn-arg set-vars)
|
||||
" (Number (float_of_int _i)) _x) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))
|
||||
|
||||
(define ml-emit-reduce
|
||||
(fn ((args :as list) (set-vars :as list))
|
||||
@@ -1101,8 +1007,8 @@
|
||||
(str "_" raw-acc)))))
|
||||
(str "(List.fold_left (fun " acc-param " " x-param " -> " body-str ") "
|
||||
(ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))")))
|
||||
(str "(List.fold_left (fun _acc _x -> cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [_acc; _x])) " (ml-expr-inner init-arg set-vars)
|
||||
(str "(List.fold_left (fun _acc _x -> " (ml-expr-inner fn-arg set-vars)
|
||||
" _acc _x) " (ml-expr-inner init-arg set-vars)
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) "))")))))
|
||||
|
||||
|
||||
@@ -1124,8 +1030,8 @@
|
||||
(ml-emit-do body set-vars))))
|
||||
(str "(List.iter (fun " param-str " -> ignore (" body-str
|
||||
")) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))
|
||||
(str "(List.iter (fun _x -> ignore (cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [_x]))) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))))
|
||||
(str "(List.iter (fun _x -> ignore (" (ml-expr-inner fn-arg set-vars)
|
||||
" _x)) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1155,7 +1061,7 @@
|
||||
(str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> "
|
||||
"let _r = Hashtbl.create (Hashtbl.length _tbl) in "
|
||||
"Hashtbl.iter (fun _k _v -> "
|
||||
"Hashtbl.replace _r _k (cek_call " fn-str " (List [String _k; _v]))) _tbl; "
|
||||
"Hashtbl.replace _r _k (" fn-str " (String _k) _v)) _tbl; "
|
||||
"Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))))))
|
||||
|
||||
|
||||
|
||||
@@ -179,11 +179,6 @@ class PyEmitter:
|
||||
"*batch-depth*": "_batch_depth",
|
||||
"*batch-queue*": "_batch_queue",
|
||||
"*store-registry*": "_store_registry",
|
||||
"*custom-special-forms*": "_custom_special_forms",
|
||||
"*render-check*": "_render_check",
|
||||
"*render-fn*": "_render_fn",
|
||||
"register-special-form!": "register_special_form_b",
|
||||
"is-else-clause?": "is_else_clause_p",
|
||||
"def-store": "def_store",
|
||||
"use-store": "use_store",
|
||||
"clear-stores": "clear_stores",
|
||||
@@ -1448,7 +1443,6 @@ def compile_ref_to_py(
|
||||
_project = os.path.abspath(os.path.join(ref_dir, "..", "..", ".."))
|
||||
_source_dirs = [
|
||||
os.path.join(_project, "spec"),
|
||||
os.path.join(_project, "lib"),
|
||||
os.path.join(_project, "web"),
|
||||
ref_dir,
|
||||
]
|
||||
@@ -1499,7 +1493,6 @@ def compile_ref_to_py(
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
("forms.sx", "forms (server definition forms)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
("render.sx", "render (core)"),
|
||||
]
|
||||
# Parser before html/sx — provides serialize used by adapters
|
||||
|
||||
@@ -612,7 +612,13 @@ def inspect(x):
|
||||
return repr(x)
|
||||
|
||||
|
||||
# escape_html and escape_attr are now library functions defined in render.sx
|
||||
def escape_html(s):
|
||||
s = str(s)
|
||||
return s.replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
|
||||
|
||||
def escape_attr(s):
|
||||
return escape_html(s)
|
||||
|
||||
|
||||
def raw_html_content(x):
|
||||
@@ -836,7 +842,7 @@ def _sx_parse_int(v, default=0):
|
||||
"stdlib.text": '''
|
||||
# stdlib.text
|
||||
PRIMITIVES["pluralize"] = lambda n, s="", p="s": s if n == 1 else p
|
||||
PRIMITIVES["escape"] = lambda s: str(s).replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
PRIMITIVES["escape"] = escape_html
|
||||
PRIMITIVES["strip-tags"] = lambda s: _strip_tags(str(s))
|
||||
|
||||
import re as _re
|
||||
@@ -1640,18 +1646,13 @@ SPEC_MODULES = {
|
||||
"engine": ("engine.sx", "engine (fetch/swap/trigger pure logic)"),
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"stdlib": ("stdlib.sx", "stdlib (library functions from former primitives)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"freeze": ("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
"content": ("content.sx", "content (content-addressed computation)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# stdlib must come first — other modules use its functions.
|
||||
# freeze depends on signals; content depends on freeze.
|
||||
SPEC_MODULE_ORDER = [
|
||||
"stdlib", "deps", "engine", "page-helpers", "router", "signals", "types", "freeze", "content",
|
||||
"deps", "engine", "page-helpers", "router", "signals", "types",
|
||||
]
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
|
||||
251
hosts/python/tests/run_cek_reactive_tests.py
Normal file
251
hosts/python/tests/run_cek_reactive_tests.py
Normal file
@@ -0,0 +1,251 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek-reactive.sx — tests for deref-as-shift reactive rendering."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
sys.setrecursionlimit(20000)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# The CEK override (eval_expr = cek_run) would cause the interpreted cek.sx
|
||||
# to delegate to the transpiled CEK, not the interpreted one being tested.
|
||||
# Override both the local names AND the module-level names so that transpiled
|
||||
# functions (ho_map, call_lambda, etc.) also use tree-walk internally.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = Continuation(lambda v=NIL: v)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = sx_ref.is_primitive
|
||||
env["get-primitive"] = sx_ref.get_primitive
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives (needed for reactive-shift-deref island cleanup)
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
env["identical?"] = lambda a, b: a is b
|
||||
|
||||
# defhandler, defpage, defquery, defaction stubs
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load signals module
|
||||
print("Loading signals.sx ...")
|
||||
with open(os.path.join(_PROJECT, "web", "signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek-reactive.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_WEB_TESTS, "test-cek-reactive.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
267
hosts/python/tests/run_cek_tests.py
Normal file
267
hosts/python/tests/run_cek_tests.py
Normal file
@@ -0,0 +1,267 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek.sx using the bootstrapped evaluator with CEK module loaded."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# The CEK override (eval_expr = cek_run) would cause the interpreted cek.sx
|
||||
# to delegate to the transpiled CEK, not the interpreted one being tested.
|
||||
# Override both the local names AND the module-level names so that transpiled
|
||||
# functions (ho_map, call_lambda, etc.) also use tree-walk internally.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation(captured, rest_kont):
|
||||
"""Create a Continuation that stores captured CEK frames as data."""
|
||||
data = {"captured": captured, "rest-kont": rest_kont}
|
||||
# The fn is a dummy — invocation happens via CEK's continue-with-call
|
||||
return Continuation(lambda v=NIL: v)
|
||||
|
||||
# Monkey-patch to store data
|
||||
_orig_make_cek_cont = _make_cek_continuation
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = _orig_make_cek_cont(captured, rest_kont)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Register platform functions from sx_ref that cek.sx and eval.sx need
|
||||
# These are normally available as transpiled Python but need to be in the
|
||||
# SX env when interpreting .sx files directly.
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = lambda n: n in sx_ref.PRIMITIVES
|
||||
env["get-primitive"] = lambda n: sx_ref.PRIMITIVES.get(n)
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers used by parse-keyword-args etc
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
|
||||
# defhandler, defpage, defquery, defaction — these are registrations
|
||||
# Use the bootstrapped versions if they exist, otherwise stub
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Define cek-eval helper in SX
|
||||
for expr in parse_all("""
|
||||
(define cek-eval
|
||||
(fn (source)
|
||||
(let ((exprs (sx-parse source)))
|
||||
(let ((result nil))
|
||||
(for-each (fn (e) (set! result (eval-expr-cek e (test-env)))) exprs)
|
||||
result))))
|
||||
"""):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
108
hosts/python/tests/run_continuation_tests.py
Normal file
108
hosts/python/tests/run_continuation_tests.py
Normal file
@@ -0,0 +1,108 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-continuations.sx using the bootstrapped evaluator with continuations enabled."""
|
||||
from __future__ import annotations
|
||||
import os, sys, subprocess, tempfile
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
# Bootstrap a fresh sx_ref with continuations enabled
|
||||
print("Bootstrapping with --extensions continuations ...")
|
||||
result = subprocess.run(
|
||||
[sys.executable, os.path.join(_HERE, "..", "bootstrap.py"),
|
||||
"--extensions", "continuations"],
|
||||
capture_output=True, text=True, cwd=_PROJECT,
|
||||
)
|
||||
if result.returncode != 0:
|
||||
print("Bootstrap FAILED:")
|
||||
print(result.stderr)
|
||||
sys.exit(1)
|
||||
|
||||
# Write to temp file and import
|
||||
tmp = tempfile.NamedTemporaryFile(mode="w", suffix=".py", delete=False, dir=_HERE)
|
||||
tmp.write(result.stdout)
|
||||
tmp.close()
|
||||
|
||||
try:
|
||||
import importlib.util
|
||||
spec = importlib.util.spec_from_file_location("sx_ref_cont", tmp.name)
|
||||
mod = importlib.util.module_from_spec(spec)
|
||||
spec.loader.exec_module(mod)
|
||||
finally:
|
||||
os.unlink(tmp.name)
|
||||
|
||||
from shared.sx.types import NIL
|
||||
parse_all = mod.sx_parse
|
||||
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# CEK is now the default, but test runners need tree-walk so that
|
||||
# transpiled HO forms (ho_map, etc.) don't re-enter CEK mid-evaluation.
|
||||
eval_expr = mod._tree_walk_eval_expr
|
||||
trampoline = mod._tree_walk_trampoline
|
||||
mod.eval_expr = eval_expr
|
||||
mod.trampoline = trampoline
|
||||
env = mod.make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-continuations.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-continuations.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
164
hosts/python/tests/run_signal_tests.py
Normal file
164
hosts/python/tests/run_signal_tests.py
Normal file
@@ -0,0 +1,164 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-signals.sx using the bootstrapped evaluator with signal primitives.
|
||||
|
||||
Uses bootstrapped signal functions from sx_ref.py directly, patching apply
|
||||
to handle SX lambdas from the interpreter (test expressions create lambdas
|
||||
that need evaluator dispatch).
|
||||
"""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import make_env, scope_push, scope_pop, sx_context
|
||||
from shared.sx.types import NIL, Island, Lambda
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# --- Patch apply BEFORE anything else ---
|
||||
# Test expressions create SX Lambdas that bootstrapped code calls via apply.
|
||||
# Patch the module-level function so all bootstrapped functions see it.
|
||||
|
||||
# apply is used by swap! and other forms to call functions with arg lists
|
||||
def _apply(f, args):
|
||||
if isinstance(f, Lambda):
|
||||
return trampoline(eval_expr([f] + list(args), env))
|
||||
return f(*args)
|
||||
sx_ref.__dict__["apply"] = _apply
|
||||
|
||||
# cons needs to handle tuples from Python *args (swap! passes &rest as tuple)
|
||||
_orig_cons = sx_ref.PRIMITIVES.get("cons")
|
||||
def _cons(x, c):
|
||||
if isinstance(c, tuple):
|
||||
c = list(c)
|
||||
return [x] + (c or [])
|
||||
sx_ref.__dict__["cons"] = _cons
|
||||
sx_ref.PRIMITIVES["cons"] = _cons
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Signal functions are now pure SX (transpiled into sx_ref.py from signals.sx)
|
||||
# Wire both low-level dict-based signal functions and high-level API
|
||||
env["identical?"] = sx_ref.is_identical
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
|
||||
# Scope primitives (used by signals.sx for reactive tracking)
|
||||
env["scope-push!"] = scope_push
|
||||
env["scope-pop!"] = scope_pop
|
||||
env["context"] = sx_context
|
||||
|
||||
# Low-level signal functions (now pure SX, transpiled from signals.sx)
|
||||
env["make-signal"] = sx_ref.make_signal
|
||||
env["signal?"] = sx_ref.is_signal
|
||||
env["signal-value"] = sx_ref.signal_value
|
||||
env["signal-set-value!"] = sx_ref.signal_set_value
|
||||
env["signal-subscribers"] = sx_ref.signal_subscribers
|
||||
env["signal-add-sub!"] = sx_ref.signal_add_sub
|
||||
env["signal-remove-sub!"] = sx_ref.signal_remove_sub
|
||||
env["signal-deps"] = sx_ref.signal_deps
|
||||
env["signal-set-deps!"] = sx_ref.signal_set_deps
|
||||
|
||||
# Bootstrapped signal functions from sx_ref.py
|
||||
env["signal"] = sx_ref.signal
|
||||
env["deref"] = sx_ref.deref
|
||||
env["reset!"] = sx_ref.reset_b
|
||||
env["swap!"] = sx_ref.swap_b
|
||||
env["computed"] = sx_ref.computed
|
||||
env["effect"] = sx_ref.effect
|
||||
# batch has a bootstrapper issue with _batch_depth global variable access.
|
||||
# Wrap it to work correctly in the test context.
|
||||
def _batch(thunk):
|
||||
sx_ref._batch_depth = getattr(sx_ref, '_batch_depth', 0) + 1
|
||||
sx_ref.cek_call(thunk, None)
|
||||
sx_ref._batch_depth -= 1
|
||||
if sx_ref._batch_depth == 0:
|
||||
queue = list(sx_ref._batch_queue)
|
||||
sx_ref._batch_queue = []
|
||||
seen = []
|
||||
pending = []
|
||||
for s in queue:
|
||||
for sub in sx_ref.signal_subscribers(s):
|
||||
if sub not in seen:
|
||||
seen.append(sub)
|
||||
pending.append(sub)
|
||||
for sub in pending:
|
||||
sub()
|
||||
return NIL
|
||||
env["batch"] = _batch
|
||||
env["notify-subscribers"] = sx_ref.notify_subscribers
|
||||
env["flush-subscribers"] = sx_ref.flush_subscribers
|
||||
env["dispose-computed"] = sx_ref.dispose_computed
|
||||
env["with-island-scope"] = sx_ref.with_island_scope
|
||||
env["register-in-scope"] = sx_ref.register_in_scope
|
||||
env["callable?"] = sx_ref.is_callable
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-signals.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_WEB_TESTS, "test-signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
316
hosts/python/tests/run_tests.py
Normal file
316
hosts/python/tests/run_tests.py
Normal file
@@ -0,0 +1,316 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Run SX spec tests using the bootstrapped Python evaluator.
|
||||
|
||||
Usage:
|
||||
python3 hosts/python/tests/run_tests.py # all spec tests
|
||||
python3 hosts/python/tests/run_tests.py test-primitives # specific test
|
||||
python3 hosts/python/tests/run_tests.py --full # include optional modules
|
||||
"""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
# Increase recursion limit for TCO tests (Python's default 1000 is too low)
|
||||
sys.setrecursionlimit(5000)
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set, env_extend, env_merge,
|
||||
)
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Macro,
|
||||
)
|
||||
|
||||
# Use tree-walk evaluator
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Check for --full flag
|
||||
full_build = "--full" in sys.argv
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Test infrastructure
|
||||
# ---------------------------------------------------------------------------
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Test helpers
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
|
||||
def _deep_equal(a, b):
|
||||
if a is b:
|
||||
return True
|
||||
if a is NIL and b is NIL:
|
||||
return True
|
||||
if a is NIL or b is NIL:
|
||||
return a is None and b is NIL or b is None and a is NIL
|
||||
if type(a) != type(b):
|
||||
# number comparison: int vs float
|
||||
if isinstance(a, (int, float)) and isinstance(b, (int, float)):
|
||||
return a == b
|
||||
return False
|
||||
if isinstance(a, list):
|
||||
if len(a) != len(b):
|
||||
return False
|
||||
return all(_deep_equal(x, y) for x, y in zip(a, b))
|
||||
if isinstance(a, dict):
|
||||
ka = {k for k in a if k != "_nil"}
|
||||
kb = {k for k in b if k != "_nil"}
|
||||
if ka != kb:
|
||||
return False
|
||||
return all(_deep_equal(a[k], b[k]) for k in ka)
|
||||
return a == b
|
||||
|
||||
|
||||
env["equal?"] = _deep_equal
|
||||
env["identical?"] = lambda a, b: a is b
|
||||
|
||||
|
||||
def _test_env():
|
||||
return make_env()
|
||||
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
|
||||
def _sx_parse_one(source):
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["cek-eval"] = lambda s: trampoline(eval_expr(parse_all(s)[0], make_env())) if parse_all(s) else NIL
|
||||
env["eval-expr-cek"] = lambda expr, e=None: trampoline(eval_expr(expr, e or env))
|
||||
|
||||
# Env operations
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-bind!"] = lambda e, k, v: e.__setitem__(k, v) or v
|
||||
env["env-extend"] = env_extend
|
||||
env["env-merge"] = env_merge
|
||||
|
||||
# Missing primitives
|
||||
env["upcase"] = lambda s: str(s).upper()
|
||||
env["downcase"] = lambda s: str(s).lower()
|
||||
env["make-keyword"] = lambda name: Keyword(name)
|
||||
env["make-symbol"] = lambda name: Symbol(name)
|
||||
env["string-length"] = lambda s: len(str(s))
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
env["apply"] = lambda f, *args: f(*args[-1]) if args and isinstance(args[-1], list) else f()
|
||||
|
||||
# Render helpers
|
||||
def _render_html(src, e=None):
|
||||
if isinstance(src, str):
|
||||
parsed = parse_all(src)
|
||||
if not parsed:
|
||||
return ""
|
||||
expr = parsed[0] if len(parsed) == 1 else [Symbol("do")] + parsed
|
||||
result = sx_ref.render_to_html(expr, e or make_env())
|
||||
# Reset render mode
|
||||
sx_ref._render_mode = False
|
||||
return result
|
||||
result = sx_ref.render_to_html(src, e or env)
|
||||
sx_ref._render_mode = False
|
||||
return result
|
||||
|
||||
|
||||
env["render-html"] = _render_html
|
||||
env["render-to-html"] = _render_html
|
||||
env["string-contains?"] = lambda s, sub: str(sub) in str(s)
|
||||
|
||||
# Type system helpers
|
||||
env["test-prim-types"] = lambda: {
|
||||
"+": "number", "-": "number", "*": "number", "/": "number",
|
||||
"mod": "number", "inc": "number", "dec": "number",
|
||||
"abs": "number", "min": "number", "max": "number",
|
||||
"str": "string", "upper": "string", "lower": "string",
|
||||
"trim": "string", "join": "string", "replace": "string",
|
||||
"=": "boolean", "<": "boolean", ">": "boolean",
|
||||
"<=": "boolean", ">=": "boolean",
|
||||
"not": "boolean", "nil?": "boolean", "empty?": "boolean",
|
||||
"number?": "boolean", "string?": "boolean", "boolean?": "boolean",
|
||||
"list?": "boolean", "dict?": "boolean",
|
||||
"contains?": "boolean", "has-key?": "boolean",
|
||||
"starts-with?": "boolean", "ends-with?": "boolean",
|
||||
"len": "number", "first": "any", "rest": "list",
|
||||
"last": "any", "nth": "any", "cons": "list",
|
||||
"append": "list", "concat": "list", "reverse": "list",
|
||||
"sort": "list", "slice": "list", "range": "list",
|
||||
"flatten": "list", "keys": "list", "vals": "list",
|
||||
"assoc": "dict", "dissoc": "dict", "merge": "dict", "dict": "dict",
|
||||
"get": "any", "type-of": "string",
|
||||
}
|
||||
env["test-prim-param-types"] = lambda: {
|
||||
"+": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"-": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"*": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"/": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"inc": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"dec": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"upper": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"lower": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"keys": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
"vals": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
}
|
||||
env["component-param-types"] = lambda c: getattr(c, "_param_types", NIL)
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, "_param_types", t) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-has-children"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, "affinity", "auto")
|
||||
|
||||
# Type accessors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, "name", n) or NIL
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-name"] = lambda c: c.name
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["sx-serialize"] = sx_ref.sx_serialize if hasattr(sx_ref, "sx_serialize") else lambda x: str(x)
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-active?"] = lambda: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Strict mode stubs (not yet bootstrapped to Python — no-ops for now)
|
||||
env["set-strict!"] = lambda val: NIL
|
||||
env["set-prim-param-types!"] = lambda types: NIL
|
||||
env["value-matches-type?"] = lambda val, t: True
|
||||
env["*strict*"] = False
|
||||
env["primitive?"] = lambda name: name in env
|
||||
env["get-primitive"] = lambda name: env.get(name, NIL)
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Load test framework
|
||||
# ---------------------------------------------------------------------------
|
||||
framework_src = open(os.path.join(_SPEC_TESTS, "test-framework.sx")).read()
|
||||
for expr in parse_all(framework_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Determine which tests to run
|
||||
# ---------------------------------------------------------------------------
|
||||
args = [a for a in sys.argv[1:] if not a.startswith("--")]
|
||||
|
||||
# Tests requiring optional modules (only with --full)
|
||||
REQUIRES_FULL = {"test-continuations.sx", "test-continuations-advanced.sx", "test-types.sx", "test-freeze.sx", "test-strict.sx", "test-cek.sx", "test-cek-advanced.sx", "test-signals-advanced.sx"}
|
||||
|
||||
test_files = []
|
||||
if args:
|
||||
for arg in args:
|
||||
name = arg if arg.endswith(".sx") else f"{arg}.sx"
|
||||
p = os.path.join(_SPEC_TESTS, name)
|
||||
if os.path.exists(p):
|
||||
test_files.append(p)
|
||||
else:
|
||||
print(f"Test file not found: {name}")
|
||||
else:
|
||||
for f in sorted(os.listdir(_SPEC_TESTS)):
|
||||
if f.startswith("test-") and f.endswith(".sx") and f != "test-framework.sx":
|
||||
if not full_build and f in REQUIRES_FULL:
|
||||
print(f"Skipping {f} (requires --full)")
|
||||
continue
|
||||
test_files.append(os.path.join(_SPEC_TESTS, f))
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Run tests
|
||||
# ---------------------------------------------------------------------------
|
||||
for test_file in test_files:
|
||||
name = os.path.basename(test_file)
|
||||
print("=" * 60)
|
||||
print(f"Running {name}")
|
||||
print("=" * 60)
|
||||
try:
|
||||
src = open(test_file).read()
|
||||
exprs = parse_all(src)
|
||||
for expr in exprs:
|
||||
trampoline(eval_expr(expr, env))
|
||||
except Exception as e:
|
||||
print(f"ERROR in {name}: {e}")
|
||||
_fail_count += 1
|
||||
|
||||
# Summary
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
194
hosts/python/tests/run_type_tests.py
Normal file
194
hosts/python/tests/run_type_tests.py
Normal file
@@ -0,0 +1,194 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-types.sx using the bootstrapped evaluator with types module loaded."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_DIR = os.path.join(_PROJECT, "spec")
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import make_env, env_get, env_has, env_set
|
||||
from shared.sx.types import NIL, Component
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# CEK is now the default, but the test runners need tree-walk so that
|
||||
# transpiled HO forms (ho_map, etc.) don't re-enter CEK mid-evaluation.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env)) # call the thunk
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Test fixtures — provide the functions that tests expect
|
||||
|
||||
# test-prim-types: dict of primitive return types for type inference
|
||||
def _test_prim_types():
|
||||
return {
|
||||
"+": "number", "-": "number", "*": "number", "/": "number",
|
||||
"mod": "number", "inc": "number", "dec": "number",
|
||||
"abs": "number", "min": "number", "max": "number",
|
||||
"floor": "number", "ceil": "number", "round": "number",
|
||||
"str": "string", "upper": "string", "lower": "string",
|
||||
"trim": "string", "join": "string", "replace": "string",
|
||||
"format": "string", "substr": "string",
|
||||
"=": "boolean", "<": "boolean", ">": "boolean",
|
||||
"<=": "boolean", ">=": "boolean", "!=": "boolean",
|
||||
"not": "boolean", "nil?": "boolean", "empty?": "boolean",
|
||||
"number?": "boolean", "string?": "boolean", "boolean?": "boolean",
|
||||
"list?": "boolean", "dict?": "boolean", "symbol?": "boolean",
|
||||
"keyword?": "boolean", "contains?": "boolean", "has-key?": "boolean",
|
||||
"starts-with?": "boolean", "ends-with?": "boolean",
|
||||
"len": "number", "first": "any", "rest": "list",
|
||||
"last": "any", "nth": "any", "cons": "list",
|
||||
"append": "list", "concat": "list", "reverse": "list",
|
||||
"sort": "list", "slice": "list", "range": "list",
|
||||
"flatten": "list", "keys": "list", "vals": "list",
|
||||
"map-dict": "dict", "assoc": "dict", "dissoc": "dict",
|
||||
"merge": "dict", "dict": "dict",
|
||||
"get": "any", "type-of": "string",
|
||||
}
|
||||
|
||||
# test-prim-param-types: dict of primitive param type specs
|
||||
# Format: {name → {"positional" [["name" "type"] ...] "rest-type" type-or-nil}}
|
||||
def _test_prim_param_types():
|
||||
return {
|
||||
"+": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"-": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"*": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"/": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"inc": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"dec": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"upper": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"lower": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"keys": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
"vals": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
}
|
||||
|
||||
# test-env: returns a fresh env for use in tests (same as the test env)
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
# sx-parse: parse an SX string and return list of AST nodes
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
# dict-get: used in some legacy tests
|
||||
def _dict_get(d, k):
|
||||
v = d.get(k) if isinstance(d, dict) else NIL
|
||||
return v if v is not None else NIL
|
||||
|
||||
# component-set-param-types! and component-param-types: type annotation accessors
|
||||
def _component_set_param_types(comp, types_dict):
|
||||
comp.param_types = types_dict
|
||||
return NIL
|
||||
|
||||
def _component_param_types(comp):
|
||||
return getattr(comp, 'param_types', NIL)
|
||||
|
||||
# Platform functions used by types.sx but not SX primitives
|
||||
def _component_params(c):
|
||||
return c.params
|
||||
|
||||
def _component_body(c):
|
||||
return c.body
|
||||
|
||||
def _component_has_children(c):
|
||||
return c.has_children
|
||||
|
||||
def _map_dict(fn, d):
|
||||
from shared.sx.types import Lambda as _Lambda
|
||||
result = {}
|
||||
for k, v in d.items():
|
||||
if isinstance(fn, _Lambda):
|
||||
# Call SX lambda through the evaluator
|
||||
result[k] = trampoline(eval_expr([fn, k, v], env))
|
||||
else:
|
||||
result[k] = fn(k, v)
|
||||
return result
|
||||
|
||||
env["test-prim-types"] = _test_prim_types
|
||||
env["test-prim-param-types"] = _test_prim_param_types
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["dict-get"] = _dict_get
|
||||
env["component-set-param-types!"] = _component_set_param_types
|
||||
env["component-param-types"] = _component_param_types
|
||||
env["component-params"] = _component_params
|
||||
env["component-body"] = _component_body
|
||||
env["component-has-children"] = _component_has_children
|
||||
env["map-dict"] = _map_dict
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
|
||||
# Load test framework (macros + assertion helpers)
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load types module
|
||||
with open(os.path.join(_SPEC_DIR, "types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-types.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -93,11 +93,6 @@
|
||||
"*batch-depth*" "_batch_depth"
|
||||
"*batch-queue*" "_batch_queue"
|
||||
"*store-registry*" "_store_registry"
|
||||
"*custom-special-forms*" "_custom_special_forms"
|
||||
"*render-check*" "_render_check"
|
||||
"*render-fn*" "_render_fn"
|
||||
"register-special-form!" "register_special_form_b"
|
||||
"is-else-clause?" "is_else_clause_p"
|
||||
"def-store" "def_store"
|
||||
"use-store" "use_store"
|
||||
"clear-stores" "clear_stores"
|
||||
|
||||
163
lib/bytecode.sx
163
lib/bytecode.sx
@@ -1,163 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; bytecode.sx — SX bytecode format definition
|
||||
;;
|
||||
;; Universal bytecode for SX evaluation. Produced by compiler.sx,
|
||||
;; executed by platform-native VMs (OCaml, JS, WASM).
|
||||
;;
|
||||
;; Design principles:
|
||||
;; - One byte per opcode (~65 ops, fits in u8)
|
||||
;; - Variable-length encoding (1-5 bytes per instruction)
|
||||
;; - Lexical scope resolved at compile time (no hash lookups)
|
||||
;; - Tail calls detected statically (no thunks/trampoline)
|
||||
;; - Control flow via jumps (no continuation frames for if/when/etc.)
|
||||
;; - Content-addressable (deterministic binary for CID)
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Opcode constants
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Stack / Constants
|
||||
(define OP_CONST 1) ;; u16 pool_idx — push constant
|
||||
(define OP_NIL 2) ;; push nil
|
||||
(define OP_TRUE 3) ;; push true
|
||||
(define OP_FALSE 4) ;; push false
|
||||
(define OP_POP 5) ;; discard TOS
|
||||
(define OP_DUP 6) ;; duplicate TOS
|
||||
|
||||
;; Variable access (resolved at compile time)
|
||||
(define OP_LOCAL_GET 16) ;; u8 slot
|
||||
(define OP_LOCAL_SET 17) ;; u8 slot
|
||||
(define OP_UPVALUE_GET 18) ;; u8 idx
|
||||
(define OP_UPVALUE_SET 19) ;; u8 idx
|
||||
(define OP_GLOBAL_GET 20) ;; u16 name_idx
|
||||
(define OP_GLOBAL_SET 21) ;; u16 name_idx
|
||||
|
||||
;; Control flow (replaces if/when/cond/and/or frames)
|
||||
(define OP_JUMP 32) ;; i16 offset
|
||||
(define OP_JUMP_IF_FALSE 33) ;; i16 offset
|
||||
(define OP_JUMP_IF_TRUE 34) ;; i16 offset
|
||||
|
||||
;; Function operations
|
||||
(define OP_CALL 48) ;; u8 argc
|
||||
(define OP_TAIL_CALL 49) ;; u8 argc — reuse frame (TCO)
|
||||
(define OP_RETURN 50) ;; return TOS
|
||||
(define OP_CLOSURE 51) ;; u16 code_idx — create closure
|
||||
(define OP_CALL_PRIM 52) ;; u16 name_idx, u8 argc — direct primitive
|
||||
(define OP_APPLY 53) ;; (apply f args-list)
|
||||
|
||||
;; Collection construction
|
||||
(define OP_LIST 64) ;; u16 count — build list from stack
|
||||
(define OP_DICT 65) ;; u16 count — build dict from stack pairs
|
||||
(define OP_APPEND_BANG 66) ;; (append! TOS-1 TOS)
|
||||
|
||||
;; Higher-order forms (inlined loop)
|
||||
(define OP_ITER_INIT 80) ;; init iterator on TOS list
|
||||
(define OP_ITER_NEXT 81) ;; i16 end_offset — push next or jump
|
||||
(define OP_MAP_OPEN 82) ;; push empty accumulator
|
||||
(define OP_MAP_APPEND 83) ;; append TOS to accumulator
|
||||
(define OP_MAP_CLOSE 84) ;; pop accumulator as list
|
||||
(define OP_FILTER_TEST 85) ;; i16 skip — if falsy jump (skip append)
|
||||
|
||||
;; HO fallback (dynamic callback)
|
||||
(define OP_HO_MAP 88) ;; (map fn coll)
|
||||
(define OP_HO_FILTER 89) ;; (filter fn coll)
|
||||
(define OP_HO_REDUCE 90) ;; (reduce fn init coll)
|
||||
(define OP_HO_FOR_EACH 91) ;; (for-each fn coll)
|
||||
(define OP_HO_SOME 92) ;; (some fn coll)
|
||||
(define OP_HO_EVERY 93) ;; (every? fn coll)
|
||||
|
||||
;; Scope / dynamic binding
|
||||
(define OP_SCOPE_PUSH 96) ;; TOS = name
|
||||
(define OP_SCOPE_POP 97)
|
||||
(define OP_PROVIDE_PUSH 98) ;; TOS-1 = name, TOS = value
|
||||
(define OP_PROVIDE_POP 99)
|
||||
(define OP_CONTEXT 100) ;; TOS = name → push value
|
||||
(define OP_EMIT 101) ;; TOS-1 = name, TOS = value
|
||||
(define OP_EMITTED 102) ;; TOS = name → push collected
|
||||
|
||||
;; Continuations
|
||||
(define OP_RESET 112) ;; i16 body_len — push delimiter
|
||||
(define OP_SHIFT 113) ;; u8 k_slot, i16 body_len — capture k
|
||||
|
||||
;; Define / component
|
||||
(define OP_DEFINE 128) ;; u16 name_idx — bind TOS to name
|
||||
(define OP_DEFCOMP 129) ;; u16 template_idx
|
||||
(define OP_DEFISLAND 130) ;; u16 template_idx
|
||||
(define OP_DEFMACRO 131) ;; u16 template_idx
|
||||
(define OP_EXPAND_MACRO 132) ;; u8 argc — runtime macro expansion
|
||||
|
||||
;; String / serialize (hot path)
|
||||
(define OP_STR_CONCAT 144) ;; u8 count — concat N values as strings
|
||||
(define OP_STR_JOIN 145) ;; (join sep list)
|
||||
(define OP_SERIALIZE 146) ;; serialize TOS to SX string
|
||||
|
||||
;; Inline primitives (hot path — no hashtable lookup)
|
||||
(define OP_ADD 160) ;; TOS-1 + TOS → push
|
||||
(define OP_SUB 161) ;; TOS-1 - TOS → push
|
||||
(define OP_MUL 162) ;; TOS-1 * TOS → push
|
||||
(define OP_DIV 163) ;; TOS-1 / TOS → push
|
||||
(define OP_EQ 164) ;; TOS-1 = TOS → push bool
|
||||
(define OP_LT 165) ;; TOS-1 < TOS → push bool
|
||||
(define OP_GT 166) ;; TOS-1 > TOS → push bool
|
||||
(define OP_NOT 167) ;; !TOS → push bool
|
||||
(define OP_LEN 168) ;; len(TOS) → push number
|
||||
(define OP_FIRST 169) ;; first(TOS) → push
|
||||
(define OP_REST 170) ;; rest(TOS) → push list
|
||||
(define OP_NTH 171) ;; nth(TOS-1, TOS) → push
|
||||
(define OP_CONS 172) ;; cons(TOS-1, TOS) → push list
|
||||
(define OP_NEG 173) ;; negate TOS → push number
|
||||
(define OP_INC 174) ;; TOS + 1 → push
|
||||
(define OP_DEC 175) ;; TOS - 1 → push
|
||||
|
||||
;; Aser specialization (optional, 224-239 reserved)
|
||||
(define OP_ASER_TAG 224) ;; u16 tag_name_idx — serialize HTML tag
|
||||
(define OP_ASER_FRAG 225) ;; u8 child_count — serialize fragment
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Bytecode module structure
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; A module contains:
|
||||
;; magic: "SXBC" (4 bytes)
|
||||
;; version: u16
|
||||
;; pool_count: u32
|
||||
;; pool: constant pool entries (self-describing tagged values)
|
||||
;; code_count: u32
|
||||
;; codes: code objects
|
||||
;; entry: u32 (index of entry-point code object)
|
||||
|
||||
(define BYTECODE_MAGIC "SXBC")
|
||||
(define BYTECODE_VERSION 1)
|
||||
|
||||
;; Constant pool tags
|
||||
(define CONST_NUMBER 1)
|
||||
(define CONST_STRING 2)
|
||||
(define CONST_BOOL 3)
|
||||
(define CONST_NIL 4)
|
||||
(define CONST_SYMBOL 5)
|
||||
(define CONST_KEYWORD 6)
|
||||
(define CONST_LIST 7)
|
||||
(define CONST_DICT 8)
|
||||
(define CONST_CODE 9)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Disassembler
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define opcode-name
|
||||
(fn (op)
|
||||
(cond
|
||||
(= op 1) "CONST" (= op 2) "NIL"
|
||||
(= op 3) "TRUE" (= op 4) "FALSE"
|
||||
(= op 5) "POP" (= op 6) "DUP"
|
||||
(= op 16) "LOCAL_GET" (= op 17) "LOCAL_SET"
|
||||
(= op 20) "GLOBAL_GET" (= op 21) "GLOBAL_SET"
|
||||
(= op 32) "JUMP" (= op 33) "JUMP_IF_FALSE"
|
||||
(= op 48) "CALL" (= op 49) "TAIL_CALL"
|
||||
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
|
||||
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
|
||||
:else (str "OP_" op))))
|
||||
826
lib/compiler.sx
826
lib/compiler.sx
@@ -1,826 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; compiler.sx — SX bytecode compiler
|
||||
;;
|
||||
;; Compiles SX AST to bytecode for the platform-native VM.
|
||||
;; Written in SX — runs on any platform with an SX evaluator.
|
||||
;;
|
||||
;; Architecture:
|
||||
;; Pass 1: Scope analysis — resolve variables, detect tail positions
|
||||
;; Pass 2: Code generation — emit bytecode
|
||||
;;
|
||||
;; The compiler produces Code objects (bytecode + constant pool).
|
||||
;; The VM executes them with a stack machine model.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constant pool builder
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-pool
|
||||
(fn ()
|
||||
{:entries (if (primitive? "mutable-list") (mutable-list) (list))
|
||||
:index {:_count 0}}))
|
||||
|
||||
(define pool-add
|
||||
(fn (pool value)
|
||||
"Add a value to the constant pool, return its index. Deduplicates."
|
||||
(let ((key (serialize value))
|
||||
(idx-map (get pool "index")))
|
||||
(if (has-key? idx-map key)
|
||||
(get idx-map key)
|
||||
(let ((idx (get idx-map "_count")))
|
||||
(dict-set! idx-map key idx)
|
||||
(dict-set! idx-map "_count" (+ idx 1))
|
||||
(append! (get pool "entries") value)
|
||||
idx)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scope analysis
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-scope
|
||||
(fn (parent)
|
||||
{:locals (list) ;; list of {name, slot, mutable?}
|
||||
:upvalues (list) ;; list of {name, is-local, index}
|
||||
:parent parent
|
||||
:is-function false ;; true for fn/lambda scopes (create frames)
|
||||
:next-slot 0}))
|
||||
|
||||
(define scope-define-local
|
||||
(fn (scope name)
|
||||
"Add a local variable, return its slot index.
|
||||
Idempotent: if name already has a slot, return it."
|
||||
(let ((existing (first (filter (fn (l) (= (get l "name") name))
|
||||
(get scope "locals")))))
|
||||
(if existing
|
||||
(get existing "slot")
|
||||
(let ((slot (get scope "next-slot")))
|
||||
(append! (get scope "locals")
|
||||
{:name name :slot slot :mutable false})
|
||||
(dict-set! scope "next-slot" (+ slot 1))
|
||||
slot)))))
|
||||
|
||||
(define scope-resolve
|
||||
(fn (scope name)
|
||||
"Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.
|
||||
Upvalue captures only happen at function boundaries (is-function=true).
|
||||
Let scopes share the enclosing function's frame — their locals are
|
||||
accessed directly without upvalue indirection."
|
||||
(if (nil? scope)
|
||||
{:type "global" :index name}
|
||||
;; Check locals in this scope
|
||||
(let ((locals (get scope "locals"))
|
||||
(found (some (fn (l) (= (get l "name") name)) locals)))
|
||||
(if found
|
||||
(let ((local (first (filter (fn (l) (= (get l "name") name)) locals))))
|
||||
{:type "local" :index (get local "slot")})
|
||||
;; Check upvalues already captured at this scope
|
||||
(let ((upvals (get scope "upvalues"))
|
||||
(uv-found (some (fn (u) (= (get u "name") name)) upvals)))
|
||||
(if uv-found
|
||||
(let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
|
||||
{:type "upvalue" :index (get uv "uv-index")})
|
||||
;; Look in parent
|
||||
(let ((parent (get scope "parent")))
|
||||
(if (nil? parent)
|
||||
{:type "global" :index name}
|
||||
(let ((parent-result (scope-resolve parent name)))
|
||||
(if (= (get parent-result "type") "global")
|
||||
parent-result
|
||||
;; Found in parent. Capture as upvalue only at function boundaries.
|
||||
(if (get scope "is-function")
|
||||
;; Function boundary — create upvalue capture
|
||||
(let ((uv-idx (len (get scope "upvalues"))))
|
||||
(append! (get scope "upvalues")
|
||||
{:name name
|
||||
:is-local (= (get parent-result "type") "local")
|
||||
:index (get parent-result "index")
|
||||
:uv-index uv-idx})
|
||||
{:type "upvalue" :index uv-idx})
|
||||
;; Let scope — pass through (same frame)
|
||||
parent-result))))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Code emitter
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-emitter
|
||||
(fn ()
|
||||
{:bytecode (if (primitive? "mutable-list") (mutable-list) (list))
|
||||
:pool (make-pool)}))
|
||||
|
||||
(define emit-byte
|
||||
(fn (em byte)
|
||||
(append! (get em "bytecode") byte)))
|
||||
|
||||
(define emit-u16
|
||||
(fn (em value)
|
||||
(emit-byte em (mod value 256))
|
||||
(emit-byte em (mod (floor (/ value 256)) 256))))
|
||||
|
||||
(define emit-i16
|
||||
(fn (em value)
|
||||
(let ((v (if (< value 0) (+ value 65536) value)))
|
||||
(emit-u16 em v))))
|
||||
|
||||
(define emit-op
|
||||
(fn (em opcode)
|
||||
(emit-byte em opcode)))
|
||||
|
||||
(define emit-const
|
||||
(fn (em value)
|
||||
(let ((idx (pool-add (get em "pool") value)))
|
||||
(emit-op em 1) ;; OP_CONST
|
||||
(emit-u16 em idx))))
|
||||
|
||||
(define current-offset
|
||||
(fn (em)
|
||||
(len (get em "bytecode"))))
|
||||
|
||||
(define patch-i16
|
||||
(fn (em offset value)
|
||||
"Patch a previously emitted i16 at the given bytecode offset."
|
||||
(let ((v (if (< value 0) (+ value 65536) value))
|
||||
(bc (get em "bytecode")))
|
||||
;; Direct mutation of bytecode list at offset
|
||||
(set-nth! bc offset (mod v 256))
|
||||
(set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Compilation — expression dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-expr
|
||||
(fn (em expr scope tail?)
|
||||
"Compile an expression. tail? indicates tail position for TCO."
|
||||
(cond
|
||||
;; Nil
|
||||
(nil? expr)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
|
||||
;; Number
|
||||
(= (type-of expr) "number")
|
||||
(emit-const em expr)
|
||||
|
||||
;; String
|
||||
(= (type-of expr) "string")
|
||||
(emit-const em expr)
|
||||
|
||||
;; Boolean
|
||||
(= (type-of expr) "boolean")
|
||||
(emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE
|
||||
|
||||
;; Keyword
|
||||
(= (type-of expr) "keyword")
|
||||
(emit-const em (keyword-name expr))
|
||||
|
||||
;; Symbol — resolve to local/upvalue/global
|
||||
(= (type-of expr) "symbol")
|
||||
(compile-symbol em (symbol-name expr) scope)
|
||||
|
||||
;; List — dispatch on head
|
||||
(= (type-of expr) "list")
|
||||
(if (empty? expr)
|
||||
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
|
||||
(compile-list em expr scope tail?))
|
||||
|
||||
;; Dict literal
|
||||
(= (type-of expr) "dict")
|
||||
(compile-dict em expr scope)
|
||||
|
||||
;; Fallback
|
||||
:else
|
||||
(emit-const em expr))))
|
||||
|
||||
|
||||
(define compile-symbol
|
||||
(fn (em name scope)
|
||||
(let ((resolved (scope-resolve scope name)))
|
||||
(cond
|
||||
(= (get resolved "type") "local")
|
||||
(do (emit-op em 16) ;; OP_LOCAL_GET
|
||||
(emit-byte em (get resolved "index")))
|
||||
(= (get resolved "type") "upvalue")
|
||||
(do (emit-op em 18) ;; OP_UPVALUE_GET
|
||||
(emit-byte em (get resolved "index")))
|
||||
:else
|
||||
;; Global or primitive
|
||||
(let ((idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 20) ;; OP_GLOBAL_GET
|
||||
(emit-u16 em idx))))))
|
||||
|
||||
|
||||
(define compile-dict
|
||||
(fn (em expr scope)
|
||||
(let ((ks (keys expr))
|
||||
(count (len ks)))
|
||||
(for-each (fn (k)
|
||||
(emit-const em k)
|
||||
(compile-expr em (get expr k) scope false))
|
||||
ks)
|
||||
(emit-op em 65) ;; OP_DICT
|
||||
(emit-u16 em count))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; List compilation — special forms, calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-list
|
||||
(fn (em expr scope tail?)
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Non-symbol head — compile as call
|
||||
(compile-call em head args scope tail?)
|
||||
;; Symbol head — check for special forms
|
||||
(let ((name (symbol-name head)))
|
||||
(cond
|
||||
(= name "if") (compile-if em args scope tail?)
|
||||
(= name "when") (compile-when em args scope tail?)
|
||||
(= name "and") (compile-and em args scope tail?)
|
||||
(= name "or") (compile-or em args scope tail?)
|
||||
(= name "let") (compile-let em args scope tail?)
|
||||
(= name "let*") (compile-let em args scope tail?)
|
||||
(= name "begin") (compile-begin em args scope tail?)
|
||||
(= name "do") (compile-begin em args scope tail?)
|
||||
(= name "lambda") (compile-lambda em args scope)
|
||||
(= name "fn") (compile-lambda em args scope)
|
||||
(= name "define") (compile-define em args scope)
|
||||
(= name "set!") (compile-set em args scope)
|
||||
(= name "quote") (compile-quote em args)
|
||||
(= name "cond") (compile-cond em args scope tail?)
|
||||
(= name "case") (compile-case em args scope tail?)
|
||||
(= name "->") (compile-thread em args scope tail?)
|
||||
(= name "defcomp") (compile-defcomp em args scope)
|
||||
(= name "defisland") (compile-defcomp em args scope)
|
||||
(= name "defmacro") (compile-defmacro em args scope)
|
||||
(= name "defstyle") (emit-op em 2) ;; defstyle → nil (no-op at runtime)
|
||||
(= name "defhandler") (emit-op em 2) ;; no-op
|
||||
(= name "defpage") (emit-op em 2) ;; handled by page loader
|
||||
(= name "defquery") (emit-op em 2)
|
||||
(= name "defaction") (emit-op em 2)
|
||||
(= name "defrelation") (emit-op em 2)
|
||||
(= name "deftype") (emit-op em 2)
|
||||
(= name "defeffect") (emit-op em 2)
|
||||
(= name "defisland") (compile-defcomp em args scope)
|
||||
(= name "quasiquote") (compile-quasiquote em (first args) scope)
|
||||
(= name "letrec") (compile-letrec em args scope tail?)
|
||||
;; Default — function call
|
||||
:else
|
||||
(compile-call em head args scope tail?)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Special form compilation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-if
|
||||
(fn (em args scope tail?)
|
||||
(let ((test (first args))
|
||||
(then-expr (nth args 1))
|
||||
(else-expr (if (> (len args) 2) (nth args 2) nil)))
|
||||
;; Compile test
|
||||
(compile-expr em test scope false)
|
||||
;; Jump if false to else
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((else-jump (current-offset em)))
|
||||
(emit-i16 em 0) ;; placeholder
|
||||
;; Compile then (in tail position if if is)
|
||||
(compile-expr em then-expr scope tail?)
|
||||
;; Jump over else
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0) ;; placeholder
|
||||
;; Patch else jump
|
||||
(patch-i16 em else-jump (- (current-offset em) (+ else-jump 2)))
|
||||
;; Compile else
|
||||
(if (nil? else-expr)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(compile-expr em else-expr scope tail?))
|
||||
;; Patch end jump
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
||||
|
||||
|
||||
(define compile-when
|
||||
(fn (em args scope tail?)
|
||||
(let ((test (first args))
|
||||
(body (rest args)))
|
||||
(compile-expr em test scope false)
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(compile-begin em body scope tail?)
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip-jump (- (current-offset em) (+ skip-jump 2)))
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
||||
|
||||
|
||||
(define compile-and
|
||||
(fn (em args scope tail?)
|
||||
(if (empty? args)
|
||||
(emit-op em 3) ;; OP_TRUE
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first args) scope false)
|
||||
(emit-op em 6) ;; OP_DUP
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; OP_POP (discard duplicated truthy)
|
||||
(compile-and em (rest args) scope tail?)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
||||
|
||||
|
||||
(define compile-or
|
||||
(fn (em args scope tail?)
|
||||
(if (empty? args)
|
||||
(emit-op em 4) ;; OP_FALSE
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first args) scope false)
|
||||
(emit-op em 6) ;; OP_DUP
|
||||
(emit-op em 34) ;; OP_JUMP_IF_TRUE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; OP_POP
|
||||
(compile-or em (rest args) scope tail?)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
||||
|
||||
|
||||
(define compile-begin
|
||||
(fn (em exprs scope tail?)
|
||||
;; Hoist: pre-allocate local slots for all define forms in this block.
|
||||
;; Enables forward references between inner functions (e.g. sx-parse).
|
||||
;; Only inside function bodies (scope has parent), not at top level.
|
||||
(when (and (not (empty? exprs)) (not (nil? (get scope "parent"))))
|
||||
(for-each (fn (expr)
|
||||
(when (and (= (type-of expr) "list")
|
||||
(>= (len expr) 2)
|
||||
(= (type-of (first expr)) "symbol")
|
||||
(= (symbol-name (first expr)) "define"))
|
||||
(let ((name-expr (nth expr 1))
|
||||
(name (if (= (type-of name-expr) "symbol")
|
||||
(symbol-name name-expr)
|
||||
name-expr)))
|
||||
(scope-define-local scope name))))
|
||||
exprs))
|
||||
;; Compile expressions
|
||||
(if (empty? exprs)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(if (= (len exprs) 1)
|
||||
(compile-expr em (first exprs) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first exprs) scope false)
|
||||
(emit-op em 5) ;; OP_POP
|
||||
(compile-begin em (rest exprs) scope tail?))))))
|
||||
|
||||
|
||||
(define compile-let
|
||||
(fn (em args scope tail?)
|
||||
;; Detect named let: (let loop ((x init) ...) body)
|
||||
(if (= (type-of (first args)) "symbol")
|
||||
;; Named let → desugar to letrec:
|
||||
;; (letrec ((loop (fn (x ...) body))) (loop init ...))
|
||||
(let ((loop-name (symbol-name (first args)))
|
||||
(bindings (nth args 1))
|
||||
(body (slice args 2))
|
||||
(params (list))
|
||||
(inits (list)))
|
||||
(for-each (fn (binding)
|
||||
(append! params (if (= (type-of (first binding)) "symbol")
|
||||
(first binding)
|
||||
(make-symbol (first binding))))
|
||||
(append! inits (nth binding 1)))
|
||||
bindings)
|
||||
;; Compile as: (letrec ((loop (fn (params...) body...))) (loop inits...))
|
||||
(let ((lambda-expr (concat (list (make-symbol "fn") params) body))
|
||||
(letrec-bindings (list (list (make-symbol loop-name) lambda-expr)))
|
||||
(call-expr (cons (make-symbol loop-name) inits)))
|
||||
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
|
||||
;; Normal let
|
||||
(let ((bindings (first args))
|
||||
(body (rest args))
|
||||
(let-scope (make-scope scope)))
|
||||
;; Let scopes share the enclosing function's frame.
|
||||
;; Continue slot numbering from parent.
|
||||
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
||||
;; Compile each binding
|
||||
(for-each (fn (binding)
|
||||
(let ((name (if (= (type-of (first binding)) "symbol")
|
||||
(symbol-name (first binding))
|
||||
(first binding)))
|
||||
(value (nth binding 1))
|
||||
(slot (scope-define-local let-scope name)))
|
||||
(compile-expr em value let-scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)))
|
||||
bindings)
|
||||
;; Compile body in let scope
|
||||
(compile-begin em body let-scope tail?)))))
|
||||
|
||||
|
||||
(define compile-letrec
|
||||
(fn (em args scope tail?)
|
||||
"Compile letrec: all names visible during value compilation.
|
||||
1. Define all local slots (initialized to nil).
|
||||
2. Compile each value and assign — names are already in scope
|
||||
so mutually recursive functions can reference each other."
|
||||
(let ((bindings (first args))
|
||||
(body (rest args))
|
||||
(let-scope (make-scope scope)))
|
||||
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
||||
;; Phase 1: define all slots (push nil for each)
|
||||
(let ((slots (map (fn (binding)
|
||||
(let ((name (if (= (type-of (first binding)) "symbol")
|
||||
(symbol-name (first binding))
|
||||
(first binding))))
|
||||
(let ((slot (scope-define-local let-scope name)))
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)
|
||||
slot)))
|
||||
bindings)))
|
||||
;; Phase 2: compile values and assign (all names in scope)
|
||||
(for-each (fn (pair)
|
||||
(let ((binding (first pair))
|
||||
(slot (nth pair 1)))
|
||||
(compile-expr em (nth binding 1) let-scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)))
|
||||
(map (fn (i) (list (nth bindings i) (nth slots i)))
|
||||
(range 0 (len bindings)))))
|
||||
;; Compile body
|
||||
(compile-begin em body let-scope tail?))))
|
||||
|
||||
(define compile-lambda
|
||||
(fn (em args scope)
|
||||
(let ((params (first args))
|
||||
(body (rest args))
|
||||
(fn-scope (make-scope scope))
|
||||
(fn-em (make-emitter)))
|
||||
;; Mark as function boundary — upvalue captures happen here
|
||||
(dict-set! fn-scope "is-function" true)
|
||||
;; Define params as locals in fn scope.
|
||||
;; Handle type annotations: (name :as type) → extract name
|
||||
(for-each (fn (p)
|
||||
(let ((name (cond
|
||||
(= (type-of p) "symbol") (symbol-name p)
|
||||
;; Type-annotated param: (name :as type)
|
||||
(and (list? p) (not (empty? p))
|
||||
(= (type-of (first p)) "symbol"))
|
||||
(symbol-name (first p))
|
||||
:else p)))
|
||||
(when (and (not (= name "&key"))
|
||||
(not (= name "&rest")))
|
||||
(scope-define-local fn-scope name))))
|
||||
params)
|
||||
;; Compile body
|
||||
(compile-begin fn-em body fn-scope true) ;; tail position
|
||||
(emit-op fn-em 50) ;; OP_RETURN
|
||||
;; Add code object to parent constant pool
|
||||
(let ((upvals (get fn-scope "upvalues"))
|
||||
(code {:arity (len (get fn-scope "locals"))
|
||||
:bytecode (get fn-em "bytecode")
|
||||
:constants (get (get fn-em "pool") "entries")
|
||||
:upvalue-count (len upvals)})
|
||||
(code-idx (pool-add (get em "pool") code)))
|
||||
(emit-op em 51) ;; OP_CLOSURE
|
||||
(emit-u16 em code-idx)
|
||||
;; Emit upvalue descriptors: for each captured variable,
|
||||
;; (is_local, index) — tells the VM where to find the value.
|
||||
;; is_local=1: capture from enclosing frame's local slot
|
||||
;; is_local=0: capture from enclosing frame's upvalue
|
||||
(for-each (fn (uv)
|
||||
(emit-byte em (if (get uv "is-local") 1 0))
|
||||
(emit-byte em (get uv "index")))
|
||||
upvals)))))
|
||||
|
||||
|
||||
(define compile-define
|
||||
(fn (em args scope)
|
||||
(let ((name-expr (first args))
|
||||
(name (if (= (type-of name-expr) "symbol")
|
||||
(symbol-name name-expr)
|
||||
name-expr))
|
||||
;; Handle :effects annotation: (define name :effects [...] value)
|
||||
;; Skip keyword-value pairs between name and body
|
||||
(value (let ((rest-args (rest args)))
|
||||
(if (and (not (empty? rest-args))
|
||||
(= (type-of (first rest-args)) "keyword"))
|
||||
;; Skip :keyword value pairs until we hit the body
|
||||
(let ((skip-annotations
|
||||
(fn (items)
|
||||
(if (empty? items) nil
|
||||
(if (= (type-of (first items)) "keyword")
|
||||
(skip-annotations (rest (rest items)))
|
||||
(first items))))))
|
||||
(skip-annotations rest-args))
|
||||
(first rest-args)))))
|
||||
;; Inside a function body, define creates a LOCAL binding.
|
||||
;; At top level (no enclosing function scope), define creates a global.
|
||||
;; Local binding prevents recursive calls from overwriting
|
||||
;; each other's defines in the flat globals hashtable.
|
||||
(if (not (nil? (get scope "parent")))
|
||||
;; Local define — allocate slot, compile value, set local
|
||||
(let ((slot (scope-define-local scope name)))
|
||||
(compile-expr em value scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot))
|
||||
;; Top-level define — global
|
||||
(let ((name-idx (pool-add (get em "pool") name)))
|
||||
(compile-expr em value scope false)
|
||||
(emit-op em 128) ;; OP_DEFINE
|
||||
(emit-u16 em name-idx))))))
|
||||
|
||||
|
||||
(define compile-set
|
||||
(fn (em args scope)
|
||||
(let ((name (if (= (type-of (first args)) "symbol")
|
||||
(symbol-name (first args))
|
||||
(first args)))
|
||||
(value (nth args 1))
|
||||
(resolved (scope-resolve scope name)))
|
||||
(compile-expr em value scope false)
|
||||
(cond
|
||||
(= (get resolved "type") "local")
|
||||
(do (emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em (get resolved "index")))
|
||||
(= (get resolved "type") "upvalue")
|
||||
(do (emit-op em 19) ;; OP_UPVALUE_SET
|
||||
(emit-byte em (get resolved "index")))
|
||||
:else
|
||||
(let ((idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 21) ;; OP_GLOBAL_SET
|
||||
(emit-u16 em idx))))))
|
||||
|
||||
|
||||
(define compile-quote
|
||||
(fn (em args)
|
||||
(if (empty? args)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(emit-const em (first args)))))
|
||||
|
||||
|
||||
(define compile-cond
|
||||
(fn (em args scope tail?)
|
||||
"Compile (cond test1 body1 test2 body2 ... :else fallback)."
|
||||
(if (< (len args) 2)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(let ((test (first args))
|
||||
(body (nth args 1))
|
||||
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
;; else clause — just compile the body
|
||||
(compile-expr em body scope tail?)
|
||||
(do
|
||||
(compile-expr em test scope false)
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(compile-expr em body scope tail?)
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
|
||||
(compile-cond em rest-clauses scope tail?)
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
|
||||
|
||||
|
||||
(define compile-case
|
||||
(fn (em args scope tail?)
|
||||
"Compile (case expr val1 body1 val2 body2 ... :else fallback)."
|
||||
;; Desugar to nested if: evaluate expr once, then compare
|
||||
(compile-expr em (first args) scope false)
|
||||
(let ((clauses (rest args)))
|
||||
(compile-case-clauses em clauses scope tail?))))
|
||||
|
||||
(define compile-case-clauses
|
||||
(fn (em clauses scope tail?)
|
||||
(if (< (len clauses) 2)
|
||||
(do (emit-op em 5) (emit-op em 2)) ;; POP match-val, push NIL
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1))
|
||||
(rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list))))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
(do (emit-op em 5) ;; POP match-val
|
||||
(compile-expr em body scope tail?))
|
||||
(do
|
||||
(emit-op em 6) ;; DUP match-val
|
||||
(compile-expr em test scope false)
|
||||
(let ((name-idx (pool-add (get em "pool") "=")))
|
||||
(emit-op em 52) (emit-u16 em name-idx) (emit-byte em 2)) ;; CALL_PRIM "=" 2
|
||||
(emit-op em 33) ;; JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; POP match-val
|
||||
(compile-expr em body scope tail?)
|
||||
(emit-op em 32) ;; JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
|
||||
(compile-case-clauses em rest-clauses scope tail?)
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
|
||||
|
||||
|
||||
(define compile-thread
|
||||
(fn (em args scope tail?)
|
||||
"Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls."
|
||||
(if (empty? args)
|
||||
(emit-op em 2)
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
;; Desugar: (-> x (f a)) → (f x a)
|
||||
(let ((val-expr (first args))
|
||||
(forms (rest args)))
|
||||
(compile-thread-step em val-expr forms scope tail?))))))
|
||||
|
||||
(define compile-thread-step
|
||||
(fn (em val-expr forms scope tail?)
|
||||
(if (empty? forms)
|
||||
(compile-expr em val-expr scope tail?)
|
||||
(let ((form (first forms))
|
||||
(rest-forms (rest forms))
|
||||
(is-tail (and tail? (empty? rest-forms))))
|
||||
;; Build desugared call: (f val args...)
|
||||
(let ((call-expr
|
||||
(if (list? form)
|
||||
;; (-> x (f a b)) → (f x a b)
|
||||
(concat (list (first form) val-expr) (rest form))
|
||||
;; (-> x f) → (f x)
|
||||
(list form val-expr))))
|
||||
(if (empty? rest-forms)
|
||||
(compile-expr em call-expr scope is-tail)
|
||||
(do
|
||||
(compile-expr em call-expr scope false)
|
||||
;; Thread result through remaining forms
|
||||
;; Store in temp, compile next step
|
||||
;; Actually, just compile sequentially — each step returns a value
|
||||
(compile-thread-step em call-expr rest-forms scope tail?))))))))
|
||||
|
||||
|
||||
(define compile-defcomp
|
||||
(fn (em args scope)
|
||||
"Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL."
|
||||
(let ((name-idx (pool-add (get em "pool") "eval-defcomp")))
|
||||
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
|
||||
(emit-const em (concat (list (make-symbol "defcomp")) args))
|
||||
(emit-op em 48) (emit-byte em 1))) ;; CALL 1
|
||||
|
||||
(define compile-defmacro
|
||||
(fn (em args scope)
|
||||
"Compile defmacro — delegates to runtime via GLOBAL_GET + CALL."
|
||||
(let ((name-idx (pool-add (get em "pool") "eval-defmacro")))
|
||||
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
|
||||
(emit-const em (concat (list (make-symbol "defmacro")) args))
|
||||
(emit-op em 48) (emit-byte em 1)))
|
||||
|
||||
|
||||
(define compile-quasiquote
|
||||
(fn (em expr scope)
|
||||
"Compile quasiquote inline — walks the template at compile time,
|
||||
emitting code that builds the structure at runtime. Unquoted
|
||||
expressions are compiled normally (resolving locals/upvalues),
|
||||
avoiding the qq-expand-runtime env-lookup limitation."
|
||||
(compile-qq-expr em expr scope)))
|
||||
|
||||
(define compile-qq-expr
|
||||
(fn (em expr scope)
|
||||
"Compile a quasiquote sub-expression."
|
||||
(if (not (= (type-of expr) "list"))
|
||||
;; Atom — emit as constant
|
||||
(emit-const em expr)
|
||||
(if (empty? expr)
|
||||
;; Empty list
|
||||
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
|
||||
(let ((head (first expr)))
|
||||
(if (and (= (type-of head) "symbol")
|
||||
(= (symbol-name head) "unquote"))
|
||||
;; (unquote expr) — compile the expression
|
||||
(compile-expr em (nth expr 1) scope false)
|
||||
;; List — compile elements, handling splice-unquote
|
||||
(compile-qq-list em expr scope)))))))
|
||||
|
||||
(define compile-qq-list
|
||||
(fn (em items scope)
|
||||
"Compile a quasiquote list. Handles splice-unquote by building
|
||||
segments and concatenating them."
|
||||
(let ((has-splice (some (fn (item)
|
||||
(and (= (type-of item) "list")
|
||||
(>= (len item) 2)
|
||||
(= (type-of (first item)) "symbol")
|
||||
(= (symbol-name (first item)) "splice-unquote")))
|
||||
items)))
|
||||
(if (not has-splice)
|
||||
;; No splicing — compile each element, then OP_LIST
|
||||
(do
|
||||
(for-each (fn (item) (compile-qq-expr em item scope)) items)
|
||||
(emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N
|
||||
;; Has splicing — build segments and concat
|
||||
;; Strategy: accumulate non-spliced items into a pending list,
|
||||
;; flush as OP_LIST when hitting a splice, concat all segments.
|
||||
(let ((segment-count 0)
|
||||
(pending 0))
|
||||
(for-each
|
||||
(fn (item)
|
||||
(if (and (= (type-of item) "list")
|
||||
(>= (len item) 2)
|
||||
(= (type-of (first item)) "symbol")
|
||||
(= (symbol-name (first item)) "splice-unquote"))
|
||||
;; Splice-unquote: flush pending, compile spliced expr
|
||||
(do
|
||||
(when (> pending 0)
|
||||
(emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending
|
||||
(set! segment-count (+ segment-count 1))
|
||||
(set! pending 0))
|
||||
;; Compile the spliced expression
|
||||
(compile-expr em (nth item 1) scope false)
|
||||
(set! segment-count (+ segment-count 1)))
|
||||
;; Normal element — compile and count as pending
|
||||
(do
|
||||
(compile-qq-expr em item scope)
|
||||
(set! pending (+ pending 1)))))
|
||||
items)
|
||||
;; Flush remaining pending items
|
||||
(when (> pending 0)
|
||||
(emit-op em 64) (emit-u16 em pending)
|
||||
(set! segment-count (+ segment-count 1)))
|
||||
;; Concat all segments
|
||||
(when (> segment-count 1)
|
||||
(let ((concat-idx (pool-add (get em "pool") "concat")))
|
||||
;; concat takes N args — call with all segments
|
||||
(emit-op em 52) (emit-u16 em concat-idx)
|
||||
(emit-byte em segment-count))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Function call compilation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-call
|
||||
(fn (em head args scope tail?)
|
||||
;; Check for known primitives
|
||||
(let ((is-prim (and (= (type-of head) "symbol")
|
||||
(let ((name (symbol-name head)))
|
||||
(and (not (= (get (scope-resolve scope name) "type") "local"))
|
||||
(not (= (get (scope-resolve scope name) "type") "upvalue"))
|
||||
(primitive? name))))))
|
||||
(if is-prim
|
||||
;; Direct primitive call via CALL_PRIM
|
||||
(let ((name (symbol-name head))
|
||||
(argc (len args))
|
||||
(name-idx (pool-add (get em "pool") name)))
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(emit-op em 52) ;; OP_CALL_PRIM
|
||||
(emit-u16 em name-idx)
|
||||
(emit-byte em argc))
|
||||
;; General call
|
||||
(do
|
||||
(compile-expr em head scope false)
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(if tail?
|
||||
(do (emit-op em 49) ;; OP_TAIL_CALL
|
||||
(emit-byte em (len args)))
|
||||
(do (emit-op em 48) ;; OP_CALL
|
||||
(emit-byte em (len args)))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Top-level API
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile
|
||||
(fn (expr)
|
||||
"Compile a single SX expression to a bytecode module."
|
||||
(let ((em (make-emitter))
|
||||
(scope (make-scope nil)))
|
||||
(compile-expr em expr scope false)
|
||||
(emit-op em 50) ;; OP_RETURN
|
||||
{:bytecode (get em "bytecode")
|
||||
:constants (get (get em "pool") "entries")})))
|
||||
|
||||
(define compile-module
|
||||
(fn (exprs)
|
||||
"Compile a list of top-level expressions to a bytecode module."
|
||||
(let ((em (make-emitter))
|
||||
(scope (make-scope nil)))
|
||||
(for-each (fn (expr)
|
||||
(compile-expr em expr scope false)
|
||||
(emit-op em 5)) ;; OP_POP between top-level exprs
|
||||
(init exprs))
|
||||
;; Last expression's value is the module result
|
||||
(compile-expr em (last exprs) scope false)
|
||||
(emit-op em 50) ;; OP_RETURN
|
||||
{:bytecode (get em "bytecode")
|
||||
:constants (get (get em "pool") "entries")})))
|
||||
@@ -1,48 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; content.sx — Content-addressed computation
|
||||
;;
|
||||
;; Hash frozen SX to a content identifier. Store and retrieve by CID.
|
||||
;; The content IS the address — same SX always produces the same CID.
|
||||
;;
|
||||
;; This is a library built on top of freeze.sx. It is NOT part of the
|
||||
;; core evaluator. Load order: evaluator.sx → freeze.sx → content.sx
|
||||
;;
|
||||
;; Uses an in-memory content store. Applications can persist to
|
||||
;; localStorage or IPFS by providing their own store backend.
|
||||
;; ==========================================================================
|
||||
|
||||
(define content-store (dict))
|
||||
|
||||
(define content-hash :effects []
|
||||
(fn (sx-text)
|
||||
;; djb2 hash → hex string. Simple, deterministic, fast.
|
||||
;; Real deployment would use SHA-256 / multihash.
|
||||
(let ((hash 5381))
|
||||
(for-each (fn (i)
|
||||
(set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296)))
|
||||
(range 0 (len sx-text)))
|
||||
(to-hex hash))))
|
||||
|
||||
(define content-put :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((cid (content-hash sx-text)))
|
||||
(dict-set! content-store cid sx-text)
|
||||
cid)))
|
||||
|
||||
(define content-get :effects []
|
||||
(fn (cid)
|
||||
(get content-store cid)))
|
||||
|
||||
;; Freeze a scope → store → return CID
|
||||
(define freeze-to-cid :effects [mutation]
|
||||
(fn (scope-name)
|
||||
(let ((sx-text (freeze-to-sx scope-name)))
|
||||
(content-put sx-text))))
|
||||
|
||||
;; Thaw from CID → look up → restore
|
||||
(define thaw-from-cid :effects [mutation]
|
||||
(fn (cid)
|
||||
(let ((sx-text (content-get cid)))
|
||||
(when sx-text
|
||||
(thaw-from-sx sx-text)
|
||||
true))))
|
||||
@@ -1,94 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; freeze.sx — Serializable state boundaries
|
||||
;;
|
||||
;; Freeze scopes collect signals registered within them. On freeze,
|
||||
;; their current values are serialized to SX. On thaw, values are
|
||||
;; restored. Multiple named scopes can coexist independently.
|
||||
;;
|
||||
;; This is a library built on top of the evaluator's scoped effects
|
||||
;; (scope-push!/scope-pop!/context) and signal system. It is NOT
|
||||
;; part of the core evaluator — it loads after evaluator.sx.
|
||||
;;
|
||||
;; Usage:
|
||||
;; (freeze-scope "editor"
|
||||
;; (let ((doc (signal "hello")))
|
||||
;; (freeze-signal "doc" doc)
|
||||
;; ...))
|
||||
;;
|
||||
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
|
||||
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
|
||||
;; ==========================================================================
|
||||
|
||||
;; Registry of freeze scopes: name → list of {name signal} entries
|
||||
(define freeze-registry (dict))
|
||||
|
||||
;; Register a signal in the current freeze scope
|
||||
(define freeze-signal :effects [mutation]
|
||||
(fn (name sig)
|
||||
(let ((scope-name (context "sx-freeze-scope" nil)))
|
||||
(when scope-name
|
||||
(let ((entries (or (get freeze-registry scope-name) (list))))
|
||||
(append! entries (dict "name" name "signal" sig))
|
||||
(dict-set! freeze-registry scope-name entries))))))
|
||||
|
||||
;; Freeze scope delimiter — collects signals registered within body
|
||||
(define freeze-scope :effects [mutation]
|
||||
(fn (name body-fn)
|
||||
(scope-push! "sx-freeze-scope" name)
|
||||
;; Initialize empty entry list for this scope
|
||||
(dict-set! freeze-registry name (list))
|
||||
(cek-call body-fn nil)
|
||||
(scope-pop! "sx-freeze-scope")
|
||||
nil))
|
||||
|
||||
;; Freeze a named scope → SX dict of signal values
|
||||
(define cek-freeze-scope :effects []
|
||||
(fn (name)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(signals-dict (dict)))
|
||||
(for-each (fn (entry)
|
||||
(dict-set! signals-dict
|
||||
(get entry "name")
|
||||
(signal-value (get entry "signal"))))
|
||||
entries)
|
||||
(dict "name" name "signals" signals-dict))))
|
||||
|
||||
;; Freeze all scopes
|
||||
(define cek-freeze-all :effects []
|
||||
(fn ()
|
||||
(map (fn (name) (cek-freeze-scope name))
|
||||
(keys freeze-registry))))
|
||||
|
||||
;; Thaw a named scope — restore signal values from frozen data
|
||||
(define cek-thaw-scope :effects [mutation]
|
||||
(fn (name frozen)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(values (get frozen "signals")))
|
||||
(when values
|
||||
(for-each (fn (entry)
|
||||
(let ((sig-name (get entry "name"))
|
||||
(sig (get entry "signal"))
|
||||
(val (get values sig-name)))
|
||||
(when (not (nil? val))
|
||||
(reset! sig val))))
|
||||
entries)))))
|
||||
|
||||
;; Thaw all scopes from a list of frozen scope dicts
|
||||
(define cek-thaw-all :effects [mutation]
|
||||
(fn (frozen-list)
|
||||
(for-each (fn (frozen)
|
||||
(cek-thaw-scope (get frozen "name") frozen))
|
||||
frozen-list)))
|
||||
|
||||
;; Serialize a frozen scope to SX text
|
||||
(define freeze-to-sx :effects []
|
||||
(fn (name)
|
||||
(sx-serialize (cek-freeze-scope name))))
|
||||
|
||||
;; Restore from SX text
|
||||
(define thaw-from-sx :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((parsed (sx-parse sx-text)))
|
||||
(when (not (empty? parsed))
|
||||
(let ((frozen (first parsed)))
|
||||
(cek-thaw-scope (get frozen "name") frozen))))))
|
||||
275
lib/stdlib.sx
275
lib/stdlib.sx
@@ -1,275 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; stdlib.sx — Standard library functions
|
||||
;;
|
||||
;; Every function here is expressed in SX using the irreducible primitive
|
||||
;; set. They are library functions — in band, auditable, portable.
|
||||
;;
|
||||
;; Depends on: evaluator.sx (special forms)
|
||||
;; Must load before: render.sx, freeze.sx, types.sx, user code
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Logic + comparison: not, !=, <=, >= stay as primitives.
|
||||
;; Replacing them with SX lambdas changes behavior inside shift/reset
|
||||
;; because the transpiled evaluator code uses them directly.
|
||||
|
||||
(define eq? (fn (a b) (= a b)))
|
||||
(define eqv? (fn (a b) (= a b)))
|
||||
(define equal? (fn (a b) (= a b)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type predicates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; nil? stays as primitive — host's type-of uses it internally.
|
||||
|
||||
(define boolean?
|
||||
(fn (x) (= (type-of x) "boolean")))
|
||||
|
||||
(define number?
|
||||
(fn (x) (= (type-of x) "number")))
|
||||
|
||||
(define string?
|
||||
(fn (x) (= (type-of x) "string")))
|
||||
|
||||
(define list?
|
||||
(fn (x) (= (type-of x) "list")))
|
||||
|
||||
(define dict?
|
||||
(fn (x) (= (type-of x) "dict")))
|
||||
|
||||
(define continuation?
|
||||
(fn (x) (= (type-of x) "continuation")))
|
||||
|
||||
(define zero?
|
||||
(fn (n) (= n 0)))
|
||||
|
||||
(define odd?
|
||||
(fn (n) (= (mod n 2) 1)))
|
||||
|
||||
(define even?
|
||||
(fn (n) (= (mod n 2) 0)))
|
||||
|
||||
(define empty?
|
||||
(fn (coll) (or (nil? coll) (= (len coll) 0))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; inc and dec stay as primitives — used inside continuation contexts.
|
||||
|
||||
(define abs
|
||||
(fn (x) (if (< x 0) (- x) x)))
|
||||
|
||||
(define ceil
|
||||
(fn (x)
|
||||
(let ((f (floor x)))
|
||||
(if (= x f) f (+ f 1)))))
|
||||
|
||||
(define round
|
||||
(fn (x ndigits)
|
||||
(if (nil? ndigits)
|
||||
(floor (+ x 0.5))
|
||||
(let ((f (pow 10 ndigits)))
|
||||
(/ (floor (+ (* x f) 0.5)) f)))))
|
||||
|
||||
(define min
|
||||
(fn (a b) (if (< a b) a b)))
|
||||
|
||||
(define max
|
||||
(fn (a b) (if (> a b) a b)))
|
||||
|
||||
(define clamp
|
||||
(fn (x lo hi) (max lo (min hi x))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection accessors
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define first
|
||||
(fn (coll)
|
||||
(if (and coll (> (len coll) 0)) (get coll 0) nil)))
|
||||
|
||||
(define last
|
||||
(fn (coll)
|
||||
(if (and coll (> (len coll) 0))
|
||||
(get coll (- (len coll) 1))
|
||||
nil)))
|
||||
|
||||
(define rest
|
||||
(fn (coll) (if coll (slice coll 1) (list))))
|
||||
|
||||
(define nth
|
||||
(fn (coll n)
|
||||
(if (and coll (>= n 0) (< n (len coll)))
|
||||
(get coll n)
|
||||
nil)))
|
||||
|
||||
(define cons
|
||||
(fn (x coll) (concat (list x) (or coll (list)))))
|
||||
|
||||
(define append
|
||||
(fn (coll x)
|
||||
(if (list? x) (concat coll x) (concat coll (list x)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection transforms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define reverse
|
||||
(fn (coll)
|
||||
(reduce (fn (acc x) (cons x acc)) (list) coll)))
|
||||
|
||||
(define flatten
|
||||
(fn (coll)
|
||||
(reduce
|
||||
(fn (acc x)
|
||||
(if (list? x) (concat acc x) (concat acc (list x))))
|
||||
(list) coll)))
|
||||
|
||||
(define range
|
||||
(fn (start end step)
|
||||
(let ((s (if (nil? step) 1 step))
|
||||
(result (list)))
|
||||
(let loop ((i start))
|
||||
(when (< i end)
|
||||
(append! result i)
|
||||
(loop (+ i s))))
|
||||
result)))
|
||||
|
||||
(define chunk-every
|
||||
(fn (coll n)
|
||||
(let ((result (list))
|
||||
(clen (len coll)))
|
||||
(let loop ((i 0))
|
||||
(when (< i clen)
|
||||
(append! result (slice coll i (min (+ i n) clen)))
|
||||
(loop (+ i n))))
|
||||
result)))
|
||||
|
||||
(define zip-pairs
|
||||
(fn (coll)
|
||||
(let ((result (list))
|
||||
(clen (len coll)))
|
||||
(let loop ((i 0))
|
||||
(when (< i (- clen 1))
|
||||
(append! result (list (get coll i) (get coll (+ i 1))))
|
||||
(loop (+ i 1))))
|
||||
result)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dict operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vals
|
||||
(fn (d)
|
||||
(map (fn (k) (get d k)) (keys d))))
|
||||
|
||||
(define has-key?
|
||||
(fn (d key)
|
||||
(some (fn (k) (= k key)) (keys d))))
|
||||
|
||||
(define assoc
|
||||
(fn (d key val)
|
||||
(let ((result (merge d (dict))))
|
||||
(dict-set! result key val)
|
||||
result)))
|
||||
|
||||
(define dissoc
|
||||
(fn (d key)
|
||||
(let ((result (dict)))
|
||||
(for-each
|
||||
(fn (k)
|
||||
(when (!= k key)
|
||||
(dict-set! result k (get d k))))
|
||||
(keys d))
|
||||
result)))
|
||||
|
||||
(define into
|
||||
(fn (target coll)
|
||||
(cond
|
||||
(list? target)
|
||||
(if (list? coll)
|
||||
(concat coll (list))
|
||||
(let ((result (list)))
|
||||
(for-each (fn (k) (append! result (list k (get coll k)))) (keys coll))
|
||||
result))
|
||||
(dict? target)
|
||||
(let ((result (dict)))
|
||||
(for-each
|
||||
(fn (pair)
|
||||
(when (and (list? pair) (>= (len pair) 2))
|
||||
(dict-set! result (get pair 0) (get pair 1))))
|
||||
coll)
|
||||
result)
|
||||
:else target)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define upcase (fn (s) (upper s)))
|
||||
(define downcase (fn (s) (lower s)))
|
||||
(define string-length (fn (s) (len s)))
|
||||
(define substring (fn (s start end) (slice s start end)))
|
||||
|
||||
(define string-contains?
|
||||
(fn (s needle) (!= (index-of s needle) -1)))
|
||||
|
||||
(define starts-with?
|
||||
(fn (s prefix) (= (index-of s prefix) 0)))
|
||||
|
||||
(define ends-with?
|
||||
(fn (s suffix)
|
||||
(let ((slen (len s))
|
||||
(plen (len suffix)))
|
||||
(if (< slen plen) false
|
||||
(= (slice s (- slen plen)) suffix)))))
|
||||
|
||||
;; split, join, replace stay as primitives — the stdlib versions cause
|
||||
;; stack overflows due to PRIMITIVES entry shadowing in the transpiled output.
|
||||
|
||||
(define contains?
|
||||
(fn (coll key)
|
||||
(cond
|
||||
(string? coll) (!= (index-of coll (str key)) -1)
|
||||
(dict? coll) (has-key? coll key)
|
||||
(list? coll) (some (fn (x) (= x key)) coll)
|
||||
:else false)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Text utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define pluralize
|
||||
(fn (count singular plural)
|
||||
(if (= count 1)
|
||||
(or singular "")
|
||||
(or plural "s"))))
|
||||
|
||||
(define escape
|
||||
(fn (s)
|
||||
(let ((r (str s)))
|
||||
(set! r (replace r "&" "&"))
|
||||
(set! r (replace r "<" "<"))
|
||||
(set! r (replace r ">" ">"))
|
||||
(set! r (replace r "\"" """))
|
||||
(set! r (replace r "'" "'"))
|
||||
r)))
|
||||
|
||||
(define parse-datetime
|
||||
(fn (s) (if s (str s) nil)))
|
||||
|
||||
(define assert
|
||||
(fn (condition message)
|
||||
(when (not condition)
|
||||
(error (or message "Assertion failed")))
|
||||
true))
|
||||
@@ -1,244 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm-closures.sx — Tests for inner closure recursion patterns
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;;
|
||||
;; These tests exercise patterns where inner closures recurse deeply
|
||||
;; while sharing mutable state via upvalues. This is the sx-parse
|
||||
;; pattern: many inner functions close over a mutable cursor variable.
|
||||
;; Without proper VM closure support, each recursive call would
|
||||
;; allocate a fresh VM — blowing the stack or hanging.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Inner closure recursion with mutable upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "inner-closure-recursion"
|
||||
(deftest "self-recursive inner closure with set! on captured variable"
|
||||
;; Pattern: closure mutates captured var on each recursive call.
|
||||
;; This is the core pattern in skip-ws, read-str-loop, etc.
|
||||
(let ((counter 0))
|
||||
(define count-up
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! counter (+ counter 1))
|
||||
(count-up (- n 1)))))
|
||||
(count-up 100)
|
||||
(assert-equal 100 counter)))
|
||||
|
||||
(deftest "deep inner closure recursion (500 iterations)"
|
||||
;; Stress test: 500 recursive calls through an inner closure
|
||||
;; mutating a shared upvalue. Would stack-overflow without TCO.
|
||||
(let ((acc 0))
|
||||
(define sum-up
|
||||
(fn (n)
|
||||
(if (<= n 0)
|
||||
acc
|
||||
(do (set! acc (+ acc n))
|
||||
(sum-up (- n 1))))))
|
||||
(assert-equal 125250 (sum-up 500))))
|
||||
|
||||
(deftest "inner closure reading captured variable updated by another"
|
||||
;; Two closures: one writes, one reads, sharing the same binding.
|
||||
(let ((pos 0))
|
||||
(define advance! (fn () (set! pos (+ pos 1))))
|
||||
(define current (fn () pos))
|
||||
(advance!)
|
||||
(advance!)
|
||||
(advance!)
|
||||
(assert-equal 3 (current))))
|
||||
|
||||
(deftest "recursive closure with multiple mutable upvalues"
|
||||
;; Like sx-parse: multiple cursor variables mutated during recursion.
|
||||
(let ((pos 0)
|
||||
(count 0))
|
||||
(define scan
|
||||
(fn (source)
|
||||
(when (< pos (len source))
|
||||
(set! count (+ count 1))
|
||||
(set! pos (+ pos 1))
|
||||
(scan source))))
|
||||
(scan "hello world")
|
||||
(assert-equal 11 pos)
|
||||
(assert-equal 11 count))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mutual recursion between inner closures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "mutual-inner-closures"
|
||||
(deftest "two inner closures calling each other"
|
||||
;; Pattern: read-expr calls read-list, read-list calls read-expr.
|
||||
(let ((result (list)))
|
||||
(define process-a
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "a:" (first items)))
|
||||
(process-b (rest items)))))
|
||||
(define process-b
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "b:" (first items)))
|
||||
(process-a (rest items)))))
|
||||
(process-a (list 1 2 3 4))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a:1" (nth result 0))
|
||||
(assert-equal "b:2" (nth result 1))
|
||||
(assert-equal "a:3" (nth result 2))
|
||||
(assert-equal "b:4" (nth result 3))))
|
||||
|
||||
(deftest "mutual recursion with shared mutable state"
|
||||
;; Both closures read and write the same captured variable.
|
||||
(let ((pos 0)
|
||||
(source "aAbBcC"))
|
||||
(define skip-lower
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "a")
|
||||
(<= (nth source pos) "z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-upper))))
|
||||
(define skip-upper
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "A")
|
||||
(<= (nth source pos) "Z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-lower))))
|
||||
(skip-lower)
|
||||
(assert-equal 6 pos)))
|
||||
|
||||
(deftest "three-way mutual recursion"
|
||||
(let ((n 30)
|
||||
(result nil))
|
||||
(define step-a
|
||||
(fn (i)
|
||||
(if (>= i n)
|
||||
(set! result "done")
|
||||
(step-b (+ i 1)))))
|
||||
(define step-b
|
||||
(fn (i)
|
||||
(step-c (+ i 1))))
|
||||
(define step-c
|
||||
(fn (i)
|
||||
(step-a (+ i 1))))
|
||||
(step-a 0)
|
||||
(assert-equal "done" result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parser-like patterns (the sx-parse structure)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-pattern"
|
||||
(deftest "mini-parser: tokenize digits from string"
|
||||
;; Simplified sx-parse pattern: closure over pos + source,
|
||||
;; multiple inner functions sharing the mutable cursor.
|
||||
(let ((pos 0)
|
||||
(source "12 34 56")
|
||||
(len-src 8))
|
||||
|
||||
(define skip-ws
|
||||
(fn ()
|
||||
(when (and (< pos len-src) (= (nth source pos) " "))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-ws))))
|
||||
|
||||
(define read-digits
|
||||
(fn ()
|
||||
(let ((start pos))
|
||||
(define digit-loop
|
||||
(fn ()
|
||||
(when (and (< pos len-src)
|
||||
(>= (nth source pos) "0")
|
||||
(<= (nth source pos) "9"))
|
||||
(set! pos (+ pos 1))
|
||||
(digit-loop))))
|
||||
(digit-loop)
|
||||
(slice source start pos))))
|
||||
|
||||
(define read-all
|
||||
(fn ()
|
||||
(let ((tokens (list)))
|
||||
(define parse-loop
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(when (< pos len-src)
|
||||
(append! tokens (read-digits))
|
||||
(parse-loop))))
|
||||
(parse-loop)
|
||||
tokens)))
|
||||
|
||||
(let ((tokens (read-all)))
|
||||
(assert-equal 3 (len tokens))
|
||||
(assert-equal "12" (nth tokens 0))
|
||||
(assert-equal "34" (nth tokens 1))
|
||||
(assert-equal "56" (nth tokens 2)))))
|
||||
|
||||
(deftest "nested inner closures with upvalue chain"
|
||||
;; Inner function defines its own inner function,
|
||||
;; both closing over the outer mutable variable.
|
||||
(let ((total 0))
|
||||
(define outer-fn
|
||||
(fn (items)
|
||||
(for-each
|
||||
(fn (item)
|
||||
(let ((sub-total 0))
|
||||
(define inner-loop
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! sub-total (+ sub-total 1))
|
||||
(set! total (+ total 1))
|
||||
(inner-loop (- n 1)))))
|
||||
(inner-loop item)))
|
||||
items)))
|
||||
(outer-fn (list 3 2 1))
|
||||
(assert-equal 6 total)))
|
||||
|
||||
(deftest "closure returning accumulated list via append!"
|
||||
;; Pattern from read-list: loop appends to mutable list, returns it.
|
||||
(let ((items (list)))
|
||||
(define collect
|
||||
(fn (source pos)
|
||||
(if (>= pos (len source))
|
||||
items
|
||||
(do (append! items (nth source pos))
|
||||
(collect source (+ pos 1))))))
|
||||
(let ((result (collect (list "a" "b" "c" "d") 0)))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a" (first result))
|
||||
(assert-equal "d" (last result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures as callbacks to higher-order functions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "closure-ho-callbacks"
|
||||
(deftest "map with closure that mutates captured variable"
|
||||
(let ((running-total 0))
|
||||
(let ((results (map (fn (x)
|
||||
(set! running-total (+ running-total x))
|
||||
running-total)
|
||||
(list 1 2 3 4))))
|
||||
(assert-equal (list 1 3 6 10) results)
|
||||
(assert-equal 10 running-total))))
|
||||
|
||||
(deftest "reduce with closure over external state"
|
||||
(let ((call-count 0))
|
||||
(let ((sum (reduce (fn (acc x)
|
||||
(set! call-count (+ call-count 1))
|
||||
(+ acc x))
|
||||
0
|
||||
(list 10 20 30))))
|
||||
(assert-equal 60 sum)
|
||||
(assert-equal 3 call-count))))
|
||||
|
||||
(deftest "filter with closure reading shared state"
|
||||
(let ((threshold 3))
|
||||
(let ((result (filter (fn (x) (> x threshold))
|
||||
(list 1 2 3 4 5))))
|
||||
(assert-equal (list 4 5) result)))))
|
||||
@@ -1,495 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx)
|
||||
;;
|
||||
;; Requires: test-framework.sx, compiler.sx, vm.sx loaded.
|
||||
;; Tests the compile → bytecode → VM execution pipeline.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Helper: compile an SX expression and execute it on the VM.
|
||||
;; Returns the result value.
|
||||
(define vm-eval
|
||||
(fn (expr)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module
|
||||
(code-from-value code)
|
||||
{}))))
|
||||
|
||||
;; Helper: compile and run with a pre-populated globals dict.
|
||||
(define vm-eval-with
|
||||
(fn (expr globals)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module (code-from-value code) globals))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constants and literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-constants"
|
||||
(deftest "number constant"
|
||||
(assert-equal 42 (vm-eval 42)))
|
||||
|
||||
(deftest "string constant"
|
||||
(assert-equal "hello" (vm-eval "hello")))
|
||||
|
||||
(deftest "boolean true"
|
||||
(assert-equal true (vm-eval true)))
|
||||
|
||||
(deftest "boolean false"
|
||||
(assert-equal false (vm-eval false)))
|
||||
|
||||
(deftest "nil constant"
|
||||
(assert-nil (vm-eval nil)))
|
||||
|
||||
(deftest "negative number"
|
||||
(assert-equal -7 (vm-eval -7)))
|
||||
|
||||
(deftest "float constant"
|
||||
(assert-equal 3.14 (vm-eval 3.14))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic via primitives
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-arithmetic"
|
||||
(deftest "addition"
|
||||
(assert-equal 5 (vm-eval '(+ 2 3))))
|
||||
|
||||
(deftest "subtraction"
|
||||
(assert-equal 7 (vm-eval '(- 10 3))))
|
||||
|
||||
(deftest "multiplication"
|
||||
(assert-equal 24 (vm-eval '(* 6 4))))
|
||||
|
||||
(deftest "division"
|
||||
(assert-equal 5 (vm-eval '(/ 10 2))))
|
||||
|
||||
(deftest "nested arithmetic"
|
||||
(assert-equal 14 (vm-eval '(+ (* 3 4) 2))))
|
||||
|
||||
(deftest "three-arg addition"
|
||||
(assert-equal 15 (vm-eval '(+ 5 4 6)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison and logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-comparison"
|
||||
(deftest "equal numbers"
|
||||
(assert-equal true (vm-eval '(= 1 1))))
|
||||
|
||||
(deftest "unequal numbers"
|
||||
(assert-equal false (vm-eval '(= 1 2))))
|
||||
|
||||
(deftest "less than"
|
||||
(assert-equal true (vm-eval '(< 1 2))))
|
||||
|
||||
(deftest "greater than"
|
||||
(assert-equal true (vm-eval '(> 5 3))))
|
||||
|
||||
(deftest "not"
|
||||
(assert-equal true (vm-eval '(not false))))
|
||||
|
||||
(deftest "not truthy"
|
||||
(assert-equal false (vm-eval '(not 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow — if, when, cond, and, or
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-control-flow"
|
||||
(deftest "if true branch"
|
||||
(assert-equal 1 (vm-eval '(if true 1 2))))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal 2 (vm-eval '(if false 1 2))))
|
||||
|
||||
(deftest "if without else returns nil"
|
||||
(assert-nil (vm-eval '(if false 1))))
|
||||
|
||||
(deftest "when true evaluates body"
|
||||
(assert-equal 42 (vm-eval '(when true 42))))
|
||||
|
||||
(deftest "when false returns nil"
|
||||
(assert-nil (vm-eval '(when false 42))))
|
||||
|
||||
(deftest "and short-circuits on false"
|
||||
(assert-equal false (vm-eval '(and true false 42))))
|
||||
|
||||
(deftest "and returns last truthy"
|
||||
(assert-equal 3 (vm-eval '(and 1 2 3))))
|
||||
|
||||
(deftest "or short-circuits on true"
|
||||
(assert-equal 1 (vm-eval '(or 1 false 2))))
|
||||
|
||||
(deftest "or returns false when all falsy"
|
||||
(assert-equal false (vm-eval '(or false false false))))
|
||||
|
||||
(deftest "cond first match"
|
||||
(assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two"))))
|
||||
|
||||
(deftest "cond else clause"
|
||||
(assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none"))))
|
||||
|
||||
(deftest "case match"
|
||||
(assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other"))))
|
||||
|
||||
(deftest "case else"
|
||||
(assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Let bindings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-let"
|
||||
(deftest "single binding"
|
||||
(assert-equal 10 (vm-eval '(let ((x 10)) x))))
|
||||
|
||||
(deftest "multiple bindings"
|
||||
(assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y)))))
|
||||
|
||||
(deftest "bindings are sequential"
|
||||
(assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y))))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y))))))
|
||||
|
||||
(deftest "inner let shadows outer"
|
||||
(assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x)))))
|
||||
|
||||
(deftest "let body returns last expression"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lambda and function calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-lambda"
|
||||
(deftest "lambda call"
|
||||
(assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5)))))
|
||||
|
||||
(deftest "lambda with multiple params"
|
||||
(assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6)))))
|
||||
|
||||
(deftest "higher-order: pass lambda to lambda"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((apply-fn (fn (f x) (f x)))
|
||||
(double (fn (n) (* n 2))))
|
||||
(apply-fn double 5)))))
|
||||
|
||||
(deftest "lambda returns lambda"
|
||||
(assert-equal 15
|
||||
(vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x)))))
|
||||
(let ((add10 (make-adder 10)))
|
||||
(add10 5))))))
|
||||
|
||||
(deftest "immediately invoked lambda"
|
||||
(assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures and upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-closures"
|
||||
(deftest "closure captures local"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((f (fn () x)))
|
||||
(f))))))
|
||||
|
||||
(deftest "closure captures through two levels"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((y 20))
|
||||
(let ((f (fn () (+ x y))))
|
||||
(f)))))))
|
||||
|
||||
(deftest "two closures share upvalue"
|
||||
(assert-equal 42
|
||||
(vm-eval '(let ((x 0))
|
||||
(let ((set-x (fn (v) (set! x v)))
|
||||
(get-x (fn () x)))
|
||||
(set-x 42)
|
||||
(get-x))))))
|
||||
|
||||
(deftest "closure mutation visible to sibling"
|
||||
(assert-equal 3
|
||||
(vm-eval '(let ((counter 0))
|
||||
(let ((inc! (fn () (set! counter (+ counter 1)))))
|
||||
(inc!)
|
||||
(inc!)
|
||||
(inc!)
|
||||
counter))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tail call optimization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-tco"
|
||||
(deftest "tail-recursive loop doesn't overflow"
|
||||
;; Count down from 10000 — would overflow without TCO
|
||||
(assert-equal 0
|
||||
(vm-eval '(let ((loop (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(loop (- n 1))))))
|
||||
(loop 10000)))))
|
||||
|
||||
(deftest "tail-recursive accumulator"
|
||||
(assert-equal 5050
|
||||
(vm-eval '(let ((sum (fn (n acc)
|
||||
(if (<= n 0) acc
|
||||
(sum (- n 1) (+ acc n))))))
|
||||
(sum 100 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collections
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-collections"
|
||||
(deftest "list construction"
|
||||
(assert-equal (list 1 2 3) (vm-eval '(list 1 2 3))))
|
||||
|
||||
(deftest "empty list"
|
||||
(assert-equal (list) (vm-eval '(list))))
|
||||
|
||||
(deftest "dict construction"
|
||||
(let ((d (vm-eval '{:a 1 :b 2})))
|
||||
(assert-equal 1 (get d "a"))
|
||||
(assert-equal 2 (get d "b"))))
|
||||
|
||||
(deftest "list operations"
|
||||
(assert-equal 1 (vm-eval '(first (list 1 2 3))))
|
||||
(assert-equal 3 (vm-eval '(len (list 1 2 3)))))
|
||||
|
||||
(deftest "nested list"
|
||||
(assert-equal (list 1 (list 2 3))
|
||||
(vm-eval '(list 1 (list 2 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-strings"
|
||||
(deftest "str concat"
|
||||
(assert-equal "hello world" (vm-eval '(str "hello" " " "world"))))
|
||||
|
||||
(deftest "string-length"
|
||||
(assert-equal 5 (vm-eval '(string-length "hello"))))
|
||||
|
||||
(deftest "str coerces numbers"
|
||||
(assert-equal "42" (vm-eval '(str 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Define — top-level and local
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-define"
|
||||
(deftest "top-level define"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do (define x 42) x))))
|
||||
|
||||
(deftest "define function then call"
|
||||
(assert-equal 10
|
||||
(vm-eval '(do
|
||||
(define double (fn (n) (* n 2)))
|
||||
(double 5)))))
|
||||
|
||||
(deftest "local define inside fn"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((f (fn (x)
|
||||
(define y (* x 2))
|
||||
(+ x y))))
|
||||
(f 10)))))
|
||||
|
||||
(deftest "define with forward reference"
|
||||
(assert-equal 120
|
||||
(vm-eval '(do
|
||||
(define fact (fn (n)
|
||||
(if (<= n 1) 1 (* n (fact (- n 1))))))
|
||||
(fact 5))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Letrec — mutual recursion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-letrec"
|
||||
(deftest "letrec self-recursion"
|
||||
(assert-equal 55
|
||||
(vm-eval '(letrec ((sum-to (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(+ n (sum-to (- n 1)))))))
|
||||
(sum-to 10)))))
|
||||
|
||||
(deftest "letrec mutual recursion"
|
||||
(assert-equal true
|
||||
(vm-eval '(letrec ((my-even? (fn (n)
|
||||
(if (= n 0) true (my-odd? (- n 1)))))
|
||||
(my-odd? (fn (n)
|
||||
(if (= n 0) false (my-even? (- n 1))))))
|
||||
(my-even? 10))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quasiquote
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-quasiquote"
|
||||
(deftest "simple quasiquote"
|
||||
(assert-equal (list 1 2 3)
|
||||
(vm-eval '(let ((x 2)) `(1 ,x 3)))))
|
||||
|
||||
(deftest "quasiquote with splice"
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Thread macro
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-threading"
|
||||
(deftest "thread-first"
|
||||
(assert-equal 7
|
||||
(vm-eval '(-> 5 (+ 2)))))
|
||||
|
||||
(deftest "thread-first chain"
|
||||
(assert-equal 12
|
||||
(vm-eval '(-> 10 (+ 5) (- 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Integration: compile then execute
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-integration"
|
||||
(deftest "fibonacci"
|
||||
(assert-equal 55
|
||||
(vm-eval '(do
|
||||
(define fib (fn (n)
|
||||
(if (<= n 1) n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
(fib 10)))))
|
||||
|
||||
(deftest "map via recursive define"
|
||||
(assert-equal (list 2 4 6)
|
||||
(vm-eval '(do
|
||||
(define my-map (fn (f lst)
|
||||
(if (empty? lst) (list)
|
||||
(cons (f (first lst)) (my-map f (rest lst))))))
|
||||
(my-map (fn (x) (* x 2)) (list 1 2 3))))))
|
||||
|
||||
(deftest "filter via recursive define"
|
||||
(assert-equal (list 2 4)
|
||||
(vm-eval '(do
|
||||
(define my-filter (fn (pred lst)
|
||||
(if (empty? lst) (list)
|
||||
(if (pred (first lst))
|
||||
(cons (first lst) (my-filter pred (rest lst)))
|
||||
(my-filter pred (rest lst))))))
|
||||
(my-filter (fn (x) (even? x)) (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "reduce via recursive define"
|
||||
(assert-equal 15
|
||||
(vm-eval '(do
|
||||
(define my-reduce (fn (f acc lst)
|
||||
(if (empty? lst) acc
|
||||
(my-reduce f (f acc (first lst)) (rest lst)))))
|
||||
(my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "nested function calls"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do
|
||||
(define compose (fn (f g) (fn (x) (f (g x)))))
|
||||
(define inc (fn (x) (+ x 1)))
|
||||
(define double (fn (x) (* x 2)))
|
||||
(let ((inc-then-double (compose double inc)))
|
||||
(inc-then-double 20)))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; VM recursive mutation — closure capture must preserve mutable references
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The stepper island's
|
||||
;; split-tag function produced 1 step instead of 16, breaking SSR.
|
||||
|
||||
(defsuite "vm-recursive-mutation"
|
||||
(deftest "recursive append! to shared list"
|
||||
(assert-equal 3
|
||||
(vm-eval '(do
|
||||
(define walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive tree walk with append!"
|
||||
(assert-equal 7
|
||||
(vm-eval '(do
|
||||
(define walk-children (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-children (rest items) result walk-fn))))
|
||||
(define walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(walk-children (rest expr) result walk)
|
||||
(append! result "close")))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive walk matching stepper split-tag pattern"
|
||||
(assert-equal 16
|
||||
(vm-eval '(do
|
||||
(define walk-each (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-each (rest items) result walk-fn))))
|
||||
(define collect-children (fn (items cch)
|
||||
(when (not (empty? items))
|
||||
(let ((a (first items)))
|
||||
(if (and (list? a) (not (empty? a))
|
||||
(= (type-of (first a)) "symbol")
|
||||
(starts-with? (symbol-name (first a)) "~"))
|
||||
nil ;; skip component spreads
|
||||
(append! cch a))
|
||||
(collect-children (rest items) cch)))))
|
||||
(define split-tag (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
(not (= (type-of (first expr)) "symbol"))
|
||||
(append! result "leaf")
|
||||
(is-html-tag? (symbol-name (first expr)))
|
||||
(let ((cch (list)))
|
||||
(collect-children (rest expr) cch)
|
||||
(append! result "open")
|
||||
(walk-each cch result split-tag)
|
||||
(append! result "close"))
|
||||
:else
|
||||
(append! result "expr"))))
|
||||
(let ((parsed (sx-parse "(div (~cssx/tw :tokens \"text-center\")\n (h1 (~cssx/tw :tokens \"text-3xl font-bold mb-2\")\n (span (~cssx/tw :tokens \"text-rose-500\") \"the \")\n (span (~cssx/tw :tokens \"text-amber-500\") \"joy \")\n (span (~cssx/tw :tokens \"text-emerald-500\") \"of \")\n (span (~cssx/tw :tokens \"text-violet-600 text-4xl\") \"sx\")))"))
|
||||
(result (list)))
|
||||
(split-tag (first parsed) result)
|
||||
(len result)))))))
|
||||
@@ -1,117 +0,0 @@
|
||||
;; vm-inline.sx — Tests for inline VM opcodes (OP_ADD, OP_EQ, etc.)
|
||||
;;
|
||||
;; These verify that the JIT-compiled inline opcodes produce
|
||||
;; identical results to the CALL_PRIM fallback.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline + integers" (= (+ 3 4) 7))
|
||||
(test "inline + floats" (= (+ 1.5 2.5) 4.0))
|
||||
(test "inline + string concat" (= (+ "hello" " world") "hello world"))
|
||||
(test "inline - integers" (= (- 10 3) 7))
|
||||
(test "inline - negative" (= (- 3 10) -7))
|
||||
(test "inline * integers" (= (* 6 7) 42))
|
||||
(test "inline * float" (= (* 2.5 4.0) 10.0))
|
||||
(test "inline / integers" (= (/ 10 2) 5))
|
||||
(test "inline / float" (= (/ 7.0 2.0) 3.5))
|
||||
(test "inline inc" (= (inc 5) 6))
|
||||
(test "inline dec" (= (dec 5) 4))
|
||||
(test "inline inc float" (= (inc 2.5) 3.5))
|
||||
(test "inline dec zero" (= (dec 0) -1))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline = numbers" (= 5 5))
|
||||
(test "inline = strings" (= "hello" "hello"))
|
||||
(test "inline = false" (not (= 5 6)))
|
||||
(test "inline = nil" (= nil nil))
|
||||
(test "inline = mixed false" (not (= 5 "5")))
|
||||
(test "inline < numbers" (< 3 5))
|
||||
(test "inline < false" (not (< 5 3)))
|
||||
(test "inline < equal" (not (< 5 5)))
|
||||
(test "inline < strings" (< "abc" "def"))
|
||||
(test "inline > numbers" (> 5 3))
|
||||
(test "inline > false" (not (> 3 5)))
|
||||
(test "inline > equal" (not (> 5 5)))
|
||||
(test "inline not true" (= (not true) false))
|
||||
(test "inline not false" (= (not false) true))
|
||||
(test "inline not nil" (= (not nil) true))
|
||||
(test "inline not number" (= (not 0) true))
|
||||
(test "inline not string" (= (not "") true))
|
||||
(test "inline not nonempty" (= (not "x") false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection ops
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline len list" (= (len (list 1 2 3)) 3))
|
||||
(test "inline len string" (= (len "hello") 5))
|
||||
(test "inline len empty" (= (len (list)) 0))
|
||||
(test "inline len nil" (= (len nil) 0))
|
||||
(test "inline first" (= (first (list 10 20 30)) 10))
|
||||
(test "inline first empty" (= (first (list)) nil))
|
||||
(test "inline rest" (= (rest (list 1 2 3)) (list 2 3)))
|
||||
(test "inline rest single" (= (rest (list 1)) (list)))
|
||||
(test "inline nth" (= (nth (list 10 20 30) 1) 20))
|
||||
(test "inline nth zero" (= (nth (list 10 20 30) 0) 10))
|
||||
(test "inline nth out of bounds" (= (nth (list 1 2) 5) nil))
|
||||
(test "inline cons" (= (cons 1 (list 2 3)) (list 1 2 3)))
|
||||
(test "inline cons to empty" (= (cons 1 (list)) (list 1)))
|
||||
(test "inline cons to nil" (= (cons 1 nil) (list 1)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Composition — inline ops in expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "nested arithmetic" (= (+ (* 3 4) (- 10 5)) 17))
|
||||
(test "comparison in if" (if (< 3 5) "yes" "no") (= "yes"))
|
||||
(test "len in condition" (if (> (len (list 1 2 3)) 2) true false))
|
||||
(test "inc in loop" (= (let ((x 0)) (for-each (fn (_) (set! x (inc x))) (list 1 2 3)) x) 3))
|
||||
(test "first + rest roundtrip" (= (cons (first (list 1 2 3)) (rest (list 1 2 3))) (list 1 2 3)))
|
||||
(test "nested comparison" (= (and (< 1 2) (> 3 0) (= 5 5)) true))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "+ with nil" (= (+ 5 nil) 5))
|
||||
(test "len of dict" (= (len {:a 1 :b 2}) 2))
|
||||
(test "= with booleans" (= (= true true) true))
|
||||
(test "= with keywords" (= (= :foo :foo) true))
|
||||
(test "not with list" (= (not (list 1)) false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Recursive mutation — VM closure capture must preserve mutable state
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The VM closure capture
|
||||
;; was copying the list value instead of sharing the mutable reference.
|
||||
|
||||
(test "recursive append! to shared list"
|
||||
(let ((walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result)))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(= (len result) 3))))
|
||||
|
||||
(test "recursive tree walk with append!"
|
||||
(let ((walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(for-each (fn (c) (walk c result)) (rest expr))
|
||||
(append! result "close"))))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(= (len result) 7))))
|
||||
633
lib/vm.sx
633
lib/vm.sx
@@ -1,633 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; vm.sx — SX bytecode virtual machine
|
||||
;;
|
||||
;; Stack-based interpreter for bytecode produced by compiler.sx.
|
||||
;; Written in SX — transpiled to each target (OCaml, JS, WASM).
|
||||
;;
|
||||
;; Architecture:
|
||||
;; - Array-based value stack (no allocation per step)
|
||||
;; - Frame list for call stack (one frame per function invocation)
|
||||
;; - Upvalue cells for shared mutable closure variables
|
||||
;; - Iterative dispatch loop (no host-stack growth)
|
||||
;; - TCO via frame replacement on OP_TAIL_CALL
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; The host must provide:
|
||||
;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow
|
||||
;; - cek-call (fallback for Lambda/Component)
|
||||
;; - get-primitive (primitive lookup)
|
||||
;; Everything else is defined here.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Types — VM data structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Upvalue cell — shared mutable reference for captured variables.
|
||||
;; When a closure captures a local, both the parent frame and the
|
||||
;; closure read/write through this cell.
|
||||
(define make-upvalue-cell
|
||||
(fn (value)
|
||||
{:uv-value value}))
|
||||
|
||||
(define uv-get (fn (cell) (get cell "uv-value")))
|
||||
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
|
||||
|
||||
;; VM code object — compiled bytecode + constant pool.
|
||||
;; Produced by compiler.sx, consumed by the VM.
|
||||
(define make-vm-code
|
||||
(fn (arity locals bytecode constants)
|
||||
{:vc-arity arity
|
||||
:vc-locals locals
|
||||
:vc-bytecode bytecode
|
||||
:vc-constants constants}))
|
||||
|
||||
;; VM closure — code + captured upvalues + globals reference.
|
||||
(define make-vm-closure
|
||||
(fn (code upvalues name globals closure-env)
|
||||
{:vm-code code
|
||||
:vm-upvalues upvalues
|
||||
:vm-name name
|
||||
:vm-globals globals
|
||||
:vm-closure-env closure-env}))
|
||||
|
||||
;; VM frame — one per active function invocation.
|
||||
(define make-vm-frame
|
||||
(fn (closure base)
|
||||
{:closure closure
|
||||
:ip 0
|
||||
:base base
|
||||
:local-cells {}}))
|
||||
|
||||
;; VM state — the virtual machine.
|
||||
(define make-vm
|
||||
(fn (globals)
|
||||
{:stack (make-vm-stack 4096)
|
||||
:sp 0
|
||||
:frames (list)
|
||||
:globals globals}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Stack operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-push
|
||||
(fn (vm value)
|
||||
(let ((sp (get vm "sp"))
|
||||
(stack (get vm "stack")))
|
||||
;; Grow stack if needed
|
||||
(when (>= sp (vm-stack-length stack))
|
||||
(let ((new-stack (make-vm-stack (* sp 2))))
|
||||
(vm-stack-copy! stack new-stack sp)
|
||||
(dict-set! vm "stack" new-stack)
|
||||
(set! stack new-stack)))
|
||||
(vm-stack-set! stack sp value)
|
||||
(dict-set! vm "sp" (+ sp 1)))))
|
||||
|
||||
(define vm-pop
|
||||
(fn (vm)
|
||||
(let ((sp (- (get vm "sp") 1)))
|
||||
(dict-set! vm "sp" sp)
|
||||
(vm-stack-get (get vm "stack") sp))))
|
||||
|
||||
(define vm-peek
|
||||
(fn (vm)
|
||||
(vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Operand reading — read from bytecode stream
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-read-u8
|
||||
(fn (frame)
|
||||
(let ((ip (get frame "ip"))
|
||||
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
|
||||
(let ((v (nth bc ip)))
|
||||
(dict-set! frame "ip" (+ ip 1))
|
||||
v))))
|
||||
|
||||
(define frame-read-u16
|
||||
(fn (frame)
|
||||
(let ((lo (frame-read-u8 frame))
|
||||
(hi (frame-read-u8 frame)))
|
||||
(+ lo (* hi 256)))))
|
||||
|
||||
(define frame-read-i16
|
||||
(fn (frame)
|
||||
(let ((v (frame-read-u16 frame)))
|
||||
(if (>= v 32768) (- v 65536) v))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Frame management
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Push a closure frame onto the VM.
|
||||
;; Lays out args as locals, pads remaining locals with nil.
|
||||
(define vm-push-frame
|
||||
(fn (vm closure args)
|
||||
(let ((frame (make-vm-frame closure (get vm "sp"))))
|
||||
(for-each (fn (a) (vm-push vm a)) args)
|
||||
;; Pad remaining local slots with nil
|
||||
(let ((arity (len args))
|
||||
(total-locals (get (get closure "vm-code") "vc-locals")))
|
||||
(let ((pad-count (- total-locals arity)))
|
||||
(when (> pad-count 0)
|
||||
(let ((i 0))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i pad-count)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop)))))
|
||||
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Code loading — convert compiler output to VM structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define code-from-value
|
||||
(fn (v)
|
||||
"Convert a compiler output dict to a vm-code object."
|
||||
(if (not (dict? v))
|
||||
(make-vm-code 0 16 (list) (list))
|
||||
(let ((bc-raw (get v "bytecode"))
|
||||
(bc (if (nil? bc-raw) (list) bc-raw))
|
||||
(consts-raw (get v "constants"))
|
||||
(consts (if (nil? consts-raw) (list) consts-raw))
|
||||
(arity-raw (get v "arity"))
|
||||
(arity (if (nil? arity-raw) 0 arity-raw)))
|
||||
(make-vm-code arity (+ arity 16) bc consts)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Call dispatch — route calls by value type
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; vm-call dispatches a function call within the VM.
|
||||
;; VmClosure: push frame on current VM (fast path, enables TCO).
|
||||
;; NativeFn: call directly, push result.
|
||||
;; Lambda/Component: fall back to CEK evaluator.
|
||||
(define vm-closure?
|
||||
(fn (v)
|
||||
(and (dict? v) (has-key? v "vm-code"))))
|
||||
|
||||
(define vm-call
|
||||
(fn (vm f args)
|
||||
(cond
|
||||
(vm-closure? f)
|
||||
;; Fast path: push frame on current VM
|
||||
(vm-push-frame vm f args)
|
||||
|
||||
(callable? f)
|
||||
;; Native function or primitive
|
||||
(vm-push vm (apply f args))
|
||||
|
||||
(or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island"))
|
||||
;; CEK fallback — the host provides cek-call
|
||||
(vm-push vm (cek-call f args))
|
||||
|
||||
:else
|
||||
(error (str "VM: not callable: " (type-of f))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Local/upvalue access helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-local-get
|
||||
(fn (vm frame slot)
|
||||
"Read a local variable — check shared cells first, then stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-get (get cells key))
|
||||
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
|
||||
|
||||
(define frame-local-set
|
||||
(fn (vm frame slot value)
|
||||
"Write a local variable — to shared cell if captured, else to stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-set! (get cells key) value)
|
||||
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
|
||||
|
||||
(define frame-upvalue-get
|
||||
(fn (frame idx)
|
||||
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
|
||||
|
||||
(define frame-upvalue-set
|
||||
(fn (frame idx value)
|
||||
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Global variable access with closure env chain
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-global-get
|
||||
(fn (vm frame name)
|
||||
"Look up a global: globals table → closure env chain → primitives."
|
||||
(let ((globals (get vm "globals")))
|
||||
(if (has-key? globals name)
|
||||
(get globals name)
|
||||
;; Walk the closure env chain for inner functions
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env")))
|
||||
(if (nil? closure-env)
|
||||
(get-primitive name)
|
||||
(let ((found (env-walk closure-env name)))
|
||||
(if (nil? found)
|
||||
(get-primitive name)
|
||||
found))))))))
|
||||
|
||||
(define vm-global-set
|
||||
(fn (vm frame name value)
|
||||
"Set a global: write to closure env if name exists there, else globals."
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env"))
|
||||
(written false))
|
||||
(when (not (nil? closure-env))
|
||||
(set! written (env-walk-set! closure-env name value)))
|
||||
(when (not written)
|
||||
(dict-set! (get vm "globals") name value)))))
|
||||
|
||||
;; env-walk: walk an environment chain looking for a binding.
|
||||
;; Returns the value or nil if not found.
|
||||
(define env-walk
|
||||
(fn (env name)
|
||||
(if (nil? env) nil
|
||||
(if (env-has? env name)
|
||||
(env-get env name)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) nil
|
||||
(env-walk parent name)))))))
|
||||
|
||||
;; env-walk-set!: walk an environment chain, set value if name found.
|
||||
;; Returns true if set, false if not found.
|
||||
(define env-walk-set!
|
||||
(fn (env name value)
|
||||
(if (nil? env) false
|
||||
(if (env-has? env name)
|
||||
(do (env-set! env name value) true)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) false
|
||||
(env-walk-set! parent name value)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Closure creation — OP_CLOSURE with upvalue capture
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-create-closure
|
||||
(fn (vm frame code-val)
|
||||
"Create a closure from a code constant. Reads upvalue descriptors
|
||||
from the bytecode stream and captures values from the enclosing frame."
|
||||
(let ((code (code-from-value code-val))
|
||||
(uv-count (if (dict? code-val)
|
||||
(let ((n (get code-val "upvalue-count")))
|
||||
(if (nil? n) 0 n))
|
||||
0)))
|
||||
(let ((upvalues
|
||||
(let ((result (list))
|
||||
(i 0))
|
||||
(define capture-loop
|
||||
(fn ()
|
||||
(when (< i uv-count)
|
||||
(let ((is-local (frame-read-u8 frame))
|
||||
(index (frame-read-u8 frame)))
|
||||
(let ((cell
|
||||
(if (= is-local 1)
|
||||
;; Capture from enclosing frame's local slot.
|
||||
;; Create/reuse a shared cell so both parent
|
||||
;; and closure read/write through it.
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str index)))
|
||||
(if (has-key? cells key)
|
||||
(get cells key)
|
||||
(let ((c (make-upvalue-cell
|
||||
(vm-stack-get (get vm "stack")
|
||||
(+ (get frame "base") index)))))
|
||||
(dict-set! cells key c)
|
||||
c)))
|
||||
;; Capture from enclosing frame's upvalue
|
||||
(nth (get (get frame "closure") "vm-upvalues") index))))
|
||||
(append! result cell)
|
||||
(set! i (+ i 1))
|
||||
(capture-loop))))))
|
||||
(capture-loop)
|
||||
result)))
|
||||
(make-vm-closure code upvalues nil
|
||||
(get vm "globals") nil)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Main execution loop — iterative dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-run
|
||||
(fn (vm)
|
||||
"Execute bytecode until all frames are exhausted.
|
||||
VmClosure calls push new frames; the loop picks them up.
|
||||
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
|
||||
(define loop
|
||||
(fn ()
|
||||
(when (not (empty? (get vm "frames")))
|
||||
(let ((frame (first (get vm "frames")))
|
||||
(rest-frames (rest (get vm "frames"))))
|
||||
(let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
|
||||
(consts (get (get (get frame "closure") "vm-code") "vc-constants")))
|
||||
(if (>= (get frame "ip") (len bc))
|
||||
;; Bytecode exhausted — stop
|
||||
(dict-set! vm "frames" (list))
|
||||
(do
|
||||
(vm-step vm frame rest-frames bc consts)
|
||||
(loop))))))))
|
||||
(loop)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Single step — opcode dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-step
|
||||
(fn (vm frame rest-frames bc consts)
|
||||
(let ((op (frame-read-u8 frame)))
|
||||
(cond
|
||||
|
||||
;; ---- Constants ----
|
||||
(= op 1) ;; OP_CONST
|
||||
(let ((idx (frame-read-u16 frame)))
|
||||
(vm-push vm (nth consts idx)))
|
||||
|
||||
(= op 2) ;; OP_NIL
|
||||
(vm-push vm nil)
|
||||
|
||||
(= op 3) ;; OP_TRUE
|
||||
(vm-push vm true)
|
||||
|
||||
(= op 4) ;; OP_FALSE
|
||||
(vm-push vm false)
|
||||
|
||||
(= op 5) ;; OP_POP
|
||||
(vm-pop vm)
|
||||
|
||||
(= op 6) ;; OP_DUP
|
||||
(vm-push vm (vm-peek vm))
|
||||
|
||||
;; ---- Variable access ----
|
||||
(= op 16) ;; OP_LOCAL_GET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-local-get vm frame slot)))
|
||||
|
||||
(= op 17) ;; OP_LOCAL_SET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(frame-local-set vm frame slot (vm-peek vm)))
|
||||
|
||||
(= op 18) ;; OP_UPVALUE_GET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-upvalue-get frame idx)))
|
||||
|
||||
(= op 19) ;; OP_UPVALUE_SET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(frame-upvalue-set frame idx (vm-peek vm)))
|
||||
|
||||
(= op 20) ;; OP_GLOBAL_GET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-push vm (vm-global-get vm frame name)))
|
||||
|
||||
(= op 21) ;; OP_GLOBAL_SET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-global-set vm frame name (vm-peek vm)))
|
||||
|
||||
;; ---- Control flow ----
|
||||
(= op 32) ;; OP_JUMP
|
||||
(let ((offset (frame-read-i16 frame)))
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset)))
|
||||
|
||||
(= op 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when (not v)
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
(= op 34) ;; OP_JUMP_IF_TRUE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when v
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
;; ---- Function calls ----
|
||||
(= op 48) ;; OP_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 49) ;; OP_TAIL_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
;; Drop current frame, reuse stack space — true TCO
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 50) ;; OP_RETURN
|
||||
(let ((result (vm-pop vm)))
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-push vm result))
|
||||
|
||||
(= op 51) ;; OP_CLOSURE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(code-val (nth consts idx)))
|
||||
(let ((cl (vm-create-closure vm frame code-val)))
|
||||
(vm-push vm cl)))
|
||||
|
||||
(= op 52) ;; OP_CALL_PRIM
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(argc (frame-read-u8 frame))
|
||||
(name (nth consts idx))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(vm-push vm (call-primitive name args-rev)))
|
||||
|
||||
;; ---- Collections ----
|
||||
(= op 64) ;; OP_LIST
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(items-rev (list))
|
||||
(i 0))
|
||||
(define collect-items
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! items-rev (cons (vm-pop vm) items-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-items))))
|
||||
(collect-items)
|
||||
(vm-push vm items-rev))
|
||||
|
||||
(= op 65) ;; OP_DICT
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(d {})
|
||||
(i 0))
|
||||
(define collect-pairs
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(let ((v (vm-pop vm))
|
||||
(k (vm-pop vm)))
|
||||
(dict-set! d k v)
|
||||
(set! i (+ i 1))
|
||||
(collect-pairs)))))
|
||||
(collect-pairs)
|
||||
(vm-push vm d))
|
||||
|
||||
;; ---- String ops ----
|
||||
(= op 144) ;; OP_STR_CONCAT
|
||||
(let ((count (frame-read-u8 frame))
|
||||
(parts-rev (list))
|
||||
(i 0))
|
||||
(define collect-parts
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! parts-rev (cons (vm-pop vm) parts-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-parts))))
|
||||
(collect-parts)
|
||||
(vm-push vm (apply str parts-rev)))
|
||||
|
||||
;; ---- Define ----
|
||||
(= op 128) ;; OP_DEFINE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(dict-set! (get vm "globals") name (vm-peek vm)))
|
||||
|
||||
;; ---- Inline primitives ----
|
||||
(= op 160) ;; OP_ADD
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (+ a b)))
|
||||
(= op 161) ;; OP_SUB
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (- a b)))
|
||||
(= op 162) ;; OP_MUL
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (* a b)))
|
||||
(= op 163) ;; OP_DIV
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (/ a b)))
|
||||
(= op 164) ;; OP_EQ
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (= a b)))
|
||||
(= op 165) ;; OP_LT
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (< a b)))
|
||||
(= op 166) ;; OP_GT
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (> a b)))
|
||||
(= op 167) ;; OP_NOT
|
||||
(vm-push vm (not (vm-pop vm)))
|
||||
(= op 168) ;; OP_LEN
|
||||
(vm-push vm (len (vm-pop vm)))
|
||||
(= op 169) ;; OP_FIRST
|
||||
(vm-push vm (first (vm-pop vm)))
|
||||
(= op 170) ;; OP_REST
|
||||
(vm-push vm (rest (vm-pop vm)))
|
||||
(= op 171) ;; OP_NTH
|
||||
(let ((n (vm-pop vm)) (coll (vm-pop vm)))
|
||||
(vm-push vm (nth coll n)))
|
||||
(= op 172) ;; OP_CONS
|
||||
(let ((coll (vm-pop vm)) (x (vm-pop vm)))
|
||||
(vm-push vm (cons x coll)))
|
||||
(= op 173) ;; OP_NEG
|
||||
(vm-push vm (- 0 (vm-pop vm)))
|
||||
(= op 174) ;; OP_INC
|
||||
(vm-push vm (inc (vm-pop vm)))
|
||||
(= op 175) ;; OP_DEC
|
||||
(vm-push vm (dec (vm-pop vm)))
|
||||
|
||||
:else
|
||||
(error (str "VM: unknown opcode " op))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 12. Entry points
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Execute a closure with arguments — creates a fresh VM.
|
||||
(define vm-call-closure
|
||||
(fn (closure args globals)
|
||||
(let ((vm (make-vm globals)))
|
||||
(vm-push-frame vm closure args)
|
||||
(vm-run vm)
|
||||
(vm-pop vm))))
|
||||
|
||||
;; Execute a compiled module (top-level bytecode).
|
||||
(define vm-execute-module
|
||||
(fn (code globals)
|
||||
(let ((closure (make-vm-closure code (list) "module" globals nil))
|
||||
(vm (make-vm globals)))
|
||||
(let ((frame (make-vm-frame closure 0)))
|
||||
;; Pad local slots
|
||||
(let ((i 0)
|
||||
(total (get code "vc-locals")))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i total)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop))
|
||||
(dict-set! vm "frames" (list frame))
|
||||
(vm-run vm)
|
||||
(vm-pop vm)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 13. Platform interface
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Each target must provide:
|
||||
;;
|
||||
;; make-vm-stack(size) → opaque stack (array-like)
|
||||
;; vm-stack-get(stack, idx) → value at index
|
||||
;; vm-stack-set!(stack, idx, value) → mutate index
|
||||
;; vm-stack-length(stack) → current capacity
|
||||
;; vm-stack-copy!(src, dst, count) → copy first count elements
|
||||
;;
|
||||
;; cek-call(f, args) → evaluate via CEK machine (fallback)
|
||||
;; get-primitive(name) → look up primitive by name (returns callable)
|
||||
;; call-primitive(name, args) → call primitive directly with args list
|
||||
;;
|
||||
;; env-parent(env) → parent environment or nil
|
||||
;; env-has?(env, name) → boolean
|
||||
;; env-get(env, name) → value
|
||||
;; env-set!(env, name, value) → mutate binding
|
||||
166
run-tests.sh
166
run-tests.sh
@@ -1,166 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# ===========================================================================
|
||||
# run-tests.sh — Run ALL test suites. Exit non-zero if any fail.
|
||||
#
|
||||
# Usage:
|
||||
# ./run-tests.sh # run everything
|
||||
# ./run-tests.sh --quick # skip Playwright (fast CI check)
|
||||
# ./run-tests.sh --sx-only # SX language tests only (JS + Python + OCaml)
|
||||
# ===========================================================================
|
||||
set -euo pipefail
|
||||
|
||||
cd "$(dirname "$0")"
|
||||
|
||||
QUICK=false
|
||||
SX_ONLY=false
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
--quick) QUICK=true ;;
|
||||
--sx-only) SX_ONLY=true ;;
|
||||
esac
|
||||
done
|
||||
|
||||
FAILURES=()
|
||||
PASSES=()
|
||||
|
||||
run_suite() {
|
||||
local name="$1"
|
||||
shift
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " $name"
|
||||
echo "============================================================"
|
||||
if "$@"; then
|
||||
PASSES+=("$name")
|
||||
else
|
||||
FAILURES+=("$name")
|
||||
fi
|
||||
}
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 1. Build SX bundles
|
||||
# -------------------------------------------------------------------
|
||||
echo "=== Building SX bundles ==="
|
||||
python3 hosts/javascript/cli.py --output shared/static/scripts/sx-browser.js
|
||||
python3 hosts/javascript/cli.py --extensions continuations --spec-modules types \
|
||||
--output shared/static/scripts/sx-full-test.js
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 2. JavaScript SX tests (standard + full)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS standard (spec tests)" \
|
||||
node hosts/javascript/run_tests.js
|
||||
|
||||
run_suite "JS full (spec + continuations + types + VM)" \
|
||||
node hosts/javascript/run_tests.js --full
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 3. OCaml SX tests
|
||||
# -------------------------------------------------------------------
|
||||
if [ -x hosts/ocaml/_build/default/bin/run_tests.exe ]; then
|
||||
run_suite "OCaml (spec tests)" \
|
||||
hosts/ocaml/_build/default/bin/run_tests.exe
|
||||
else
|
||||
echo ""
|
||||
echo "[SKIP] OCaml tests — binary not built (run: cd hosts/ocaml && dune build)"
|
||||
fi
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 4. OCaml bridge integration (custom special forms, web-forms.sx)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml bridge — custom special forms + web-forms" \
|
||||
python3 -c "
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
bridge = OcamlSync()
|
||||
# Load exactly what the server does (no evaluator.sx!)
|
||||
for f in ['spec/parser.sx', 'spec/render.sx', 'web/adapter-html.sx', 'web/adapter-sx.sx', 'web/web-forms.sx', 'lib/freeze.sx']:
|
||||
bridge.load(f)
|
||||
ok = 0; fail = 0
|
||||
def check(name, expr, expected=None):
|
||||
global ok, fail
|
||||
try:
|
||||
r = bridge.eval(expr)
|
||||
if expected is not None and r != expected:
|
||||
print(f' FAIL: {name}: expected {expected!r}, got {r!r}'); fail += 1
|
||||
else:
|
||||
print(f' PASS: {name}'); ok += 1
|
||||
except Exception as e:
|
||||
print(f' FAIL: {name}: {e}'); fail += 1
|
||||
|
||||
# Custom special forms registered by web-forms.sx
|
||||
for form in ['defhandler', 'defquery', 'defaction', 'defpage', 'defrelation', 'defstyle', 'deftype', 'defeffect']:
|
||||
check(f'{form} registered', f'(has-key? *custom-special-forms* \"{form}\")', 'true')
|
||||
|
||||
# Custom forms callable via eval (not just via load)
|
||||
check('deftype via eval', '(deftype test-t number)', 'nil')
|
||||
check('defeffect via eval', '(defeffect test-e)', 'nil')
|
||||
check('defstyle via eval', '(defstyle my-s \"bold\")', 'bold')
|
||||
check('defhandler via eval', '(has-key? (defhandler test-h (&key x) x) \"__type\")', 'true')
|
||||
|
||||
# Extension lists populated
|
||||
check('definition-form-extensions populated', '(> (len *definition-form-extensions*) 0)', 'true')
|
||||
check('RENDER_HTML_FORMS has defstyle', '(contains? RENDER_HTML_FORMS \"defstyle\")', 'true')
|
||||
|
||||
# Env-shadowing regression: custom forms survive evaluator.sx load
|
||||
bridge2 = OcamlSync()
|
||||
bridge2.eval('(register-special-form! \"shadow-test\" (fn (args env) 42))')
|
||||
bridge2.load('spec/evaluator.sx')
|
||||
check('custom form survives evaluator.sx load',
|
||||
bridge2.eval('(has-key? *custom-special-forms* \"shadow-test\")'), 'true')
|
||||
bridge2.eval('(register-special-form! \"post-load\" (fn (args env) 99))')
|
||||
check('custom form callable after evaluator.sx load',
|
||||
bridge2.eval('(post-load 1)'), '99')
|
||||
|
||||
print(f'\\nResults: {ok} passed, {fail} failed')
|
||||
import sys; sys.exit(1 if fail > 0 else 0)
|
||||
"
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 5. Python SX tests (post-removal regression, components, parser)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "Python — post-removal regression" \
|
||||
python3 -m pytest shared/sx/tests/test_post_removal_bugs.py -v --tb=short
|
||||
|
||||
run_suite "Python — component rendering" \
|
||||
python3 -m pytest shared/sx/tests/test_components.py -v --tb=short
|
||||
|
||||
run_suite "Python — parser" \
|
||||
python3 -m pytest shared/sx/tests/test_parser.py -v --tb=short
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 5. Playwright tests (browser)
|
||||
# -------------------------------------------------------------------
|
||||
if [ "$QUICK" = false ] && [ "$SX_ONLY" = false ]; then
|
||||
run_suite "Playwright — isomorphic SSR" \
|
||||
npx playwright test --reporter=list
|
||||
|
||||
run_suite "Playwright — SX demos (98 tests)" \
|
||||
python3 -m pytest sx/tests/test_demos.py -v --tb=short
|
||||
fi
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# Summary
|
||||
# -------------------------------------------------------------------
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " TEST SUMMARY"
|
||||
echo "============================================================"
|
||||
for p in "${PASSES[@]}"; do
|
||||
echo " PASS: $p"
|
||||
done
|
||||
for f in "${FAILURES[@]}"; do
|
||||
echo " FAIL: $f"
|
||||
done
|
||||
echo "============================================================"
|
||||
|
||||
if [ ${#FAILURES[@]} -gt 0 ]; then
|
||||
echo ""
|
||||
echo " ${#FAILURES[@]} suite(s) FAILED — deploy blocked."
|
||||
echo ""
|
||||
exit 1
|
||||
else
|
||||
echo ""
|
||||
echo " All ${#PASSES[@]} suites passed."
|
||||
echo ""
|
||||
exit 0
|
||||
fi
|
||||
@@ -344,7 +344,7 @@ def create_base_app(
|
||||
response.headers["Access-Control-Allow-Origin"] = origin
|
||||
response.headers["Access-Control-Allow-Credentials"] = "true"
|
||||
response.headers["Access-Control-Allow-Headers"] = (
|
||||
"SX-Request, SX-Target, SX-Current-URL, SX-Components, SX-Components-Hash, SX-Css, "
|
||||
"SX-Request, SX-Target, SX-Current-URL, SX-Components, SX-Css, "
|
||||
"HX-Request, HX-Target, HX-Current-URL, HX-Trigger, "
|
||||
"Content-Type, X-CSRFToken"
|
||||
)
|
||||
|
||||
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
Binary file not shown.
2584
shared/static/scripts/sx-wasm.js
Normal file
2584
shared/static/scripts/sx-wasm.js
Normal file
File diff suppressed because one or more lines are too long
@@ -32,6 +32,7 @@ from .parser import (
|
||||
serialize,
|
||||
)
|
||||
from .types import EvalError
|
||||
from .ref.sx_ref import evaluate, make_env
|
||||
|
||||
from .primitives import (
|
||||
all_primitives,
|
||||
|
||||
@@ -53,9 +53,7 @@ from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
|
||||
_expand_components: contextvars.ContextVar[bool] = contextvars.ContextVar(
|
||||
"_expand_components", default=False
|
||||
)
|
||||
# sx_ref.py removed — stub so module loads. OCaml bridge handles macro expansion.
|
||||
def _expand_macro(*a, **kw):
|
||||
raise RuntimeError("sx_ref.py has been removed — use SX_USE_OCAML=1")
|
||||
from .ref.sx_ref import expand_macro as _expand_macro
|
||||
from .types import EvalError
|
||||
from .primitives import _PRIMITIVES
|
||||
from .primitives_io import IO_PRIMITIVES, RequestContext, execute_io
|
||||
@@ -423,39 +421,23 @@ async def _asf_define(expr, env, ctx):
|
||||
|
||||
|
||||
async def _asf_defcomp(expr, env, ctx):
|
||||
# Component definitions are handled by OCaml kernel at load time.
|
||||
# Python-side: just store a minimal Component in env for reference.
|
||||
from .types import Component
|
||||
name_sym = expr[1]
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym)
|
||||
env[name] = Component(name=name.lstrip("~"), params=[], has_children=False,
|
||||
body=expr[-1], closure={})
|
||||
return NIL
|
||||
from .ref.sx_ref import sf_defcomp
|
||||
return sf_defcomp(expr[1:], env)
|
||||
|
||||
|
||||
async def _asf_defstyle(expr, env, ctx):
|
||||
# Style definitions handled by OCaml kernel.
|
||||
return NIL
|
||||
from .ref.sx_ref import sf_defstyle
|
||||
return sf_defstyle(expr[1:], env)
|
||||
|
||||
|
||||
async def _asf_defmacro(expr, env, ctx):
|
||||
# Macro definitions handled by OCaml kernel.
|
||||
from .types import Macro
|
||||
name_sym = expr[1]
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym)
|
||||
params_form = expr[2] if len(expr) > 3 else []
|
||||
param_names = [p.name for p in params_form if isinstance(p, Symbol) and not p.name.startswith("&")]
|
||||
rest_param = None
|
||||
for i, p in enumerate(params_form):
|
||||
if isinstance(p, Symbol) and p.name == "&rest" and i + 1 < len(params_form):
|
||||
rest_param = params_form[i + 1].name if isinstance(params_form[i + 1], Symbol) else None
|
||||
env[name] = Macro(name=name, params=param_names, rest_param=rest_param, body=expr[-1])
|
||||
return NIL
|
||||
from .ref.sx_ref import sf_defmacro
|
||||
return sf_defmacro(expr[1:], env)
|
||||
|
||||
|
||||
async def _asf_defhandler(expr, env, ctx):
|
||||
# Handler definitions handled by OCaml kernel.
|
||||
return NIL
|
||||
from .ref.sx_ref import sf_defhandler
|
||||
return sf_defhandler(expr[1:], env)
|
||||
|
||||
|
||||
async def _asf_begin(expr, env, ctx):
|
||||
@@ -617,12 +599,9 @@ async def _asf_reset(expr, env, ctx):
|
||||
from .types import NIL
|
||||
_ASYNC_RESET_RESUME.append(value if value is not None else NIL)
|
||||
try:
|
||||
# Continuations are handled by OCaml kernel.
|
||||
# Python-side cont_fn should not be called in normal operation.
|
||||
raise RuntimeError(
|
||||
"Python-side continuation invocation not supported — "
|
||||
"use OCaml bridge for shift/reset"
|
||||
)
|
||||
# Sync re-evaluation; the async caller will trampoline
|
||||
from .ref.sx_ref import eval_expr as sync_eval, trampoline as _trampoline
|
||||
return _trampoline(sync_eval(body, env))
|
||||
finally:
|
||||
_ASYNC_RESET_RESUME.pop()
|
||||
k = Continuation(cont_fn)
|
||||
|
||||
@@ -14,7 +14,7 @@ from .types import Component, Island, Macro, Symbol
|
||||
|
||||
|
||||
def _use_ref() -> bool:
|
||||
return False # sx_ref.py removed — always use fallback
|
||||
return os.environ.get("SX_USE_REF") == "1"
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -152,11 +152,18 @@ def transitive_deps(name: str, env: dict[str, Any]) -> set[str]:
|
||||
Returns the set of all component names (with ~ prefix) that
|
||||
*name* can transitively render, NOT including *name* itself.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import transitive_deps as _ref_td
|
||||
return set(_ref_td(name, env))
|
||||
return _transitive_deps_fallback(name, env)
|
||||
|
||||
|
||||
def compute_all_deps(env: dict[str, Any]) -> None:
|
||||
"""Compute and cache deps for all Component entries in *env*."""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import compute_all_deps as _ref_cad
|
||||
_ref_cad(env)
|
||||
return
|
||||
_compute_all_deps_fallback(env)
|
||||
|
||||
|
||||
@@ -165,6 +172,9 @@ def scan_components_from_sx(source: str) -> set[str]:
|
||||
|
||||
Returns names with ~ prefix, e.g. {"~card", "~shared:layout/nav-link"}.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import scan_components_from_source as _ref_sc
|
||||
return set(_ref_sc(source))
|
||||
return _scan_components_from_sx_fallback(source)
|
||||
|
||||
|
||||
@@ -173,11 +183,18 @@ def components_needed(page_sx: str, env: dict[str, Any]) -> set[str]:
|
||||
|
||||
Returns names with ~ prefix.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import components_needed as _ref_cn
|
||||
return set(_ref_cn(page_sx, env))
|
||||
return _components_needed_fallback(page_sx, env)
|
||||
|
||||
|
||||
def compute_all_io_refs(env: dict[str, Any], io_names: set[str]) -> None:
|
||||
"""Compute and cache transitive IO refs for all Component entries in *env*."""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import compute_all_io_refs as _ref_cio
|
||||
_ref_cio(env, list(io_names))
|
||||
return
|
||||
_compute_all_io_refs_fallback(env, io_names)
|
||||
|
||||
|
||||
@@ -192,17 +209,9 @@ def page_render_plan(page_sx: str, env: dict[str, Any], io_names: set[str] | Non
|
||||
"""
|
||||
if io_names is None:
|
||||
io_names = get_all_io_names()
|
||||
# Use fallback implementation (sx_ref.py removed)
|
||||
needed = _components_needed_fallback(page_sx, env)
|
||||
server, client, io_deps = [], [], []
|
||||
for name in needed:
|
||||
comp = env.get(name)
|
||||
if comp and hasattr(comp, 'io_refs') and comp.io_refs:
|
||||
client.append(name)
|
||||
else:
|
||||
server.append(name)
|
||||
return {"components": {n: ("server" if n in server else "client") for n in needed},
|
||||
"server": server, "client": client, "io-deps": io_deps}
|
||||
from .ref.sx_ref import page_render_plan as _ref_prp
|
||||
plan = _ref_prp(page_sx, env, list(io_names))
|
||||
return plan
|
||||
|
||||
|
||||
def get_all_io_names() -> set[str]:
|
||||
|
||||
@@ -80,76 +80,30 @@ def clear_handlers(service: str | None = None) -> None:
|
||||
# Loading — parse .sx files and collect HandlerDef instances
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _parse_defhandler(expr: list) -> HandlerDef | None:
|
||||
"""Extract HandlerDef from a (defhandler name :path ... (&key ...) body) form."""
|
||||
from .types import Keyword
|
||||
if len(expr) < 3:
|
||||
return None
|
||||
name = expr[1].name if hasattr(expr[1], 'name') else str(expr[1])
|
||||
|
||||
# Parse keyword options and find params/body
|
||||
path = None
|
||||
method = "get"
|
||||
csrf = True
|
||||
returns = "element"
|
||||
params_list = None
|
||||
body = None
|
||||
|
||||
i = 2
|
||||
while i < len(expr):
|
||||
item = expr[i]
|
||||
if isinstance(item, Keyword) and i + 1 < len(expr):
|
||||
kn = item.name
|
||||
val = expr[i + 1]
|
||||
if kn == "path":
|
||||
path = val if isinstance(val, str) else str(val)
|
||||
elif kn == "method":
|
||||
method = val.name if hasattr(val, 'name') else str(val)
|
||||
elif kn == "csrf":
|
||||
csrf = val not in (False, "false")
|
||||
elif kn == "returns":
|
||||
returns = val if isinstance(val, str) else str(val)
|
||||
i += 2
|
||||
elif isinstance(item, list) and not params_list:
|
||||
# This is the params list (&key ...)
|
||||
params_list = item
|
||||
i += 1
|
||||
else:
|
||||
body = item
|
||||
i += 1
|
||||
|
||||
param_names = []
|
||||
if params_list:
|
||||
for p in params_list:
|
||||
if hasattr(p, 'name') and p.name not in ("&key", "&rest"):
|
||||
param_names.append(p.name)
|
||||
|
||||
return HandlerDef(
|
||||
name=name, params=param_names, body=body or [],
|
||||
path=path, method=method, csrf=csrf, returns=returns,
|
||||
)
|
||||
|
||||
|
||||
def load_handler_file(filepath: str, service_name: str) -> list[HandlerDef]:
|
||||
"""Parse an .sx file, evaluate it, and register any HandlerDef values."""
|
||||
from .parser import parse_all
|
||||
import os
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
# Parse defhandler forms from the AST to extract handler registration info
|
||||
# Seed env with component definitions so handlers can reference components
|
||||
env = dict(get_component_env())
|
||||
exprs = parse_all(source)
|
||||
handlers: list[HandlerDef] = []
|
||||
|
||||
for expr in exprs:
|
||||
if (isinstance(expr, list) and expr
|
||||
and hasattr(expr[0], 'name') and expr[0].name == "defhandler"):
|
||||
hd = _parse_defhandler(expr)
|
||||
if hd:
|
||||
register_handler(service_name, hd)
|
||||
handlers.append(hd)
|
||||
_eval(expr, env)
|
||||
|
||||
# Collect all HandlerDef values from the env
|
||||
for key, val in env.items():
|
||||
if isinstance(val, HandlerDef):
|
||||
register_handler(service_name, val)
|
||||
handlers.append(val)
|
||||
|
||||
return handlers
|
||||
|
||||
@@ -183,54 +137,36 @@ async def execute_handler(
|
||||
|
||||
1. Build env from component env + handler closure
|
||||
2. Bind handler params from args (typically request.args)
|
||||
3. Evaluate via OCaml kernel (or Python fallback)
|
||||
3. Evaluate via ``async_eval_to_sx`` (I/O inline, components serialized)
|
||||
4. Return ``SxExpr`` wire format
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .pages import get_page_helpers
|
||||
from .parser import serialize
|
||||
from .types import NIL, SxExpr
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_to_sx
|
||||
from .types import NIL
|
||||
|
||||
if args is None:
|
||||
args = {}
|
||||
|
||||
use_ocaml = os.environ.get("SX_USE_OCAML") == "1"
|
||||
# Build environment
|
||||
env = dict(get_component_env())
|
||||
env.update(get_page_helpers(service_name))
|
||||
env.update(handler_def.closure)
|
||||
|
||||
if use_ocaml:
|
||||
from .ocaml_bridge import get_bridge
|
||||
# Bind handler params from request args
|
||||
for param in handler_def.params:
|
||||
env[param] = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
|
||||
# Serialize handler body with bound params as a let expression.
|
||||
# Define constants and defcomps from the handler file are available
|
||||
# in the kernel's global env (loaded by _ensure_components).
|
||||
param_bindings = []
|
||||
for param in handler_def.params:
|
||||
val = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
param_bindings.append(f"({param} {serialize(val)})")
|
||||
# Get request context for I/O primitives
|
||||
ctx = _get_request_context()
|
||||
|
||||
body_sx = serialize(handler_def.body)
|
||||
if param_bindings:
|
||||
sx_text = f"(let ({' '.join(param_bindings)}) {body_sx})"
|
||||
else:
|
||||
sx_text = body_sx
|
||||
|
||||
bridge = await get_bridge()
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
result_sx = await bridge.aser(sx_text, ctx=ocaml_ctx)
|
||||
return SxExpr(result_sx or "")
|
||||
else:
|
||||
# Python fallback (async_eval)
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(get_page_helpers(service_name))
|
||||
env.update(handler_def.closure)
|
||||
|
||||
for param in handler_def.params:
|
||||
env[param] = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
|
||||
ctx = _get_request_context()
|
||||
return await async_eval_to_sx(handler_def.body, env, ctx)
|
||||
# Async eval → sx source — I/O primitives are awaited inline,
|
||||
# but component/tag calls serialize to sx wire format (not HTML).
|
||||
return await async_eval_to_sx(handler_def.body, env, ctx)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@@ -364,6 +364,10 @@ async def _render_to_sx_with_env(__name: str, extra_env: dict, **kwargs: Any) ->
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_slot_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
from .types import Symbol, Keyword, NIL as _NIL
|
||||
|
||||
# Build AST with extra_env entries as keyword args so _aser_component
|
||||
@@ -377,16 +381,6 @@ async def _render_to_sx_with_env(__name: str, extra_env: dict, **kwargs: Any) ->
|
||||
ast.append(Keyword(k.replace("_", "-")))
|
||||
ast.append(v if v is not None else _NIL)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
ocaml_ctx = {"_helper_service": _get_request_context().get("_helper_service", "")} if isinstance(_get_request_context(), dict) else {}
|
||||
return SxExpr(await bridge.aser_slot(sx_text, ctx=ocaml_ctx))
|
||||
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(extra_env)
|
||||
ctx = _get_request_context()
|
||||
@@ -405,21 +399,12 @@ async def _render_to_sx(__name: str, **kwargs: Any) -> str:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
ast = _build_component_ast(__name, **kwargs)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
# aser_slot (not aser) — layout wrappers contain re-parsed
|
||||
# content from earlier aser_slot calls. Regular aser fails on
|
||||
# symbols like `title` that were bound during the earlier expansion.
|
||||
return SxExpr(await bridge.aser_slot(sx_text))
|
||||
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
ctx = _get_request_context()
|
||||
return SxExpr(await async_eval_to_sx(ast, env, ctx))
|
||||
@@ -435,24 +420,15 @@ async def render_to_html(__name: str, **kwargs: Any) -> str:
|
||||
|
||||
Same as render_to_sx() but produces HTML output instead of SX wire
|
||||
format. Used by route renders that need HTML (full pages, fragments).
|
||||
|
||||
Routes through the OCaml bridge (render mode) which handles component
|
||||
parameter binding, scope primitives, and all evaluation.
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_render
|
||||
else:
|
||||
from .async_eval import async_render
|
||||
|
||||
ast = _build_component_ast(__name, **kwargs)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
return await bridge.render(sx_text)
|
||||
|
||||
# Fallback: Python async_eval (requires working evaluator)
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .async_eval import async_render
|
||||
env = dict(get_component_env())
|
||||
ctx = _get_request_context()
|
||||
return await async_render(ast, env, ctx)
|
||||
@@ -520,18 +496,8 @@ def components_for_request(source: str = "",
|
||||
elif extra_names:
|
||||
needed = extra_names
|
||||
|
||||
# Check hash first (new): if client hash matches current, skip all defs.
|
||||
# Fall back to legacy name list (SX-Components) for backward compat.
|
||||
comp_hash_header = request.headers.get("SX-Components-Hash", "")
|
||||
if comp_hash_header:
|
||||
from .jinja_bridge import components_for_page
|
||||
_, current_hash = components_for_page("", service=None)
|
||||
if comp_hash_header == current_hash:
|
||||
return "" # client has everything
|
||||
loaded = set() # hash mismatch — send all needed
|
||||
else:
|
||||
loaded_raw = request.headers.get("SX-Components", "")
|
||||
loaded = set(loaded_raw.split(",")) if loaded_raw else set()
|
||||
loaded_raw = request.headers.get("SX-Components", "")
|
||||
loaded = set(loaded_raw.split(",")) if loaded_raw else set()
|
||||
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
@@ -801,162 +767,6 @@ def _sx_literal(v: object) -> str:
|
||||
|
||||
|
||||
|
||||
_cached_shell_static: dict[str, Any] | None = None
|
||||
_cached_shell_comp_hash: str | None = None
|
||||
|
||||
|
||||
def invalidate_shell_cache():
|
||||
"""Call on component hot-reload to recompute shell statics."""
|
||||
global _cached_shell_static, _cached_shell_comp_hash
|
||||
_cached_shell_static = None
|
||||
_cached_shell_comp_hash = None
|
||||
|
||||
|
||||
def _get_shell_static() -> dict[str, Any]:
|
||||
"""Compute and cache all shell kwargs that don't change per-request.
|
||||
|
||||
This is the expensive part: component dep scanning, serialization,
|
||||
CSS class scanning, rule lookup, pages registry. All stable until
|
||||
components are hot-reloaded.
|
||||
"""
|
||||
global _cached_shell_static, _cached_shell_comp_hash
|
||||
from .jinja_bridge import components_for_page, css_classes_for_page, _component_env_hash
|
||||
from .css_registry import lookup_rules, get_preamble, registry_loaded, store_css_hash
|
||||
|
||||
current_hash = _component_env_hash()
|
||||
if _cached_shell_static is not None and _cached_shell_comp_hash == current_hash:
|
||||
return _cached_shell_static
|
||||
|
||||
import time
|
||||
t0 = time.monotonic()
|
||||
|
||||
from quart import current_app as _ca
|
||||
from .jinja_bridge import client_components_tag, _COMPONENT_ENV, _CLIENT_LIBRARY_SOURCES
|
||||
from .jinja_bridge import _component_env_hash
|
||||
from .parser import serialize as _serialize
|
||||
|
||||
# Send ALL component definitions — the hash is stable per env so the
|
||||
# browser caches them across all pages. Server-side expansion handles
|
||||
# the per-page subset; the client needs the full set for client-side
|
||||
# routing to any page.
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
from .types import Island, Component, Macro
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children: ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children: ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param: ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
|
||||
component_defs = "\n".join(all_parts)
|
||||
component_hash = _component_env_hash()
|
||||
|
||||
# CSS: scan ALL components (not per-page) for the static cache
|
||||
sx_css = ""
|
||||
sx_css_classes = ""
|
||||
if registry_loaded():
|
||||
classes: set[str] = set()
|
||||
from .types import Island as _I, Component as _C
|
||||
for val in _COMPONENT_ENV.values():
|
||||
if isinstance(val, (_I, _C)) and val.css_classes:
|
||||
classes.update(val.css_classes)
|
||||
classes.update(["bg-stone-50", "text-stone-900"])
|
||||
rules = lookup_rules(classes)
|
||||
sx_css = get_preamble() + rules
|
||||
sx_css_classes = store_css_hash(classes)
|
||||
|
||||
pages_sx = _build_pages_sx(_ca.name)
|
||||
|
||||
_shell_cfg = _ca.config.get("SX_SHELL", {})
|
||||
|
||||
static = dict(
|
||||
component_hash=component_hash,
|
||||
component_defs=component_defs,
|
||||
pages_sx=pages_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_hash=_script_hash("sx-browser.js"),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
asset_url=_ca.config.get("ASSET_URL", "/static"),
|
||||
head_scripts=_shell_cfg.get("head_scripts"),
|
||||
inline_css=_shell_cfg.get("inline_css"),
|
||||
inline_head_js=_shell_cfg.get("inline_head_js"),
|
||||
init_sx=_shell_cfg.get("init_sx"),
|
||||
body_scripts=_shell_cfg.get("body_scripts"),
|
||||
)
|
||||
|
||||
t1 = time.monotonic()
|
||||
import logging
|
||||
logging.getLogger("sx.pages").info(
|
||||
"[shell-static] computed in %.3fs, comp_defs=%d css=%d pages=%d",
|
||||
t1 - t0, len(component_defs), len(sx_css), len(pages_sx))
|
||||
|
||||
_cached_shell_static = static
|
||||
_cached_shell_comp_hash = current_hash
|
||||
return static
|
||||
|
||||
|
||||
async def _build_shell_kwargs(ctx: dict, page_sx: str, *,
|
||||
meta_html: str = "",
|
||||
head_scripts: list[str] | None = None,
|
||||
inline_css: str | None = None,
|
||||
inline_head_js: str | None = None,
|
||||
init_sx: str | None = None,
|
||||
body_scripts: list[str] | None = None) -> dict[str, Any]:
|
||||
"""Compute all shell kwargs for sx-page-shell.
|
||||
|
||||
Static parts (components, CSS, pages) are cached. Only per-request
|
||||
values (title, csrf) are computed fresh.
|
||||
"""
|
||||
static = _get_shell_static()
|
||||
|
||||
asset_url = get_asset_url(ctx) or static["asset_url"]
|
||||
title = ctx.get("base_title", "Rose Ash")
|
||||
csrf = _get_csrf_token()
|
||||
|
||||
kwargs: dict[str, Any] = dict(static)
|
||||
kwargs.update(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
meta_html=meta_html,
|
||||
csrf=_html_escape(csrf),
|
||||
)
|
||||
|
||||
# Per-page CSS: scan THIS page's classes and add to cached CSS
|
||||
from .css_registry import scan_classes_from_sx, lookup_rules, registry_loaded
|
||||
if registry_loaded() and page_sx:
|
||||
page_classes = scan_classes_from_sx(page_sx)
|
||||
if page_classes:
|
||||
extra_rules = lookup_rules(page_classes)
|
||||
if extra_rules:
|
||||
kwargs["sx_css"] = static["sx_css"] + extra_rules
|
||||
|
||||
# Cookie-based component caching
|
||||
client_hash = _get_sx_comp_cookie()
|
||||
if not _is_dev_mode() and client_hash and client_hash == static["component_hash"]:
|
||||
kwargs["component_defs"] = ""
|
||||
|
||||
# Per-call overrides
|
||||
if head_scripts is not None:
|
||||
kwargs["head_scripts"] = head_scripts
|
||||
if inline_css is not None:
|
||||
kwargs["inline_css"] = inline_css
|
||||
if inline_head_js is not None:
|
||||
kwargs["inline_head_js"] = inline_head_js
|
||||
if init_sx is not None:
|
||||
kwargs["init_sx"] = init_sx
|
||||
if body_scripts is not None:
|
||||
kwargs["body_scripts"] = body_scripts
|
||||
return kwargs
|
||||
|
||||
|
||||
async def sx_page(ctx: dict, page_sx: str, *,
|
||||
meta_html: str = "",
|
||||
head_scripts: list[str] | None = None,
|
||||
@@ -964,18 +774,113 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
inline_head_js: str | None = None,
|
||||
init_sx: str | None = None,
|
||||
body_scripts: list[str] | None = None) -> str:
|
||||
"""Return a minimal HTML shell that boots the page from sx source."""
|
||||
# Ensure page_sx is a plain str
|
||||
"""Return a minimal HTML shell that boots the page from sx source.
|
||||
|
||||
The browser loads component definitions and page sx, then sx.js
|
||||
renders everything client-side. CSS rules are scanned from the sx
|
||||
source and component defs, then injected as a <style> block.
|
||||
|
||||
The shell is rendered from the ~shared:shell/sx-page-shell SX component
|
||||
(shared/sx/templates/shell.sx).
|
||||
"""
|
||||
from .jinja_bridge import components_for_page, css_classes_for_page
|
||||
from .css_registry import lookup_rules, get_preamble, registry_loaded, store_css_hash
|
||||
|
||||
# Per-page component bundle: this page's deps + all :data page deps
|
||||
from quart import current_app as _ca
|
||||
component_defs, component_hash = components_for_page(page_sx, service=_ca.name)
|
||||
|
||||
# Check if client already has this version cached (via cookie)
|
||||
# In dev mode, always send full source so edits are visible immediately
|
||||
client_hash = _get_sx_comp_cookie()
|
||||
if not _is_dev_mode() and client_hash and client_hash == component_hash:
|
||||
# Client has current components cached — send empty source
|
||||
component_defs = ""
|
||||
|
||||
# Scan for CSS classes — only from components this page uses + page source
|
||||
sx_css = ""
|
||||
sx_css_classes = ""
|
||||
sx_css_hash = ""
|
||||
if registry_loaded():
|
||||
classes = css_classes_for_page(page_sx, service=_ca.name)
|
||||
# Always include body classes
|
||||
classes.update(["bg-stone-50", "text-stone-900"])
|
||||
rules = lookup_rules(classes)
|
||||
sx_css = get_preamble() + rules
|
||||
sx_css_hash = store_css_hash(classes)
|
||||
sx_css_classes = sx_css_hash
|
||||
|
||||
asset_url = get_asset_url(ctx)
|
||||
title = ctx.get("base_title", "Rose Ash")
|
||||
csrf = _get_csrf_token()
|
||||
|
||||
# Dev mode: pretty-print page sx for readable View Source
|
||||
if _is_dev_mode() and page_sx and page_sx.startswith("("):
|
||||
from .parser import parse as _parse, serialize as _serialize
|
||||
try:
|
||||
page_sx = _serialize(_parse(page_sx), pretty=True)
|
||||
except Exception as e:
|
||||
import logging
|
||||
logging.getLogger("sx").warning("Pretty-print page_sx failed: %s", e)
|
||||
|
||||
# Page registry for client-side routing
|
||||
import logging
|
||||
_plog = logging.getLogger("sx.pages")
|
||||
from quart import current_app
|
||||
pages_sx = _build_pages_sx(current_app.name)
|
||||
_plog.debug("sx_page: pages_sx %d bytes for service %s", len(pages_sx), current_app.name)
|
||||
if pages_sx:
|
||||
_plog.debug("sx_page: pages_sx first 200 chars: %s", pages_sx[:200])
|
||||
|
||||
# Ensure page_sx is a plain str, not SxExpr — _build_component_ast
|
||||
# parses SxExpr back into AST, which _arender then evaluates as HTML
|
||||
# instead of passing through as raw content for the script tag.
|
||||
if isinstance(page_sx, SxExpr):
|
||||
page_sx = "".join([page_sx])
|
||||
|
||||
kwargs = await _build_shell_kwargs(
|
||||
ctx, page_sx, meta_html=meta_html,
|
||||
head_scripts=head_scripts, inline_css=inline_css,
|
||||
inline_head_js=inline_head_js, init_sx=init_sx,
|
||||
body_scripts=body_scripts)
|
||||
kwargs["page_sx"] = page_sx
|
||||
return await render_to_html("shared:shell/sx-page-shell", **kwargs)
|
||||
# Per-app shell config: check explicit args, then app config, then defaults
|
||||
from quart import current_app as _app
|
||||
_shell_cfg = _app.config.get("SX_SHELL", {})
|
||||
if head_scripts is None:
|
||||
head_scripts = _shell_cfg.get("head_scripts")
|
||||
if inline_css is None:
|
||||
inline_css = _shell_cfg.get("inline_css")
|
||||
if inline_head_js is None:
|
||||
inline_head_js = _shell_cfg.get("inline_head_js")
|
||||
if init_sx is None:
|
||||
init_sx = _shell_cfg.get("init_sx")
|
||||
if body_scripts is None:
|
||||
body_scripts = _shell_cfg.get("body_scripts")
|
||||
|
||||
import os as _os
|
||||
_sx_js_file = "sx-wasm.js" if _os.environ.get("SX_USE_WASM") == "1" else "sx-browser.js"
|
||||
|
||||
shell_kwargs: dict[str, Any] = dict(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
meta_html=meta_html,
|
||||
csrf=_html_escape(csrf),
|
||||
component_hash=component_hash,
|
||||
component_defs=component_defs,
|
||||
pages_sx=pages_sx,
|
||||
page_sx=page_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_file=_sx_js_file,
|
||||
sx_js_hash=_script_hash(_sx_js_file),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
)
|
||||
if head_scripts is not None:
|
||||
shell_kwargs["head_scripts"] = head_scripts
|
||||
if inline_css is not None:
|
||||
shell_kwargs["inline_css"] = inline_css
|
||||
if inline_head_js is not None:
|
||||
shell_kwargs["inline_head_js"] = inline_head_js
|
||||
if init_sx is not None:
|
||||
shell_kwargs["init_sx"] = init_sx
|
||||
if body_scripts is not None:
|
||||
shell_kwargs["body_scripts"] = body_scripts
|
||||
return await render_to_html("shared:shell/sx-page-shell", **shell_kwargs)
|
||||
|
||||
|
||||
_SX_STREAMING_RESOLVE = """\
|
||||
|
||||
@@ -28,163 +28,15 @@ import contextvars
|
||||
from typing import Any
|
||||
|
||||
from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
|
||||
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, call_component as _raw_call_component, expand_macro as _expand_macro, trampoline as _trampoline
|
||||
|
||||
def _eval(expr, env):
|
||||
"""Minimal Python evaluator for sync html.py rendering.
|
||||
"""Evaluate and unwrap thunks — all html.py _eval calls are non-tail."""
|
||||
return _trampoline(_raw_eval(expr, env))
|
||||
|
||||
Handles: literals, symbols, keywords, dicts, special forms (if, when,
|
||||
cond, let, begin/do, and, or, str, not, list), lambda calls, and
|
||||
primitive function calls. Enough for the sync sx() Jinja function.
|
||||
"""
|
||||
from .primitives import _PRIMITIVES
|
||||
|
||||
# Literals
|
||||
if isinstance(expr, (int, float, str, bool)):
|
||||
return expr
|
||||
if expr is None or expr is NIL:
|
||||
return NIL
|
||||
|
||||
# Symbol lookup
|
||||
if isinstance(expr, Symbol):
|
||||
name = expr.name
|
||||
if name in env:
|
||||
return env[name]
|
||||
if name in _PRIMITIVES:
|
||||
return _PRIMITIVES[name]
|
||||
if name == "true":
|
||||
return True
|
||||
if name == "false":
|
||||
return False
|
||||
if name == "nil":
|
||||
return NIL
|
||||
from .types import EvalError
|
||||
raise EvalError(f"Undefined symbol: {name}")
|
||||
|
||||
# Keyword
|
||||
if isinstance(expr, Keyword):
|
||||
return expr.name
|
||||
|
||||
# Dict
|
||||
if isinstance(expr, dict):
|
||||
return {k: _eval(v, env) for k, v in expr.items()}
|
||||
|
||||
# List — dispatch
|
||||
if not isinstance(expr, list):
|
||||
return expr
|
||||
if not expr:
|
||||
return []
|
||||
|
||||
head = expr[0]
|
||||
if isinstance(head, Symbol):
|
||||
name = head.name
|
||||
|
||||
# Special forms
|
||||
if name == "if":
|
||||
cond = _eval(expr[1], env)
|
||||
if cond and cond is not NIL:
|
||||
return _eval(expr[2], env)
|
||||
return _eval(expr[3], env) if len(expr) > 3 else NIL
|
||||
|
||||
if name == "when":
|
||||
cond = _eval(expr[1], env)
|
||||
if cond and cond is not NIL:
|
||||
result = NIL
|
||||
for body in expr[2:]:
|
||||
result = _eval(body, env)
|
||||
return result
|
||||
return NIL
|
||||
|
||||
if name == "let":
|
||||
bindings = expr[1]
|
||||
local = dict(env)
|
||||
if isinstance(bindings, list):
|
||||
if bindings and isinstance(bindings[0], list):
|
||||
for b in bindings:
|
||||
vname = b[0].name if isinstance(b[0], Symbol) else b[0]
|
||||
local[vname] = _eval(b[1], local)
|
||||
elif len(bindings) % 2 == 0:
|
||||
for i in range(0, len(bindings), 2):
|
||||
vname = bindings[i].name if isinstance(bindings[i], Symbol) else bindings[i]
|
||||
local[vname] = _eval(bindings[i + 1], local)
|
||||
result = NIL
|
||||
for body in expr[2:]:
|
||||
result = _eval(body, local)
|
||||
return result
|
||||
|
||||
if name in ("begin", "do"):
|
||||
result = NIL
|
||||
for body in expr[1:]:
|
||||
result = _eval(body, env)
|
||||
return result
|
||||
|
||||
if name == "and":
|
||||
result = True
|
||||
for arg in expr[1:]:
|
||||
result = _eval(arg, env)
|
||||
if not result or result is NIL:
|
||||
return result
|
||||
return result
|
||||
|
||||
if name == "or":
|
||||
for arg in expr[1:]:
|
||||
result = _eval(arg, env)
|
||||
if result and result is not NIL:
|
||||
return result
|
||||
return NIL
|
||||
|
||||
if name == "not":
|
||||
val = _eval(expr[1], env)
|
||||
return val is NIL or val is False or val is None
|
||||
|
||||
if name == "lambda" or name == "fn":
|
||||
params_form = expr[1]
|
||||
param_names = [p.name if isinstance(p, Symbol) else str(p) for p in params_form]
|
||||
return Lambda(params=param_names, body=expr[2], closure=dict(env))
|
||||
|
||||
if name == "define":
|
||||
var_name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
env[var_name] = _eval(expr[2], env)
|
||||
return NIL
|
||||
|
||||
if name == "quote":
|
||||
return expr[1]
|
||||
|
||||
if name == "str":
|
||||
parts = []
|
||||
for arg in expr[1:]:
|
||||
val = _eval(arg, env)
|
||||
if val is NIL or val is None:
|
||||
parts.append("")
|
||||
else:
|
||||
parts.append(str(val))
|
||||
return "".join(parts)
|
||||
|
||||
if name == "list":
|
||||
return [_eval(arg, env) for arg in expr[1:]]
|
||||
|
||||
# Primitive or function call
|
||||
fn = _eval(head, env)
|
||||
else:
|
||||
fn = _eval(head, env)
|
||||
|
||||
# Evaluate args
|
||||
args = [_eval(a, env) for a in expr[1:]]
|
||||
|
||||
# Call
|
||||
if callable(fn):
|
||||
return fn(*args)
|
||||
if isinstance(fn, Lambda):
|
||||
local = dict(fn.closure)
|
||||
local.update(env)
|
||||
for p, v in zip(fn.params, args):
|
||||
local[p] = v
|
||||
return _eval(fn.body, local)
|
||||
return NIL
|
||||
|
||||
|
||||
def _expand_macro(*a, **kw):
|
||||
raise RuntimeError("Macro expansion requires OCaml bridge")
|
||||
def _call_component(comp, raw_args, env):
|
||||
"""Call component and unwrap thunks — non-tail in html.py."""
|
||||
return _trampoline(_raw_call_component(comp, raw_args, env))
|
||||
|
||||
# ContextVar for collecting CSS class names during render.
|
||||
# Set to a set[str] to collect; None to skip.
|
||||
|
||||
@@ -30,7 +30,17 @@ from typing import Any
|
||||
|
||||
from .types import NIL, Component, Island, Keyword, Lambda, Macro, Symbol
|
||||
from .parser import parse
|
||||
from .html import render as html_render, _render_component
|
||||
import os as _os
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
# OCaml kernel bridge — render via persistent subprocess.
|
||||
# html_render and _render_component are set up lazily since the bridge
|
||||
# requires an async event loop. The sync sx() function falls back to
|
||||
# the ref renderer; async callers use ocaml_bridge directly.
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
elif _os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
else:
|
||||
from .html import render as html_render, _render_component
|
||||
|
||||
_logger = logging.getLogger("sx.bridge")
|
||||
|
||||
@@ -331,9 +341,6 @@ def reload_if_changed() -> None:
|
||||
_COMPONENT_ENV.clear()
|
||||
_CLIENT_LIBRARY_SOURCES.clear()
|
||||
_dirs_from_cache.clear()
|
||||
invalidate_component_hash()
|
||||
from .helpers import invalidate_shell_cache
|
||||
invalidate_shell_cache()
|
||||
# Reload SX libraries first (e.g. z3.sx) so reader macros resolve
|
||||
for cb in _reload_callbacks:
|
||||
cb()
|
||||
@@ -352,8 +359,6 @@ def reload_if_changed() -> None:
|
||||
from .ocaml_bridge import _bridge
|
||||
if _bridge is not None:
|
||||
_bridge._components_loaded = False
|
||||
_bridge._shell_statics_injected = False
|
||||
_bridge._helpers_injected = False
|
||||
|
||||
# Recompute render plans for all services that have pages
|
||||
from .pages import _PAGE_REGISTRY, compute_page_render_plans
|
||||
@@ -396,40 +401,6 @@ def load_handler_dir(directory: str, service_name: str) -> None:
|
||||
_load(directory, service_name)
|
||||
|
||||
|
||||
def _parse_defcomp_params(param_form: list) -> tuple[list[str], bool]:
|
||||
"""Extract keyword param names and has_children from a defcomp param list.
|
||||
|
||||
Handles: (&key p1 p2 &rest children), (&key (p1 :as type) &rest children),
|
||||
(p1 p2), () etc.
|
||||
|
||||
Returns (param_names, has_children).
|
||||
"""
|
||||
if not isinstance(param_form, list):
|
||||
return [], False
|
||||
|
||||
params: list[str] = []
|
||||
has_children = False
|
||||
in_key = False
|
||||
i = 0
|
||||
while i < len(param_form):
|
||||
item = param_form[i]
|
||||
if isinstance(item, Symbol):
|
||||
sname = item.name
|
||||
if sname == "&key":
|
||||
in_key = True
|
||||
elif sname == "&rest":
|
||||
has_children = True
|
||||
i += 1 # skip the rest-param name (e.g. 'children')
|
||||
else:
|
||||
params.append(sname)
|
||||
elif isinstance(item, list):
|
||||
# Typed param: (name :as type)
|
||||
if item and isinstance(item[0], Symbol):
|
||||
params.append(item[0].name)
|
||||
i += 1
|
||||
return params, has_children
|
||||
|
||||
|
||||
def register_components(sx_source: str, *, _defer_postprocess: bool = False) -> None:
|
||||
"""Parse and evaluate s-expression component definitions into the
|
||||
shared environment.
|
||||
@@ -437,30 +408,17 @@ def register_components(sx_source: str, *, _defer_postprocess: bool = False) ->
|
||||
When *_defer_postprocess* is True, skip deps/io_refs/hash computation.
|
||||
Call ``finalize_components()`` once after all files are loaded.
|
||||
"""
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .parser import parse_all
|
||||
from .css_registry import scan_classes_from_sx
|
||||
|
||||
# Snapshot existing component names before eval
|
||||
existing = set(_COMPONENT_ENV.keys())
|
||||
|
||||
# Evaluate definitions — OCaml kernel handles everything.
|
||||
# Python-side component registry is populated with parsed params for CSS/deps.
|
||||
exprs = parse_all(sx_source)
|
||||
for expr in exprs:
|
||||
if (isinstance(expr, list) and expr and isinstance(expr[0], Symbol)
|
||||
and expr[0].name in ("defcomp", "defisland", "defmacro",
|
||||
"define", "defstyle", "deftype",
|
||||
"defeffect", "defrelation", "defhandler")):
|
||||
name_sym = expr[1] if len(expr) > 1 else None
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym) if name_sym else None
|
||||
if name and expr[0].name in ("defcomp", "defisland"):
|
||||
params, has_children = _parse_defcomp_params(expr[2] if len(expr) > 3 else [])
|
||||
cls = Island if expr[0].name == "defisland" else Component
|
||||
_COMPONENT_ENV[name] = cls(
|
||||
name=name.lstrip("~"),
|
||||
params=params, has_children=has_children,
|
||||
body=expr[-1], closure={},
|
||||
)
|
||||
_eval(expr, _COMPONENT_ENV)
|
||||
|
||||
# Pre-scan CSS classes for newly registered components.
|
||||
all_classes: set[str] | None = None
|
||||
@@ -629,23 +587,25 @@ def client_components_tag(*names: str) -> str:
|
||||
|
||||
|
||||
def components_for_page(page_sx: str, service: str | None = None) -> tuple[str, str]:
|
||||
"""Return (component_defs_source, stable_hash) for a page.
|
||||
"""Return (component_defs_source, page_hash) for a page.
|
||||
|
||||
Sends per-page component subsets for bandwidth, but the hash is
|
||||
computed from the FULL component env — stable across all pages.
|
||||
Browser caches once on first page load, subsequent navigations
|
||||
hit the cache (same hash) without re-downloading.
|
||||
Scans *page_sx* for component references, computes the transitive
|
||||
closure, and returns only the definitions needed for this page.
|
||||
|
||||
Components go to the client for: hydration, client-side routing,
|
||||
data binding, and future CID-based caching.
|
||||
When *service* is given, also includes deps for all :data pages
|
||||
in that service so the client can render them without a server
|
||||
roundtrip on navigation.
|
||||
|
||||
The hash is computed from the page-specific bundle for caching.
|
||||
"""
|
||||
from .deps import components_needed
|
||||
from .parser import serialize
|
||||
|
||||
needed = components_needed(page_sx, _COMPONENT_ENV)
|
||||
|
||||
# Include deps for all :data pages so the client can render them
|
||||
# during client-side navigation.
|
||||
# Include deps for all :data pages so the client can render them.
|
||||
# Pages with IO deps use the async render path (Phase 5) — the IO
|
||||
# primitives are proxied via /sx/io/<name>.
|
||||
if service:
|
||||
from .pages import get_all_pages
|
||||
for page_def in get_all_pages(service).values():
|
||||
@@ -656,6 +616,7 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
if not needed:
|
||||
return "", ""
|
||||
|
||||
# Also include macros — they're needed for client-side expansion
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
if isinstance(val, Island):
|
||||
@@ -668,6 +629,10 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
parts.append(f"(defisland ~{val.name} {params_sx} {body_sx})")
|
||||
elif isinstance(val, Component):
|
||||
if f"~{val.name}" in needed or key in needed:
|
||||
# Skip server-affinity components — they're expanded server-side
|
||||
# and the client doesn't have the define values they depend on.
|
||||
if val.render_target == "server":
|
||||
continue
|
||||
param_strs = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
param_strs.extend(["&rest", "children"])
|
||||
@@ -675,7 +640,8 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
body_sx = serialize(val.body, pretty=True)
|
||||
parts.append(f"(defcomp ~{val.name} {params_sx} {body_sx})")
|
||||
elif isinstance(val, Macro):
|
||||
# Include all macros — small and often shared across pages
|
||||
# Include macros that are referenced in needed components' bodies
|
||||
# For now, include all macros (they're small and often shared)
|
||||
param_strs = list(val.params)
|
||||
if val.rest_param:
|
||||
param_strs.extend(["&rest", val.rest_param])
|
||||
@@ -689,39 +655,10 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
# Prepend client library sources (define forms) before component defs
|
||||
all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
|
||||
source = "\n".join(all_parts)
|
||||
|
||||
# Hash from FULL component env — stable across all pages.
|
||||
# Browser caches by this hash; same hash = cache hit on navigation.
|
||||
digest = _component_env_hash()
|
||||
digest = hashlib.sha256(source.encode()).hexdigest()[:12]
|
||||
return source, digest
|
||||
|
||||
|
||||
# Cached full-env hash — invalidated when components are reloaded.
|
||||
_env_hash_cache: str | None = None
|
||||
|
||||
|
||||
def _component_env_hash() -> str:
|
||||
"""Compute a stable hash from all loaded component names + bodies."""
|
||||
global _env_hash_cache
|
||||
if _env_hash_cache is not None:
|
||||
return _env_hash_cache
|
||||
from .parser import serialize
|
||||
h = hashlib.sha256()
|
||||
for key in sorted(_COMPONENT_ENV.keys()):
|
||||
val = _COMPONENT_ENV[key]
|
||||
if isinstance(val, (Island, Component, Macro)):
|
||||
h.update(key.encode())
|
||||
h.update(serialize(val.body).encode())
|
||||
_env_hash_cache = h.hexdigest()[:12]
|
||||
return _env_hash_cache
|
||||
|
||||
|
||||
def invalidate_component_hash():
|
||||
"""Call when components are reloaded (hot-reload, file change)."""
|
||||
global _env_hash_cache
|
||||
_env_hash_cache = None
|
||||
|
||||
|
||||
def css_classes_for_page(page_sx: str, service: str | None = None) -> set[str]:
|
||||
"""Return CSS classes needed for a page's component bundle + page source.
|
||||
|
||||
|
||||
@@ -41,12 +41,8 @@ class OcamlBridge:
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: asyncio.subprocess.Process | None = None
|
||||
self._lock = asyncio.Lock()
|
||||
self._in_io_handler = False # re-entrancy guard
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
self._helpers_injected = False
|
||||
self._io_cache: dict[tuple, Any] = {} # (name, args...) → cached result
|
||||
self._epoch: int = 0 # request epoch — monotonically increasing
|
||||
|
||||
async def start(self) -> None:
|
||||
"""Launch the OCaml subprocess and wait for (ready)."""
|
||||
@@ -61,13 +57,11 @@ class OcamlBridge:
|
||||
)
|
||||
|
||||
_logger.info("Starting OCaml SX kernel: %s", bin_path)
|
||||
import sys
|
||||
self._proc = await asyncio.create_subprocess_exec(
|
||||
bin_path,
|
||||
stdin=asyncio.subprocess.PIPE,
|
||||
stdout=asyncio.subprocess.PIPE,
|
||||
stderr=sys.stderr, # kernel timing/debug to container logs
|
||||
limit=10 * 1024 * 1024, # 10MB readline buffer for large spec data
|
||||
stderr=asyncio.subprocess.PIPE,
|
||||
)
|
||||
|
||||
# Wait for (ready)
|
||||
@@ -78,7 +72,7 @@ class OcamlBridge:
|
||||
self._started = True
|
||||
|
||||
# Verify engine identity
|
||||
await self._send_command("(ping)")
|
||||
self._send("(ping)")
|
||||
kind, engine = await self._read_response()
|
||||
engine_name = engine if kind == "ok" else "unknown"
|
||||
_logger.info("OCaml SX kernel ready (pid=%d, engine=%s)", self._proc.pid, engine_name)
|
||||
@@ -96,50 +90,39 @@ class OcamlBridge:
|
||||
self._proc = None
|
||||
self._started = False
|
||||
|
||||
async def _restart(self) -> None:
|
||||
"""Kill and restart the OCaml subprocess to recover from pipe desync."""
|
||||
_logger.warning("Restarting OCaml SX kernel (pipe recovery)")
|
||||
if self._proc and self._proc.returncode is None:
|
||||
self._proc.kill()
|
||||
await self._proc.wait()
|
||||
self._proc = None
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
self._helpers_injected = False
|
||||
await self.start()
|
||||
|
||||
async def ping(self) -> str:
|
||||
"""Health check — returns engine name (e.g. 'ocaml-cek')."""
|
||||
async with self._lock:
|
||||
await self._send_command("(ping)")
|
||||
self._send("(ping)")
|
||||
kind, value = await self._read_response()
|
||||
return value or "" if kind == "ok" else ""
|
||||
|
||||
async def load(self, path: str) -> int:
|
||||
"""Load an .sx file for side effects (defcomp, define, defmacro)."""
|
||||
async with self._lock:
|
||||
await self._send_command(f'(load "{_escape(path)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
self._send(f'(load "{_escape(path)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load {path}: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def load_source(self, source: str) -> int:
|
||||
"""Evaluate SX source for side effects."""
|
||||
async with self._lock:
|
||||
await self._send_command(f'(load-source "{_escape(source)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
self._send(f'(load-source "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load-source: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def eval(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Evaluate SX expression, return serialized result.
|
||||
|
||||
Supports io-requests (helper calls, query, action, etc.) via the
|
||||
coroutine bridge, just like render().
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async def eval(self, source: str) -> str:
|
||||
"""Evaluate SX expression, return serialized result."""
|
||||
async with self._lock:
|
||||
await self._send_command('(eval-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
self._send(f'(eval "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"eval: {value}")
|
||||
return value or ""
|
||||
|
||||
async def render(
|
||||
self,
|
||||
@@ -149,332 +132,49 @@ class OcamlBridge:
|
||||
"""Render SX to HTML, handling io-requests via Python async IO."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
await self._send_command(f'(render "{_escape(source)}")')
|
||||
self._send(f'(render "{_escape(source)}")')
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def aser(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Evaluate SX and return SX wire format, handling io-requests."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
await self._send_command('(aser-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def aser_slot(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Like aser() but expands ALL components server-side.
|
||||
|
||||
Equivalent to Python's async_eval_slot_to_sx — used for layout
|
||||
slots where component bodies need server-side IO evaluation.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
# Inject helpers inside the lock to avoid pipe desync —
|
||||
# a separate lock acquisition could let another coroutine
|
||||
# interleave commands between injection and aser-slot.
|
||||
await self._inject_helpers_locked()
|
||||
await self._send_command('(aser-slot-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
_shell_statics_injected: bool = False
|
||||
|
||||
async def _inject_shell_statics_locked(self) -> None:
|
||||
"""Inject cached shell static data into kernel. MUST hold lock."""
|
||||
if self._shell_statics_injected:
|
||||
return
|
||||
from .helpers import _get_shell_static
|
||||
try:
|
||||
static = _get_shell_static()
|
||||
except Exception:
|
||||
return # not ready yet (no app context)
|
||||
# Only inject small, safe values as kernel variables.
|
||||
# Large/complex blobs use placeholder tokens at render time.
|
||||
for key in ("component_hash", "sx_css_classes", "asset_url",
|
||||
"sx_js_hash", "body_js_hash"):
|
||||
val = static.get(key) or ""
|
||||
var = f"__shell-{key.replace('_', '-')}"
|
||||
defn = f'(define {var} "{_escape(str(val))}")'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(defn)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("Shell static inject failed for %s: %s", key, e)
|
||||
# List/nil values
|
||||
for key in ("head_scripts", "body_scripts"):
|
||||
val = static.get(key)
|
||||
var = f"__shell-{key.replace('_', '-')}"
|
||||
if val is None:
|
||||
defn = f'(define {var} nil)'
|
||||
elif isinstance(val, list):
|
||||
items = " ".join(f'"{_escape(str(v))}"' for v in val)
|
||||
defn = f'(define {var} (list {items}))'
|
||||
else:
|
||||
defn = f'(define {var} "{_escape(str(val))}")'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(defn)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("Shell static inject failed for %s: %s", key, e)
|
||||
self._shell_statics_injected = True
|
||||
_logger.info("Injected shell statics into OCaml kernel")
|
||||
|
||||
async def _inject_request_cookies_locked(self) -> None:
|
||||
"""Send current request cookies to kernel for get-cookie primitive."""
|
||||
try:
|
||||
from quart import request
|
||||
cookies = request.cookies
|
||||
except Exception:
|
||||
return # no request context (CLI mode, tests)
|
||||
if not cookies:
|
||||
return
|
||||
# Build SX dict: {:name1 "val1" :name2 "val2"}
|
||||
# Cookie values may be URL-encoded (client set-cookie uses
|
||||
# encodeURIComponent) — decode before sending to kernel.
|
||||
from urllib.parse import unquote
|
||||
pairs = []
|
||||
for k, v in cookies.items():
|
||||
pairs.append(f':{k} "{_escape(unquote(str(v)))}"')
|
||||
if pairs:
|
||||
cmd = f'(set-request-cookies {{{" ".join(pairs)}}})'
|
||||
try:
|
||||
await self._send_command(cmd)
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.debug("Cookie inject failed: %s", e)
|
||||
|
||||
async def sx_page_full(
|
||||
self,
|
||||
page_source: str,
|
||||
shell_kwargs: dict[str, Any],
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Render full page HTML in one OCaml call: aser-slot + shell render.
|
||||
|
||||
Static data (component_defs, CSS, pages_sx) is pre-injected as
|
||||
kernel vars on first call. Per-request command sends only small
|
||||
values (title, csrf) + references to the kernel vars.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
await self._inject_helpers_locked()
|
||||
await self._inject_shell_statics_locked()
|
||||
# Send request cookies so get-cookie works during SSR
|
||||
await self._inject_request_cookies_locked()
|
||||
# Large/complex blobs use placeholders — OCaml renders the shell
|
||||
# with short tokens; Python splices in the real values post-render.
|
||||
# This avoids piping large strings or strings with special chars
|
||||
# through the SX parser.
|
||||
PLACEHOLDER_KEYS = {"component_defs", "pages_sx", "init_sx",
|
||||
"sx_css", "inline_css", "inline_head_js"}
|
||||
placeholders = {}
|
||||
static_keys = {"component_hash", "sx_css_classes", "asset_url",
|
||||
"sx_js_hash", "body_js_hash",
|
||||
"head_scripts", "body_scripts"}
|
||||
# page_source is SX wire format that may contain \" escapes.
|
||||
# Send via binary blob protocol to avoid double-escaping
|
||||
# through the SX string parser round-trip.
|
||||
parts = ['(sx-page-full-blob']
|
||||
for key, val in shell_kwargs.items():
|
||||
k = key.replace("_", "-")
|
||||
if key in PLACEHOLDER_KEYS:
|
||||
token = f"__SLOT_{key.upper()}__"
|
||||
placeholders[token] = str(val) if val else ""
|
||||
parts.append(f' :{k} "{token}"')
|
||||
elif key in static_keys:
|
||||
parts.append(f' :{k} __shell-{k}')
|
||||
elif val is None:
|
||||
parts.append(f' :{k} nil')
|
||||
elif isinstance(val, bool):
|
||||
parts.append(f' :{k} {"true" if val else "false"}')
|
||||
elif isinstance(val, list):
|
||||
items = " ".join(f'"{_escape(str(v))}"' for v in val)
|
||||
parts.append(f' :{k} ({items})')
|
||||
else:
|
||||
parts.append(f' :{k} "{_escape(str(val))}"')
|
||||
parts.append(")")
|
||||
cmd = "".join(parts)
|
||||
await self._send_command(cmd)
|
||||
# Send page source as binary blob (avoids string-escape issues)
|
||||
await self._send_blob(page_source)
|
||||
html = await self._read_until_ok(ctx)
|
||||
# Splice in large blobs
|
||||
for token, blob in placeholders.items():
|
||||
html = html.replace(token, blob)
|
||||
return html
|
||||
|
||||
async def _inject_helpers_locked(self) -> None:
|
||||
"""Inject page helpers into the kernel. MUST be called with lock held."""
|
||||
if self._helpers_injected:
|
||||
return
|
||||
self._helpers_injected = True
|
||||
try:
|
||||
from .pages import get_page_helpers
|
||||
import inspect
|
||||
helpers = get_page_helpers("sx")
|
||||
if not helpers:
|
||||
self._helpers_injected = False
|
||||
return
|
||||
count = 0
|
||||
for name, fn in helpers.items():
|
||||
if callable(fn) and not name.startswith("~"):
|
||||
try:
|
||||
sig = inspect.signature(fn)
|
||||
nargs = sum(1 for p in sig.parameters.values()
|
||||
if p.kind in (p.POSITIONAL_ONLY, p.POSITIONAL_OR_KEYWORD))
|
||||
except (ValueError, TypeError):
|
||||
nargs = 2
|
||||
nargs = max(nargs, 1)
|
||||
param_names = " ".join(chr(97 + i) for i in range(nargs))
|
||||
arg_list = " ".join(chr(97 + i) for i in range(nargs))
|
||||
sx_def = f'(define {name} (fn ({param_names}) (helper "{name}" {arg_list})))'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(sx_def)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
count += 1
|
||||
except OcamlBridgeError:
|
||||
pass
|
||||
_logger.info("Injected %d page helpers into OCaml kernel", count)
|
||||
except Exception as e:
|
||||
_logger.warning("Helper injection failed: %s", e)
|
||||
self._helpers_injected = False
|
||||
|
||||
async def _compile_adapter_module(self) -> None:
|
||||
"""Compile adapter-sx.sx to bytecode and load as a VM module.
|
||||
|
||||
Previously used Python's sx_ref.py evaluator for compilation.
|
||||
Now the OCaml kernel handles JIT compilation natively — this method
|
||||
is a no-op. The kernel's own JIT hook compiles functions on first call.
|
||||
"""
|
||||
_logger.info("Adapter module compilation delegated to OCaml kernel JIT")
|
||||
|
||||
async def _ensure_components(self) -> None:
|
||||
"""Load all .sx source files into the kernel on first use.
|
||||
|
||||
Errors during loading are handled gracefully — IO responses are
|
||||
always sent back to keep the pipe clean.
|
||||
"""
|
||||
"""Load component definitions into the kernel on first use."""
|
||||
if self._components_loaded:
|
||||
return
|
||||
self._components_loaded = True
|
||||
try:
|
||||
from .jinja_bridge import _watched_dirs, _dirs_from_cache
|
||||
import glob
|
||||
from .jinja_bridge import get_component_env, _CLIENT_LIBRARY_SOURCES
|
||||
from .parser import serialize
|
||||
from .types import Component, Island, Macro
|
||||
|
||||
# Skip patterns — files that use constructs not available in the kernel
|
||||
skip_names = {"boundary.sx", "forms.sx"}
|
||||
skip_dirs = {"tests"}
|
||||
|
||||
# Collect files to load
|
||||
all_files: list[str] = []
|
||||
|
||||
# Core spec files
|
||||
spec_dir = os.path.join(os.path.dirname(__file__), "../../spec")
|
||||
for spec_file in ["parser.sx", "render.sx"]:
|
||||
path = os.path.normpath(os.path.join(spec_dir, spec_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
# Library files (compiler, vm, freeze — written in the language)
|
||||
lib_dir = os.path.join(os.path.dirname(__file__), "../../lib")
|
||||
for lib_file in ["bytecode.sx", "compiler.sx"]:
|
||||
path = os.path.normpath(os.path.join(lib_dir, lib_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
# All directories loaded into the Python env
|
||||
all_dirs = list(set(_watched_dirs) | _dirs_from_cache)
|
||||
|
||||
# Isomorphic libraries: signals, rendering, web forms
|
||||
web_dir = os.path.join(os.path.dirname(__file__), "../../web")
|
||||
if os.path.isdir(web_dir):
|
||||
for web_file in ["signals.sx", "adapter-html.sx", "adapter-sx.sx",
|
||||
"web-forms.sx"]:
|
||||
path = os.path.normpath(os.path.join(web_dir, web_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
# Library files loaded after adapters (depend on scope primitives)
|
||||
for lib_file in ["freeze.sx"]:
|
||||
path = os.path.normpath(os.path.join(lib_dir, lib_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
for directory in sorted(all_dirs):
|
||||
files = sorted(
|
||||
glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True)
|
||||
)
|
||||
for filepath in files:
|
||||
basename = os.path.basename(filepath)
|
||||
# Skip known-bad files
|
||||
if basename in skip_names:
|
||||
continue
|
||||
# Skip test and handler directories
|
||||
parts = filepath.replace("\\", "/").split("/")
|
||||
if any(d in skip_dirs for d in parts):
|
||||
continue
|
||||
all_files.append(filepath)
|
||||
|
||||
# Load all files under a single lock
|
||||
count = 0
|
||||
skipped = 0
|
||||
async with self._lock:
|
||||
for filepath in all_files:
|
||||
try:
|
||||
await self._send_command(f'(load "{_escape(filepath)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
# Response may be a number (count) or a value — just count files
|
||||
count += 1
|
||||
except OcamlBridgeError as e:
|
||||
skipped += 1
|
||||
_logger.warning("OCaml load skipped %s: %s",
|
||||
filepath, e)
|
||||
|
||||
# SSR overrides: effect is a no-op on the server (prevents
|
||||
# reactive loops during island SSR — effects are DOM side-effects)
|
||||
try:
|
||||
noop_dispose = '(fn () nil)'
|
||||
await self._send_command(f'(load-source "(define effect (fn (f) {noop_dispose}))")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError:
|
||||
pass
|
||||
|
||||
# Register JIT hook — lambdas compile on first call
|
||||
try:
|
||||
await self._send_command('(vm-compile-adapter)')
|
||||
await self._read_until_ok(ctx=None)
|
||||
_logger.info("JIT hook registered — lambdas compile on first call")
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("JIT hook registration skipped: %s", e)
|
||||
_logger.info("Loaded %d definitions from .sx files into OCaml kernel (%d skipped)",
|
||||
count, skipped)
|
||||
env = get_component_env()
|
||||
parts: list[str] = list(_CLIENT_LIBRARY_SOURCES)
|
||||
for key, val in env.items():
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param:
|
||||
ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
if parts:
|
||||
source = "\n".join(parts)
|
||||
await self.load_source(source)
|
||||
_logger.info("Loaded %d definitions into OCaml kernel", len(parts))
|
||||
except Exception as e:
|
||||
_logger.error("Failed to load .sx files into OCaml kernel: %s", e)
|
||||
_logger.error("Failed to load components into OCaml kernel: %s", e)
|
||||
self._components_loaded = False # retry next time
|
||||
|
||||
async def inject_page_helpers(self, helpers: dict) -> None:
|
||||
"""Register page helpers as IO-routing definitions in the kernel.
|
||||
|
||||
Each helper becomes a function that yields (io-request "helper" name ...),
|
||||
routing the call back to Python via the coroutine bridge.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
count = 0
|
||||
for name, fn in helpers.items():
|
||||
if callable(fn) and not name.startswith("~"):
|
||||
sx_def = f'(define {name} (fn (&rest args) (apply helper (concat (list "{name}") args))))'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(sx_def)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
count += 1
|
||||
except OcamlBridgeError:
|
||||
pass # non-fatal
|
||||
if count:
|
||||
_logger.info("Injected %d page helpers into OCaml kernel", count)
|
||||
|
||||
async def reset(self) -> None:
|
||||
"""Reset the kernel environment to pristine state."""
|
||||
async with self._lock:
|
||||
await self._send_command("(reset)")
|
||||
self._send("(reset)")
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"reset: {value}")
|
||||
@@ -483,102 +183,32 @@ class OcamlBridge:
|
||||
# Internal protocol handling
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
async def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin and flush."""
|
||||
if self._in_io_handler:
|
||||
raise OcamlBridgeError(
|
||||
f"Re-entrant bridge call from IO handler: {line[:80]}. "
|
||||
f"IO handlers must not call the bridge — use Python-only code."
|
||||
)
|
||||
def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin."""
|
||||
assert self._proc and self._proc.stdin
|
||||
_logger.debug("SEND: %s", line[:120])
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _send_command(self, line: str) -> None:
|
||||
"""Send a command with a fresh epoch prefix.
|
||||
|
||||
Increments the epoch counter and sends (epoch N) before the
|
||||
actual command. The OCaml kernel tags all responses with this
|
||||
epoch so stale messages from previous requests are discarded.
|
||||
"""
|
||||
self._epoch += 1
|
||||
assert self._proc and self._proc.stdin
|
||||
_logger.debug("EPOCH %d SEND: %s", self._epoch, line[:120])
|
||||
self._proc.stdin.write(f"(epoch {self._epoch})\n".encode())
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _send_blob(self, data: str) -> None:
|
||||
"""Send a length-prefixed binary blob to the subprocess.
|
||||
|
||||
Protocol: sends "(blob N)\\n" followed by exactly N bytes, then "\\n".
|
||||
The OCaml side reads the length, then reads exactly N bytes.
|
||||
This avoids string-escape round-trip issues for SX wire format.
|
||||
"""
|
||||
assert self._proc and self._proc.stdin
|
||||
encoded = data.encode()
|
||||
self._proc.stdin.write(f"(blob {len(encoded)})\n".encode())
|
||||
self._proc.stdin.write(encoded)
|
||||
self._proc.stdin.write(b"\n")
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _readline(self) -> str:
|
||||
"""Read a line from the subprocess stdout."""
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readline()
|
||||
if not data:
|
||||
# Process died
|
||||
# Process died — collect stderr for diagnostics
|
||||
stderr = b""
|
||||
if self._proc.stderr:
|
||||
stderr = await self._proc.stderr.read()
|
||||
raise OcamlBridgeError(
|
||||
"OCaml subprocess died unexpectedly (check container stderr)"
|
||||
f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}"
|
||||
)
|
||||
line = data.decode().rstrip("\n")
|
||||
_logger.debug("RECV: %s", line[:120])
|
||||
return line
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
async def _read_response(self) -> tuple[str, str | None]:
|
||||
"""Read a single (ok ...) or (error ...) response.
|
||||
|
||||
Returns (kind, value) where kind is "ok" or "error".
|
||||
Discards stale epoch messages.
|
||||
"""
|
||||
while True:
|
||||
line = await self._readline()
|
||||
if not self._is_current_epoch(line):
|
||||
_logger.debug("Discarding stale response: %s", line[:80])
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
if len(parts) >= 3:
|
||||
n = int(parts[-1])
|
||||
assert self._proc and self._proc.stdout
|
||||
await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline()
|
||||
continue
|
||||
# Length-prefixed blob: (ok-len EPOCH N) or (ok-len N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
n = int(parts[-1])
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline() # trailing newline
|
||||
return ("ok", data.decode())
|
||||
return _parse_response(line)
|
||||
|
||||
def _is_current_epoch(self, line: str) -> bool:
|
||||
"""Check if a response line belongs to the current epoch.
|
||||
|
||||
Lines tagged with a stale epoch are discarded. Untagged lines
|
||||
(from a kernel that predates the epoch protocol) are accepted.
|
||||
"""
|
||||
# Extract epoch number from known tagged formats:
|
||||
# (ok EPOCH ...), (error EPOCH ...), (ok-len EPOCH N),
|
||||
# (io-request EPOCH ...), (io-done EPOCH N)
|
||||
import re
|
||||
m = re.match(r'\((?:ok|error|ok-len|ok-raw|io-request|io-done)\s+(\d+)\b', line)
|
||||
if m:
|
||||
return int(m.group(1)) == self._epoch
|
||||
# Untagged (legacy) — accept
|
||||
return True
|
||||
line = await self._readline()
|
||||
return _parse_response(line)
|
||||
|
||||
async def _read_until_ok(
|
||||
self,
|
||||
@@ -586,94 +216,17 @@ class OcamlBridge:
|
||||
) -> str:
|
||||
"""Read lines until (ok ...) or (error ...).
|
||||
|
||||
Handles IO requests in two modes:
|
||||
- Legacy (blocking): single io-request → immediate io-response
|
||||
- Batched: collect io-requests until (io-done N), process ALL
|
||||
concurrently with asyncio.gather, send responses in order
|
||||
|
||||
Lines tagged with a stale epoch are silently discarded, making
|
||||
pipe desync from previous failed requests impossible.
|
||||
Handles (io-request ...) by fulfilling IO and sending (io-response ...).
|
||||
"""
|
||||
import asyncio
|
||||
pending_batch: list[str] = []
|
||||
|
||||
while True:
|
||||
line = await self._readline()
|
||||
|
||||
# Discard stale epoch messages
|
||||
if not self._is_current_epoch(line):
|
||||
_logger.debug("Discarding stale epoch message: %s", line[:80])
|
||||
# If it's a stale ok-len, drain the blob bytes too
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
if len(parts) >= 3:
|
||||
n = int(parts[2])
|
||||
assert self._proc and self._proc.stdout
|
||||
await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline()
|
||||
continue
|
||||
|
||||
if line.startswith("(io-request "):
|
||||
# New format: (io-request EPOCH ...) or (io-request EPOCH ID ...)
|
||||
# Strip epoch from the line for IO dispatch
|
||||
after = line[len("(io-request "):].lstrip()
|
||||
# Skip epoch number if present
|
||||
if after and after[0].isdigit():
|
||||
# Could be epoch or batch ID — check for second number
|
||||
parts = after.split(None, 2)
|
||||
if len(parts) >= 2 and parts[1][0].isdigit():
|
||||
# (io-request EPOCH ID "name" args...) — batched with epoch
|
||||
pending_batch.append(line)
|
||||
continue
|
||||
elif len(parts) >= 2 and parts[1].startswith('"'):
|
||||
# (io-request EPOCH "name" args...) — legacy with epoch
|
||||
try:
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
except Exception as e:
|
||||
_logger.warning("IO request failed, sending nil: %s", e)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
continue
|
||||
else:
|
||||
# Old format: (io-request ID "name" ...) — batched, no epoch
|
||||
pending_batch.append(line)
|
||||
continue
|
||||
# Legacy blocking mode — respond immediately
|
||||
try:
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
except Exception as e:
|
||||
_logger.warning("IO request failed, sending nil: %s", e)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
# Send response back to OCaml
|
||||
self._send(f"(io-response {_serialize_for_ocaml(result)})")
|
||||
continue
|
||||
|
||||
if line.startswith("(io-done "):
|
||||
# Batch complete — process all pending IO concurrently
|
||||
tasks = [self._handle_io_request(req, ctx)
|
||||
for req in pending_batch]
|
||||
results = await asyncio.gather(*tasks, return_exceptions=True)
|
||||
for result in results:
|
||||
if isinstance(result, BaseException):
|
||||
_logger.warning("Batched IO failed: %s", result)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
else:
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
pending_batch = []
|
||||
continue
|
||||
|
||||
# Length-prefixed blob: (ok-len EPOCH N) or (ok-len N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split() # ["ok-len", epoch, n] or ["ok-len", n]
|
||||
n = int(parts[-1]) # last number is always byte count
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readexactly(n)
|
||||
# Read trailing newline
|
||||
await self._proc.stdout.readline()
|
||||
return data.decode()
|
||||
|
||||
kind, value = _parse_response(line)
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(value or "Unknown error")
|
||||
@@ -685,24 +238,7 @@ class OcamlBridge:
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Dispatch an io-request to the appropriate Python handler.
|
||||
|
||||
IO handlers MUST NOT call the bridge (eval/aser/render) — doing so
|
||||
would deadlock since the lock is already held. The _in_io_handler
|
||||
flag triggers an immediate error if this rule is violated.
|
||||
"""
|
||||
self._in_io_handler = True
|
||||
try:
|
||||
return await self._dispatch_io(line, ctx)
|
||||
finally:
|
||||
self._in_io_handler = False
|
||||
|
||||
async def _dispatch_io(
|
||||
self,
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Inner dispatch for IO requests."""
|
||||
"""Dispatch an io-request to the appropriate Python handler."""
|
||||
from .parser import parse_all
|
||||
|
||||
# Parse the io-request
|
||||
@@ -711,17 +247,12 @@ class OcamlBridge:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
parts = parsed[0]
|
||||
# Legacy: [Symbol("io-request"), name_str, ...args]
|
||||
# Batched: [Symbol("io-request"), id_num, name_str, ...args]
|
||||
# parts = [Symbol("io-request"), name_str, ...args]
|
||||
if len(parts) < 2:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
# Skip numeric batch ID if present
|
||||
offset = 1
|
||||
if isinstance(parts[1], (int, float)):
|
||||
offset = 2
|
||||
req_name = _to_str(parts[offset])
|
||||
args = parts[offset + 1:]
|
||||
req_name = _to_str(parts[1])
|
||||
args = parts[2:]
|
||||
|
||||
if req_name == "query":
|
||||
return await self._io_query(args)
|
||||
@@ -733,15 +264,7 @@ class OcamlBridge:
|
||||
return self._io_request_method()
|
||||
elif req_name == "ctx":
|
||||
return self._io_ctx(args, ctx)
|
||||
elif req_name == "helper":
|
||||
return await self._io_helper(args, ctx)
|
||||
else:
|
||||
# Fall back to registered IO handlers (set-response-status, sleep, etc.)
|
||||
from .primitives_io import _IO_HANDLERS, RequestContext
|
||||
io_handler = _IO_HANDLERS.get(req_name)
|
||||
if io_handler is not None:
|
||||
helper_args = [_to_python(a) for a in args]
|
||||
return await io_handler(helper_args, {}, ctx or RequestContext())
|
||||
raise OcamlBridgeError(f"Unknown io-request type: {req_name}")
|
||||
|
||||
async def _io_query(self, args: list) -> Any:
|
||||
@@ -786,63 +309,6 @@ class OcamlBridge:
|
||||
key = _to_str(args[0]) if args else ""
|
||||
return ctx.get(key)
|
||||
|
||||
# Helpers that are pure functions — safe to cache by args.
|
||||
_CACHEABLE_HELPERS = frozenset({
|
||||
"highlight", "component-source", "primitives-data",
|
||||
"special-forms-data", "reference-data", "read-spec-file",
|
||||
"bootstrapper-data", "bundle-analyzer-data", "routing-analyzer-data",
|
||||
})
|
||||
|
||||
async def _io_helper(self, args: list, ctx: dict[str, Any] | None) -> Any:
|
||||
"""Handle (io-request "helper" name arg1 arg2 ...).
|
||||
|
||||
Dispatches to registered page helpers — Python functions like
|
||||
read-spec-file, bootstrapper-data, etc. The helper service name
|
||||
is passed via ctx["_helper_service"].
|
||||
|
||||
Pure helpers (highlight etc.) are cached — same input always
|
||||
produces same output. Eliminates blocking round-trips for
|
||||
repeat calls across pages.
|
||||
"""
|
||||
import asyncio
|
||||
from .pages import get_page_helpers
|
||||
from .primitives_io import _IO_HANDLERS, RequestContext
|
||||
|
||||
name = _to_str(args[0]) if args else ""
|
||||
helper_args = [_to_python(a) for a in args[1:]]
|
||||
|
||||
# Cache lookup for pure helpers
|
||||
if name in self._CACHEABLE_HELPERS:
|
||||
cache_key = (name, *[repr(a) for a in helper_args])
|
||||
if cache_key in self._io_cache:
|
||||
return self._io_cache[cache_key]
|
||||
|
||||
# Check page helpers first (application-level)
|
||||
service = (ctx or {}).get("_helper_service", "sx")
|
||||
helpers = get_page_helpers(service)
|
||||
fn = helpers.get(name)
|
||||
if fn is not None:
|
||||
result = fn(*helper_args)
|
||||
if asyncio.iscoroutine(result):
|
||||
result = await result
|
||||
# Cache pure helper results
|
||||
if name in self._CACHEABLE_HELPERS:
|
||||
self._io_cache[cache_key] = result
|
||||
return result
|
||||
|
||||
# Fall back to IO primitives (now, state-get, state-set!, etc.)
|
||||
io_handler = _IO_HANDLERS.get(name)
|
||||
if io_handler is not None:
|
||||
return await io_handler(helper_args, {}, RequestContext())
|
||||
|
||||
# Fall back to regular primitives (json-encode, into, etc.)
|
||||
from .primitives import get_primitive as _get_prim
|
||||
prim = _get_prim(name)
|
||||
if prim is not None:
|
||||
return prim(*helper_args)
|
||||
|
||||
raise OcamlBridgeError(f"Unknown helper: {name!r}")
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Module-level singleton
|
||||
@@ -873,50 +339,22 @@ def _escape(s: str) -> str:
|
||||
def _parse_response(line: str) -> tuple[str, str | None]:
|
||||
"""Parse an (ok ...) or (error ...) response line.
|
||||
|
||||
Handles epoch-tagged responses: (ok EPOCH), (ok EPOCH value),
|
||||
(error EPOCH "msg"), as well as legacy untagged responses.
|
||||
|
||||
Returns (kind, value) tuple.
|
||||
"""
|
||||
line = line.strip()
|
||||
# (ok EPOCH) — tagged no-value
|
||||
if line == "(ok)" or (line.startswith("(ok ") and line[4:-1].isdigit()):
|
||||
if line == "(ok)":
|
||||
return ("ok", None)
|
||||
if line.startswith("(ok-raw "):
|
||||
# (ok-raw EPOCH value) or (ok-raw value)
|
||||
inner = line[8:-1]
|
||||
# Strip epoch if present
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
else:
|
||||
return ("ok", None)
|
||||
return ("ok", inner)
|
||||
if line.startswith("(ok "):
|
||||
inner = line[4:-1] # strip (ok and )
|
||||
# Strip epoch number if present: (ok 42 "value") → "value"
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
else:
|
||||
# (ok EPOCH) with no value
|
||||
return ("ok", None)
|
||||
value = line[4:-1] # strip (ok and )
|
||||
# If the value is a quoted string, unquote it
|
||||
if inner.startswith('"') and inner.endswith('"'):
|
||||
inner = _unescape(inner[1:-1])
|
||||
return ("ok", inner)
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _unescape(value[1:-1])
|
||||
return ("ok", value)
|
||||
if line.startswith("(error "):
|
||||
inner = line[7:-1]
|
||||
# Strip epoch number if present: (error 42 "msg") → "msg"
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
if inner.startswith('"') and inner.endswith('"'):
|
||||
inner = _unescape(inner[1:-1])
|
||||
return ("error", inner)
|
||||
msg = line[7:-1]
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _unescape(msg[1:-1])
|
||||
return ("error", msg)
|
||||
return ("error", f"Unexpected response: {line}")
|
||||
|
||||
|
||||
@@ -931,16 +369,6 @@ def _unescape(s: str) -> str:
|
||||
)
|
||||
|
||||
|
||||
def _to_python(val: Any) -> Any:
|
||||
"""Convert an SX parsed value to a plain Python value."""
|
||||
from .types import NIL as _NIL
|
||||
if val is None or val is _NIL:
|
||||
return None
|
||||
if hasattr(val, "name"): # Symbol or Keyword
|
||||
return val.name
|
||||
return val
|
||||
|
||||
|
||||
def _to_str(val: Any) -> str:
|
||||
"""Convert an SX parsed value to a Python string."""
|
||||
if isinstance(val, str):
|
||||
|
||||
@@ -1,167 +0,0 @@
|
||||
"""
|
||||
Synchronous OCaml bridge — persistent subprocess for build-time evaluation.
|
||||
|
||||
Used by bootstrappers (JS cli.py, OCaml bootstrap.py) that need a sync
|
||||
evaluator to run transpiler.sx. For async runtime use, see ocaml_bridge.py.
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import subprocess
|
||||
import sys
|
||||
|
||||
_DEFAULT_BIN = os.path.join(
|
||||
os.path.dirname(__file__),
|
||||
"../../hosts/ocaml/_build/default/bin/sx_server.exe",
|
||||
)
|
||||
|
||||
|
||||
class OcamlSyncError(Exception):
|
||||
"""Error from the OCaml SX kernel."""
|
||||
|
||||
|
||||
def _sx_unescape(s: str) -> str:
|
||||
"""Unescape an SX string literal (left-to-right, one pass)."""
|
||||
out = []
|
||||
i = 0
|
||||
while i < len(s):
|
||||
if s[i] == '\\' and i + 1 < len(s):
|
||||
c = s[i + 1]
|
||||
if c == 'n':
|
||||
out.append('\n')
|
||||
elif c == 'r':
|
||||
out.append('\r')
|
||||
elif c == 't':
|
||||
out.append('\t')
|
||||
elif c == '"':
|
||||
out.append('"')
|
||||
elif c == '\\':
|
||||
out.append('\\')
|
||||
else:
|
||||
out.append(c)
|
||||
i += 2
|
||||
else:
|
||||
out.append(s[i])
|
||||
i += 1
|
||||
return ''.join(out)
|
||||
|
||||
|
||||
class OcamlSync:
|
||||
"""Synchronous bridge to the OCaml sx_server subprocess."""
|
||||
|
||||
def __init__(self, binary: str | None = None):
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: subprocess.Popen | None = None
|
||||
self._epoch: int = 0
|
||||
|
||||
def _ensure(self):
|
||||
if self._proc is not None and self._proc.poll() is None:
|
||||
return
|
||||
self._proc = subprocess.Popen(
|
||||
[self._binary],
|
||||
stdin=subprocess.PIPE,
|
||||
stdout=subprocess.PIPE,
|
||||
stderr=subprocess.PIPE,
|
||||
)
|
||||
self._epoch = 0
|
||||
# Wait for (ready)
|
||||
line = self._readline()
|
||||
if line != "(ready)":
|
||||
raise OcamlSyncError(f"Expected (ready), got: {line}")
|
||||
|
||||
def _send(self, command: str):
|
||||
"""Send a command with epoch prefix."""
|
||||
assert self._proc and self._proc.stdin
|
||||
self._epoch += 1
|
||||
self._proc.stdin.write(f"(epoch {self._epoch})\n".encode())
|
||||
self._proc.stdin.write((command + "\n").encode())
|
||||
self._proc.stdin.flush()
|
||||
|
||||
def _readline(self) -> str:
|
||||
assert self._proc and self._proc.stdout
|
||||
data = self._proc.stdout.readline()
|
||||
if not data:
|
||||
raise OcamlSyncError("OCaml subprocess died unexpectedly")
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
def _strip_epoch(self, inner: str) -> str:
|
||||
"""Strip leading epoch number from a response value: '42 value' → 'value'."""
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
return inner[space + 1:]
|
||||
return "" # epoch only, no value
|
||||
return inner
|
||||
|
||||
def _read_response(self) -> str:
|
||||
"""Read a single response. Returns the value string or raises on error.
|
||||
|
||||
Handles epoch-tagged responses: (ok EPOCH), (ok EPOCH value),
|
||||
(ok-len EPOCH N), (error EPOCH "msg").
|
||||
"""
|
||||
line = self._readline()
|
||||
# Length-prefixed blob: (ok-len N) or (ok-len EPOCH N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split() # ["ok-len", ...]
|
||||
n = int(parts[-1]) # last number is always byte count
|
||||
assert self._proc and self._proc.stdout
|
||||
data = self._proc.stdout.read(n)
|
||||
self._proc.stdout.readline() # trailing newline
|
||||
value = data.decode()
|
||||
# Blob is SX-serialized — strip string quotes and unescape
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _sx_unescape(value[1:-1])
|
||||
return value
|
||||
if line == "(ok)" or (line.startswith("(ok ") and line[4:-1].isdigit()):
|
||||
return ""
|
||||
if line.startswith("(ok-raw "):
|
||||
inner = self._strip_epoch(line[8:-1])
|
||||
return inner
|
||||
if line.startswith("(ok "):
|
||||
value = self._strip_epoch(line[4:-1])
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _sx_unescape(value[1:-1])
|
||||
return value
|
||||
if line.startswith("(error "):
|
||||
msg = self._strip_epoch(line[7:-1])
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _sx_unescape(msg[1:-1])
|
||||
raise OcamlSyncError(msg)
|
||||
raise OcamlSyncError(f"Unexpected response: {line}")
|
||||
|
||||
def eval(self, source: str) -> str:
|
||||
"""Evaluate SX source, return result as string."""
|
||||
self._ensure()
|
||||
escaped = source.replace("\\", "\\\\").replace('"', '\\"')
|
||||
self._send(f'(eval "{escaped}")')
|
||||
return self._read_response()
|
||||
|
||||
def load(self, path: str) -> str:
|
||||
"""Load an .sx file into the kernel."""
|
||||
self._ensure()
|
||||
self._send(f'(load "{path}")')
|
||||
return self._read_response()
|
||||
|
||||
def load_source(self, source: str) -> str:
|
||||
"""Load SX source directly into the kernel."""
|
||||
self._ensure()
|
||||
escaped = source.replace("\\", "\\\\").replace('"', '\\"')
|
||||
self._send(f'(load-source "{escaped}")')
|
||||
return self._read_response()
|
||||
|
||||
def stop(self):
|
||||
if self._proc and self._proc.poll() is None:
|
||||
self._proc.terminate()
|
||||
self._proc.wait(timeout=5)
|
||||
self._proc = None
|
||||
|
||||
|
||||
# Singleton
|
||||
_global: OcamlSync | None = None
|
||||
|
||||
|
||||
def get_sync_bridge() -> OcamlSync:
|
||||
global _global
|
||||
if _global is None:
|
||||
_global = OcamlSync()
|
||||
return _global
|
||||
@@ -32,7 +32,7 @@ logger = logging.getLogger("sx.pages")
|
||||
|
||||
def _eval_error_sx(e: EvalError, context: str) -> str:
|
||||
"""Render an EvalError as SX content that's visible to the developer."""
|
||||
from html import escape as _esc
|
||||
from .ref.sx_ref import escape_html as _esc
|
||||
msg = _esc(str(e))
|
||||
ctx = _esc(context)
|
||||
return (
|
||||
@@ -141,60 +141,29 @@ def get_page_helpers(service: str) -> dict[str, Any]:
|
||||
# Loading — parse .sx files and collect PageDef instances
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _parse_defpage(expr: list) -> PageDef | None:
|
||||
"""Extract PageDef from a (defpage name :path ... :content ...) form."""
|
||||
from .types import Keyword
|
||||
if len(expr) < 3:
|
||||
return None
|
||||
name = expr[1].name if hasattr(expr[1], 'name') else str(expr[1])
|
||||
|
||||
kwargs: dict[str, Any] = {}
|
||||
i = 2
|
||||
while i < len(expr):
|
||||
item = expr[i]
|
||||
if isinstance(item, Keyword) and i + 1 < len(expr):
|
||||
kwargs[item.name] = expr[i + 1]
|
||||
i += 2
|
||||
else:
|
||||
i += 1
|
||||
|
||||
path = kwargs.get("path")
|
||||
if not path or not isinstance(path, str):
|
||||
return None
|
||||
|
||||
auth = kwargs.get("auth", "public")
|
||||
if hasattr(auth, 'name'):
|
||||
auth = auth.name
|
||||
|
||||
return PageDef(
|
||||
name=name, path=path, auth=auth,
|
||||
layout=kwargs.get("layout"),
|
||||
cache=None,
|
||||
data_expr=kwargs.get("data"),
|
||||
content_expr=kwargs.get("content"),
|
||||
filter_expr=kwargs.get("filter"),
|
||||
aside_expr=kwargs.get("aside"),
|
||||
menu_expr=kwargs.get("menu"),
|
||||
)
|
||||
|
||||
|
||||
def load_page_file(filepath: str, service_name: str) -> list[PageDef]:
|
||||
"""Parse an .sx file and register any defpage definitions."""
|
||||
"""Parse an .sx file, evaluate it, and register any PageDef values."""
|
||||
from .parser import parse_all
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
# Seed env with component definitions so pages can reference components
|
||||
env = dict(get_component_env())
|
||||
exprs = parse_all(source)
|
||||
pages: list[PageDef] = []
|
||||
|
||||
for expr in exprs:
|
||||
if (isinstance(expr, list) and expr
|
||||
and hasattr(expr[0], 'name') and expr[0].name == "defpage"):
|
||||
pd = _parse_defpage(expr)
|
||||
if pd:
|
||||
register_page(service_name, pd)
|
||||
pages.append(pd)
|
||||
_eval(expr, env)
|
||||
|
||||
# Collect all PageDef values from the env
|
||||
for key, val in env.items():
|
||||
if isinstance(val, PageDef):
|
||||
register_page(service_name, val)
|
||||
pages.append(val)
|
||||
|
||||
return pages
|
||||
|
||||
@@ -208,95 +177,10 @@ def load_page_dir(directory: str, service_name: str) -> list[PageDef]:
|
||||
return pages
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# URL → SX expression conversion (was in sx_ref.py, pure logic)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def prepare_url_expr(url_path: str, env: dict) -> list:
|
||||
"""Convert a URL path to an SX expression, quoting unknown symbols."""
|
||||
from .parser import parse_all
|
||||
from .types import Symbol
|
||||
|
||||
if not url_path or url_path == "/":
|
||||
return []
|
||||
trimmed = url_path.lstrip("/")
|
||||
sx_source = trimmed.replace(".", " ")
|
||||
exprs = parse_all(sx_source)
|
||||
if not exprs:
|
||||
return []
|
||||
expr = exprs[0]
|
||||
if not isinstance(expr, list):
|
||||
return expr
|
||||
# Auto-quote unknown symbols (not in env, not keywords/components)
|
||||
return _auto_quote(expr, env)
|
||||
|
||||
|
||||
def _auto_quote(expr, env: dict):
|
||||
from .types import Symbol
|
||||
if not isinstance(expr, list) or not expr:
|
||||
return expr
|
||||
head = expr[0]
|
||||
children = []
|
||||
for child in expr[1:]:
|
||||
if isinstance(child, list):
|
||||
children.append(_auto_quote(child, env))
|
||||
elif isinstance(child, Symbol):
|
||||
name = child.name
|
||||
if (name in env or name.startswith(":") or
|
||||
name.startswith("~") or name.startswith("!")):
|
||||
children.append(child)
|
||||
else:
|
||||
children.append(name) # quote as string
|
||||
else:
|
||||
children.append(child)
|
||||
return [head] + children
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Page execution
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _wrap_with_env(expr: Any, env: dict) -> str:
|
||||
"""Serialize an expression wrapped with let-bindings from env.
|
||||
|
||||
Injects page env values (URL params, data results) as let-bindings
|
||||
so the OCaml kernel can evaluate the expression with those bindings.
|
||||
Only injects non-component, non-callable values that pages add dynamically.
|
||||
"""
|
||||
from .parser import serialize
|
||||
from .ocaml_bridge import _serialize_for_ocaml
|
||||
from .types import Symbol, Keyword, NIL
|
||||
|
||||
body = serialize(expr)
|
||||
bindings = []
|
||||
for k, v in env.items():
|
||||
# Skip component definitions — already loaded in kernel
|
||||
if k.startswith("~") or callable(v):
|
||||
continue
|
||||
# Skip env keys that are component-env infrastructure
|
||||
if isinstance(v, (type, type(None))) and v is not None:
|
||||
continue
|
||||
# Serialize the value
|
||||
if v is NIL or v is None:
|
||||
sv = "nil"
|
||||
elif isinstance(v, bool):
|
||||
sv = "true" if v else "false"
|
||||
elif isinstance(v, (int, float)):
|
||||
sv = str(int(v)) if isinstance(v, float) and v == int(v) else str(v)
|
||||
elif isinstance(v, str):
|
||||
sv = _serialize_for_ocaml(v)
|
||||
elif isinstance(v, (list, dict)):
|
||||
sv = _serialize_for_ocaml(v)
|
||||
else:
|
||||
# Component, Lambda, etc — skip, already in kernel
|
||||
continue
|
||||
bindings.append(f"({k} {sv})")
|
||||
|
||||
if not bindings:
|
||||
return body
|
||||
return f"(let ({' '.join(bindings)}) {body})"
|
||||
|
||||
|
||||
async def _eval_slot(expr: Any, env: dict, ctx: Any) -> str:
|
||||
"""Evaluate a page slot expression and return an sx source string.
|
||||
|
||||
@@ -304,16 +188,10 @@ async def _eval_slot(expr: Any, env: dict, ctx: Any) -> str:
|
||||
the result as SX wire format, not HTML.
|
||||
"""
|
||||
import os
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
# Wrap expression with let-bindings for env values that pages
|
||||
# inject (URL params, data results, etc.)
|
||||
sx_text = _wrap_with_env(expr, env)
|
||||
service = ctx.get("_helper_service", "") if isinstance(ctx, dict) else ""
|
||||
return await bridge.aser_slot(sx_text, ctx={"_helper_service": service})
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_slot_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
return await async_eval_slot_to_sx(expr, env, ctx)
|
||||
|
||||
|
||||
@@ -370,19 +248,12 @@ async def execute_page(
|
||||
6. Branch: full_page_sx() vs oob_page_sx() based on is_htmx_request()
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .async_eval import async_eval
|
||||
from .page import get_template_context
|
||||
from .helpers import full_page_sx, oob_page_sx, sx_response
|
||||
from .layouts import get_layout
|
||||
from shared.browser.app.utils.htmx import is_htmx_request
|
||||
|
||||
_use_ocaml = os.environ.get("SX_USE_OCAML") == "1"
|
||||
if _use_ocaml:
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .ocaml_bridge import _serialize_for_ocaml
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
if url_params is None:
|
||||
url_params = {}
|
||||
|
||||
@@ -404,19 +275,7 @@ async def execute_page(
|
||||
# Evaluate :data expression if present
|
||||
_multi_stream_content = None
|
||||
if page_def.data_expr is not None:
|
||||
if _use_ocaml:
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(page_def.data_expr, env)
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
raw = await bridge.eval(sx_text, ctx=ocaml_ctx)
|
||||
# Parse result back to Python dict/value
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
data_result = parsed[0] if parsed else {}
|
||||
else:
|
||||
data_result = {}
|
||||
else:
|
||||
data_result = await async_eval(page_def.data_expr, env, ctx)
|
||||
data_result = await async_eval(page_def.data_expr, env, ctx)
|
||||
if hasattr(data_result, '__aiter__'):
|
||||
# Multi-stream: consume generator, eval :content per chunk,
|
||||
# combine into shell with resolved suspense slots.
|
||||
@@ -499,18 +358,7 @@ async def execute_page(
|
||||
k = raw[i]
|
||||
if isinstance(k, SxKeyword) and i + 1 < len(raw):
|
||||
raw_val = raw[i + 1]
|
||||
if _use_ocaml:
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(raw_val, env)
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
raw_result = await bridge.eval(sx_text, ctx=ocaml_ctx)
|
||||
if raw_result:
|
||||
parsed = parse_all(raw_result)
|
||||
resolved = parsed[0] if parsed else None
|
||||
else:
|
||||
resolved = None
|
||||
else:
|
||||
resolved = await async_eval(raw_val, env, ctx)
|
||||
resolved = await async_eval(raw_val, env, ctx)
|
||||
layout_kwargs[k.name.replace("-", "_")] = resolved
|
||||
i += 2
|
||||
else:
|
||||
|
||||
@@ -38,11 +38,10 @@ def _resolve_sx_reader_macro(name: str):
|
||||
If a file like z3.sx defines (define z3-translate ...), then #z3 is
|
||||
automatically available as a reader macro without any Python registration.
|
||||
Looks for {name}-translate as a Lambda in the component env.
|
||||
|
||||
Uses the synchronous OCaml bridge (ocaml_sync) when available.
|
||||
"""
|
||||
try:
|
||||
from .jinja_bridge import get_component_env
|
||||
from .ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
|
||||
from .types import Lambda
|
||||
except ImportError:
|
||||
return None
|
||||
@@ -50,18 +49,10 @@ def _resolve_sx_reader_macro(name: str):
|
||||
fn = env.get(f"{name}-translate")
|
||||
if fn is None or not isinstance(fn, Lambda):
|
||||
return None
|
||||
# Use sync OCaml bridge to invoke the lambda
|
||||
try:
|
||||
from .ocaml_sync import OcamlSync
|
||||
_sync = OcamlSync()
|
||||
_sync.start()
|
||||
def _sx_handler(expr):
|
||||
from .parser import serialize as _ser
|
||||
result = _sync.eval(f"({name}-translate {_ser(expr)})")
|
||||
return parse(result) if result else expr
|
||||
return _sx_handler
|
||||
except Exception:
|
||||
return None
|
||||
# Return a Python callable that invokes the SX lambda
|
||||
def _sx_handler(expr):
|
||||
return _trampoline(_call_lambda(fn, [expr], env))
|
||||
return _sx_handler
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@@ -579,54 +579,26 @@ def prim_json_encode(value) -> str:
|
||||
# (shared global state between transpiled and hand-written evaluators)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _register_scope_primitives():
|
||||
"""Register scope/provide/collect primitive stubs.
|
||||
def _lazy_scope_primitives():
|
||||
"""Register scope/provide/collect primitives from sx_ref.py.
|
||||
|
||||
The OCaml kernel provides the real implementations. These stubs exist
|
||||
so _PRIMITIVES contains the names for dependency analysis, and so
|
||||
any Python-side code that checks for their existence finds them.
|
||||
Called at import time — if sx_ref.py isn't built yet, silently skip.
|
||||
These are needed by the hand-written _aser in async_eval.py when
|
||||
expanding components that use scoped effects (e.g. ~cssx/flush).
|
||||
"""
|
||||
import threading
|
||||
_scope_data = threading.local()
|
||||
try:
|
||||
from .ref.sx_ref import (
|
||||
sx_collect, sx_collected, sx_clear_collected,
|
||||
sx_emitted, sx_emit, sx_context,
|
||||
)
|
||||
_PRIMITIVES["collect!"] = sx_collect
|
||||
_PRIMITIVES["collected"] = sx_collected
|
||||
_PRIMITIVES["clear-collected!"] = sx_clear_collected
|
||||
_PRIMITIVES["emitted"] = sx_emitted
|
||||
_PRIMITIVES["emit!"] = sx_emit
|
||||
_PRIMITIVES["context"] = sx_context
|
||||
except ImportError:
|
||||
pass
|
||||
|
||||
def _collect(channel, value):
|
||||
if not hasattr(_scope_data, 'collected'):
|
||||
_scope_data.collected = {}
|
||||
_scope_data.collected.setdefault(channel, []).append(value)
|
||||
return NIL
|
||||
|
||||
def _collected(channel):
|
||||
if not hasattr(_scope_data, 'collected'):
|
||||
return []
|
||||
return list(_scope_data.collected.get(channel, []))
|
||||
|
||||
def _clear_collected(channel):
|
||||
if hasattr(_scope_data, 'collected'):
|
||||
_scope_data.collected.pop(channel, None)
|
||||
return NIL
|
||||
|
||||
def _emit(channel, value):
|
||||
if not hasattr(_scope_data, 'emitted'):
|
||||
_scope_data.emitted = {}
|
||||
_scope_data.emitted.setdefault(channel, []).append(value)
|
||||
return NIL
|
||||
|
||||
def _emitted(channel):
|
||||
if not hasattr(_scope_data, 'emitted'):
|
||||
return []
|
||||
return list(_scope_data.emitted.get(channel, []))
|
||||
|
||||
def _context(key):
|
||||
if not hasattr(_scope_data, 'context'):
|
||||
return NIL
|
||||
return _scope_data.context.get(key, NIL) if isinstance(_scope_data.context, dict) else NIL
|
||||
|
||||
_PRIMITIVES["collect!"] = _collect
|
||||
_PRIMITIVES["collected"] = _collected
|
||||
_PRIMITIVES["clear-collected!"] = _clear_collected
|
||||
_PRIMITIVES["emitted"] = _emitted
|
||||
_PRIMITIVES["emit!"] = _emit
|
||||
_PRIMITIVES["context"] = _context
|
||||
|
||||
_register_scope_primitives()
|
||||
_lazy_scope_primitives()
|
||||
|
||||
|
||||
@@ -642,8 +642,7 @@ from . import primitives_ctx # noqa: E402, F401
|
||||
# Auto-derive IO_PRIMITIVES from registered handlers
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# Placeholder — rebuilt at end of file after all handlers are registered
|
||||
IO_PRIMITIVES: frozenset[str] = frozenset()
|
||||
IO_PRIMITIVES: frozenset[str] = frozenset(_IO_HANDLERS.keys())
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -704,45 +703,9 @@ _PRIMITIVES["relations-from"] = _bridge_relations_from
|
||||
# Validate all IO handlers against boundary.sx
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@register_io_handler("helper")
|
||||
async def _io_helper(
|
||||
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
|
||||
) -> Any:
|
||||
"""``(helper "name" args...)`` → dispatch to page helpers or IO handlers.
|
||||
|
||||
Universal IO dispatcher — same interface as the OCaml kernel's helper
|
||||
IO primitive. Checks page helpers first, then IO handlers.
|
||||
"""
|
||||
if not args:
|
||||
raise ValueError("helper requires a name")
|
||||
name = str(args[0])
|
||||
helper_args = args[1:]
|
||||
|
||||
# Check page helpers first
|
||||
from .pages import get_page_helpers
|
||||
helpers = get_page_helpers("sx")
|
||||
fn = helpers.get(name)
|
||||
if fn is not None:
|
||||
import asyncio
|
||||
result = fn(*helper_args)
|
||||
if asyncio.iscoroutine(result):
|
||||
result = await result
|
||||
return result
|
||||
|
||||
# Fall back to IO handlers
|
||||
io_handler = _IO_HANDLERS.get(name)
|
||||
if io_handler is not None:
|
||||
return await io_handler(helper_args, {}, ctx)
|
||||
|
||||
raise ValueError(f"Unknown helper: {name!r}")
|
||||
|
||||
|
||||
def _validate_io_handlers() -> None:
|
||||
from .boundary import validate_io
|
||||
for name in _IO_HANDLERS:
|
||||
validate_io(name)
|
||||
|
||||
_validate_io_handlers()
|
||||
|
||||
# Rebuild IO_PRIMITIVES now that all handlers (including helper) are registered
|
||||
IO_PRIMITIVES = frozenset(_IO_HANDLERS.keys())
|
||||
|
||||
@@ -21,6 +21,10 @@ async def execute_query(query_def: QueryDef, params: dict[str, str]) -> Any:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(query_def.closure)
|
||||
@@ -34,23 +38,6 @@ async def execute_query(query_def: QueryDef, params: dict[str, str]) -> Any:
|
||||
val = int(val)
|
||||
env[param] = val
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .pages import _wrap_with_env
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(query_def.body, env)
|
||||
ctx = {"_helper_service": ""}
|
||||
raw = await bridge.eval(sx_text, ctx=ctx)
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
result = parsed[0] if parsed else None
|
||||
else:
|
||||
result = None
|
||||
return _normalize(result)
|
||||
|
||||
from .async_eval import async_eval
|
||||
|
||||
ctx = _get_request_context()
|
||||
result = await async_eval(query_def.body, env, ctx)
|
||||
return _normalize(result)
|
||||
@@ -63,6 +50,10 @@ async def execute_action(action_def: ActionDef, payload: dict[str, Any]) -> Any:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(action_def.closure)
|
||||
@@ -73,23 +64,6 @@ async def execute_action(action_def: ActionDef, payload: dict[str, Any]) -> Any:
|
||||
val = payload.get(param, payload.get(snake, NIL))
|
||||
env[param] = val
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .pages import _wrap_with_env
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(action_def.body, env)
|
||||
ctx = {"_helper_service": ""}
|
||||
raw = await bridge.eval(sx_text, ctx=ctx)
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
result = parsed[0] if parsed else None
|
||||
else:
|
||||
result = None
|
||||
return _normalize(result)
|
||||
|
||||
from .async_eval import async_eval
|
||||
|
||||
ctx = _get_request_context()
|
||||
result = await async_eval(action_def.body, env, ctx)
|
||||
return _normalize(result)
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user