Compare commits
474 Commits
architectu
...
loops/lua
| Author | SHA1 | Date | |
|---|---|---|---|
| dd47fa8a0b | |||
| fad44ca097 | |||
| 702e7c8eac | |||
| 73694a3a84 | |||
| b9b875f399 | |||
| f620be096b | |||
| 1b34d41b33 | |||
| fd32bcf547 | |||
| d170d5fbae | |||
| abc98b7665 | |||
| 77f20b713d | |||
| 0491f061c4 | |||
| 2a4a4531b9 | |||
| f89e50aa4d | |||
| e670e914e7 | |||
| bd0377b6a3 | |||
| 3ec52d4556 | |||
| fb18629916 | |||
| d8be6b8230 | |||
| e105edee01 | |||
| 27425a3173 | |||
| bac3471a1f | |||
| 68b0a279f8 | |||
| b1bed8e0e5 | |||
| 9560145228 | |||
| 9435fab790 | |||
| fc2baee9c7 | |||
| 12b02d5691 | |||
| 57516ce18e | |||
| 46741a9643 | |||
| 1d3a93b0ca | |||
| f0a4dfbea8 | |||
| 54d7fcf436 | |||
| d361d83402 | |||
| 0b0d704f1e | |||
| 5ea81fe4e0 | |||
| 781bd36eeb | |||
| 743e0bae87 | |||
| cf4d19fb94 | |||
| 24fde8aa2f | |||
| 582894121d | |||
| c6b7e19892 | |||
| 40439cf0e1 | |||
| 6dfef34a4b | |||
| 8c25527205 | |||
| a5947e1295 | |||
| 0934c4bd28 | |||
| e224fb2db0 | |||
| 43c13c4eb1 | |||
| 4815db461b | |||
| 3ab8474e78 | |||
| d925be4768 | |||
| 418a0dc120 | |||
| fe0fafe8e9 | |||
| 2b448d99bc | |||
| 8bfeff8623 | |||
| 30d76537d1 | |||
| d7070ee901 | |||
| e67852ca96 | |||
| 99753580b4 | |||
| e274878052 | |||
| a3d1c37c95 | |||
| 2b486976a6 | |||
| 6e92a5ad66 | |||
| 2cd8e57694 | |||
| 0f67021aa3 | |||
| 81022784bc | |||
| 4be90bf21f | |||
| b45a69b7a4 | |||
| 8f202e03c2 | |||
| d865c4d58d | |||
| 6c1da9212a | |||
| 30fca2dd19 | |||
| d7a88d85ae | |||
| 9db703324d | |||
| b2810db1a0 | |||
| 2af31248f2 | |||
| 81059861fd | |||
| 52fc87f222 | |||
| 2caf356fc4 | |||
| 67df95508d | |||
| 679d6bd590 | |||
| 6a4269d327 | |||
| ec0be48a00 | |||
| 83c9d60d72 | |||
| 00edae49e4 | |||
| bf09055c4e | |||
| f63934b15e | |||
| 05aef11bf5 | |||
| 7cffae2148 | |||
| dc97c17304 | |||
| 4a277941b6 | |||
| f14a257533 | |||
| 5875c97391 | |||
| c932ad59e1 | |||
| 4cc2e82091 | |||
| 0c31dd2735 | |||
| cee9ae7f22 | |||
| 1473e277fd | |||
| 304a52d2cf | |||
| 99c5911347 | |||
| 64bcefffdc | |||
| eb587bb3d0 | |||
| c3b0aef1f8 | |||
| 38e9376573 | |||
| 9da43877e8 | |||
| 3b5f16088b | |||
| cb37259d10 | |||
| 094945d86a | |||
| 1c0a71517c | |||
| ade87c0744 | |||
| 0d38a75b21 | |||
| 99706a91d1 | |||
| 3e1bca5435 | |||
| 9ea67b9422 | |||
| 85a329e8d6 | |||
| c22f553146 | |||
| edfbb75466 | |||
| 3aa8034a0b | |||
| 84b947024d | |||
| 60bb77d365 | |||
| 621a1ad947 | |||
| 88217ec612 | |||
| d294443627 | |||
| db7a3d10dd | |||
| fd73c43eba | |||
| 30ef085844 | |||
| d74344ffbd | |||
| d862efe811 | |||
| c4da069815 | |||
| 87cafaaa3f | |||
| 3587443742 | |||
| 6b7559fcaf | |||
| 67d4b9dae5 | |||
| df8913e9a1 | |||
| 4ee748bf42 | |||
| 320e948224 | |||
| 1b4b7effbd | |||
| f0c4127870 | |||
| a15c1d2cfb | |||
| 3c4d68575c | |||
| dda3becbab | |||
| baa5cd9341 | |||
| 00bb21ca13 | |||
| a82050e819 | |||
| c532dd57f1 | |||
| bb64e42570 | |||
| 3d35205533 | |||
| e155c21798 | |||
| e5346d5ea3 | |||
| 5f3a8e43c0 | |||
| 860549c1db | |||
| 0e22779fe0 | |||
| bd821c0445 | |||
| 16df723e08 | |||
| 9502d56a38 | |||
| 0474514e59 | |||
| 98c957b3bf | |||
| 92c1fc72a5 | |||
| 1774a900aa | |||
| dc1aaac35a | |||
| beb120baf7 | |||
| 65d4c70638 | |||
| 20a1a81d15 | |||
| ae999e3362 | |||
| 30f3334107 | |||
| bf78f2ecc8 | |||
| fda8846376 | |||
| f79f96c1c3 | |||
| e8a89a6ce2 | |||
| fe6cadd268 | |||
| c94b340943 | |||
| 64e53518ae | |||
| 6293a0fe70 | |||
| 27bd25843e | |||
| 0a3425ba18 | |||
| 9f9e4e1e9d | |||
| c5e2bc2fe1 | |||
| 835d42fd1a | |||
| d7ad7172aa | |||
| 1079004981 | |||
| c257971bb1 | |||
| 1459f7a637 | |||
| d6975d3c79 | |||
| 18ae63b0bd | |||
| 067c0ab34a | |||
| ed8d71c9b8 | |||
| 15c310cdc1 | |||
| dd6375af18 | |||
| 8268010a0a | |||
| ccf59a9882 | |||
| 5e682b01c6 | |||
| 41d0c65874 | |||
| 216c3c5e9d | |||
| f21eb00878 | |||
| 4800246b23 | |||
| b502b8f58e | |||
| 60bb7c4687 | |||
| 6fb65464ed | |||
| 5fe1c2c7d5 | |||
| 108e25d418 | |||
| babef2503f | |||
| 3efd527d4e | |||
| e7b8626498 | |||
| f113b45d48 | |||
| ee16e358f3 | |||
| 3279954234 | |||
| 4fe0b64965 | |||
| 9e92b9c9fc | |||
| b48dabf383 | |||
| e59c0b8e0a | |||
| 35c72e2a13 | |||
| 19e148d930 | |||
| 835025ec37 | |||
| e195b5bd72 | |||
| 94b47a4b2b | |||
| f3e1383466 | |||
| 39a597e9b6 | |||
| ebaec1659e | |||
| 6f0b4fb476 | |||
| 449b77cbb0 | |||
| 65dfd75865 | |||
| 2bd3a6b2ba | |||
| 9d3e54029a | |||
| 275d2ecbae | |||
| 6c4001a299 | |||
| e0531d730c | |||
| 608a5088a4 | |||
| ce46420c2e | |||
| 6b0334affe | |||
| 8984520f05 | |||
| 1613f551ef | |||
| 9e568ad886 | |||
| 14b6586e41 | |||
| 1cd81e5369 | |||
| 1213ee04c7 | |||
| a5f0325935 | |||
| 7ecdd59335 | |||
| d6137f0d6f | |||
| 5b31d935bd | |||
| e976d7c145 | |||
| f44a185230 | |||
| 601fdc1c34 | |||
| 3528cef35a | |||
| 5b100cac17 | |||
| b90aa54dd0 | |||
| 7330bc1a36 | |||
| adb06ed1fd | |||
| 19f5bf7d72 | |||
| e4773ec336 | |||
| 24dbc966e9 | |||
| dc194b05eb | |||
| 781e0d427a | |||
| 1bdd141178 | |||
| f8d30f50fb | |||
| a11d0941e9 | |||
| 0515295317 | |||
| b2ae80fb21 | |||
| 7329b1d242 | |||
| 7833fc2716 | |||
| fd1dfea9b3 | |||
| 802ccd23e8 | |||
| 5c66095b0f | |||
| 71cf5b8472 | |||
| 41cfa5621b | |||
| 5b0c8569a8 | |||
| ef5faa6b54 | |||
| ce7ad3eead | |||
| ebcb5348ba | |||
| 0a5066a75c | |||
| be3fbae584 | |||
| 7357988af6 | |||
| 5c42f4842b | |||
| 6528ce78b9 | |||
| bfe4727edf | |||
| a7da235459 | |||
| 1a9c8d61b5 | |||
| fc24cc704d | |||
| dd604f2bb1 | |||
| 9d246f5c96 | |||
| b23da3190e | |||
| 5a3bae5516 | |||
| 922e7a7892 | |||
| a876ac8a7f | |||
| 84f0af657a | |||
| c59070ad20 | |||
| c8aab54d52 | |||
| c25ab23709 | |||
| f200418d91 | |||
| 79b3fa3f26 | |||
| d0b3b86823 | |||
| dcbeb5cec5 | |||
| 7516d1e1f9 | |||
| 00bf13a230 | |||
| 06bed36272 | |||
| 5a0740d3ce | |||
| be84246961 | |||
| 3ba819d9ae | |||
| ac65666f6f | |||
| 9e0de8831f | |||
| d4f74b5b02 | |||
| f78a97960f | |||
| de90cd04f2 | |||
| 444cd1ea70 | |||
| b5387c069f | |||
| 673be85743 | |||
| f85004c8a2 | |||
| 84996d74e2 | |||
| db8e680caf | |||
| 0410812420 | |||
| ac193e8839 | |||
| 25db89a96c | |||
| 017451370f | |||
| cc9975aaf0 | |||
| b12ec746a2 | |||
| d8fec1305b | |||
| 112eed50d0 | |||
| b9c9216409 | |||
| f276c4a56a | |||
| aef92cc1f3 | |||
| 922c4de2d0 | |||
| c0b001d3c2 | |||
| bceccccedb | |||
| 0e152721cc | |||
| c641b445f8 | |||
| 0f9bb68ba2 | |||
| 15e593b725 | |||
| 8c85e892c2 | |||
| 76f7e3b68a | |||
| 97818c6de1 | |||
| 2285ea3e49 | |||
| ca9196a693 | |||
| d981e5f620 | |||
| 1bce1b701b | |||
| e12e84a4c7 | |||
| b86d0b7e15 | |||
| 133edd4c5e | |||
| 98fbd5cf40 | |||
| fec3194464 | |||
| 4981e9a32f | |||
| 6f374fabce | |||
| 87fdb1db71 | |||
| fc76a42403 | |||
| 6bd45daed6 | |||
| 8819d7cbd1 | |||
| faa65e15d8 | |||
| ca077b429b | |||
| c9634ba649 | |||
| 684a46297d | |||
| 1e42451252 | |||
| 4aa49e42e8 | |||
| 4f02f82f4e | |||
| a93e5924df | |||
| d6ae303db3 | |||
| 745e78ab05 | |||
| 8bf874c50c | |||
| e5e3e90ee7 | |||
| b1666a5fe2 | |||
| b81c26c45b | |||
| 23e8379622 | |||
| a6eb125dcc | |||
| e3eb46d0dc | |||
| 3d7fffe4eb | |||
| 1d83ccba3c | |||
| 2cba359fdf | |||
| d42717d4b9 | |||
| 75f1c04559 | |||
| fb93aaaa8c | |||
| 49afef6eef | |||
| eb060ef32c | |||
| d938682469 | |||
| 4cac08d56f | |||
| c05d8788c7 | |||
| eaf3c88a36 | |||
| e2fe070dd4 | |||
| e12ddefdff | |||
| da0da1472d | |||
| e5293e4e03 | |||
| 429c2b59f9 | |||
| 5948741fb6 | |||
| 564e344961 | |||
| 1884c28763 | |||
| 13f24e5f26 | |||
| e71e74941e | |||
| 7ec42386fb | |||
| 45209caf73 | |||
| 699dd5ad69 | |||
| 676ec6dd2b | |||
| 498f1a33b6 | |||
| 1eadefd0c1 | |||
| f60d22e86e | |||
| 1783f4805a | |||
| 7d798be14f | |||
| ae32254dfb | |||
| 854ed9c027 | |||
| 3dbbe7e1d1 | |||
| 56855eee7f | |||
| 6e27442d57 | |||
| 7aefe4da8f | |||
| d4c0be52b1 | |||
| 3cada3f8fe | |||
| c850737c60 | |||
| eaf5af4cd8 | |||
| ccd89dfa53 | |||
| 55a4fba58f | |||
| fc9c90b7b1 | |||
| ef8f8b7c03 | |||
| bca0d8e4e5 | |||
| 99c5c44cc1 | |||
| 36ae0384ae | |||
| 299f3e748d | |||
| 6e38a2e1e1 | |||
| 52e4d38852 | |||
| 5fe97d8481 | |||
| cfc7e74a56 | |||
| 08cd82ed65 | |||
| f97a1711c6 | |||
| e85de7d5cc | |||
| 1461919857 | |||
| ce4579badb | |||
| e98aedf803 | |||
| ab50c4516e | |||
| a2a4d17d53 | |||
| 89ffb02b20 | |||
| 0044f17e4c | |||
| 3d05efbb9b | |||
| 9c64d1d929 | |||
| 42198e4e22 | |||
| e6def8b6cd | |||
| 2805e0077b | |||
| 737964be89 | |||
| 23c88cd1e5 | |||
| 3329512bf8 | |||
| 79ba9c2d40 | |||
| 32fd3ef7d3 | |||
| 3b06299e4b | |||
| 42a7747d02 | |||
| 0a2d7768dd | |||
| fecfc71e5f | |||
| 0bed9e3664 | |||
| 9982cd5926 | |||
| cf10e9a2d6 | |||
| 0365ecb2b9 | |||
| de9ab4ca07 | |||
| c6df054957 | |||
| 7f273dc7c2 | |||
| 7492ceac4e | |||
| 908f4f80d4 | |||
| 981b6e7560 | |||
| 8e9dc4a623 | |||
| 5e708e1b20 | |||
| ddc48c6d48 | |||
| 52165f6a2a | |||
| 6456bd927a | |||
| 67d2f32512 | |||
| 7a1af7a80a | |||
| 4ca92960c4 | |||
| 34e7cb177c | |||
| 48c5ac6287 | |||
| 520424954b | |||
| c521ff8731 | |||
| aeaa8cb498 | |||
| a9066c0653 | |||
| 1f7f47b4c1 | |||
| 2278443182 | |||
| 71d1ac9ce4 | |||
| 33e8788781 | |||
| 23749773f2 | |||
| 783ffc2ddd | |||
| d715d8c4ac | |||
| 3155ba47f9 | |||
| 387a6cb49e | |||
| 4d1079aa5e | |||
| 03278c640d |
5
.gitignore
vendored
5
.gitignore
vendored
@@ -23,8 +23,13 @@ hosts/ocaml/test-results/
|
|||||||
shared/static/wasm/sx_browser.bc.wasm.assets/
|
shared/static/wasm/sx_browser.bc.wasm.assets/
|
||||||
.claude/worktrees/
|
.claude/worktrees/
|
||||||
tests/playwright/test-results/
|
tests/playwright/test-results/
|
||||||
|
test-results/
|
||||||
test-case-define.sx
|
test-case-define.sx
|
||||||
test-case-define.txt
|
test-case-define.txt
|
||||||
test_all.js
|
test_all.js
|
||||||
test_final.js
|
test_final.js
|
||||||
test_interactive.js
|
test_interactive.js
|
||||||
|
|
||||||
|
# Loop lock/log state
|
||||||
|
.loop-locks/
|
||||||
|
.loop-logs/
|
||||||
|
|||||||
@@ -8,6 +8,11 @@
|
|||||||
"type": "stdio",
|
"type": "stdio",
|
||||||
"command": "python3",
|
"command": "python3",
|
||||||
"args": ["tools/mcp_services.py"]
|
"args": ["tools/mcp_services.py"]
|
||||||
|
},
|
||||||
|
"hs-test": {
|
||||||
|
"type": "stdio",
|
||||||
|
"command": "python3",
|
||||||
|
"args": ["tools/mcp_hs_test.py"]
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
64
applications/graphql/spec.sx
Normal file
64
applications/graphql/spec.sx
Normal file
@@ -0,0 +1,64 @@
|
|||||||
|
|
||||||
|
;; GraphQL — SX language assimilation
|
||||||
|
;;
|
||||||
|
;; Pure SX implementation of the GraphQL query language.
|
||||||
|
;; Parser, executor, and serializer — all s-expressions,
|
||||||
|
;; compiled to bytecode by the same kernel.
|
||||||
|
;;
|
||||||
|
;; Files:
|
||||||
|
;; lib/graphql.sx — Tokenizer + recursive descent parser
|
||||||
|
;; lib/graphql-exec.sx — Executor (projection, fragments, variables)
|
||||||
|
;; spec/tests/test-graphql.sx — 66 tests across 15 suites
|
||||||
|
;;
|
||||||
|
;; Hyperscript integration:
|
||||||
|
;; fetch gql { query { ... } } — shorthand query
|
||||||
|
;; fetch gql mutation { ... } — mutation
|
||||||
|
;; fetch gql { ... } from "/endpoint" — custom endpoint
|
||||||
|
;;
|
||||||
|
;; Maps to existing SX infrastructure:
|
||||||
|
;; Query → defquery (IO suspension)
|
||||||
|
;; Mutation → defaction (IO suspension)
|
||||||
|
;; Subscription → SSE + signals (reactive islands)
|
||||||
|
;; Fragment → defcomp (component composition)
|
||||||
|
;; Schema → spec/types.sx (gradual type system)
|
||||||
|
;; Resolver → perform (CEK IO suspension)
|
||||||
|
|
||||||
|
(define graphql-version "0.1.0")
|
||||||
|
|
||||||
|
(define
|
||||||
|
graphql-features
|
||||||
|
(quote
|
||||||
|
(queries
|
||||||
|
mutations
|
||||||
|
subscriptions
|
||||||
|
fragments
|
||||||
|
inline-fragments
|
||||||
|
fragment-spreads
|
||||||
|
variables
|
||||||
|
variable-defaults
|
||||||
|
directives
|
||||||
|
directive-arguments
|
||||||
|
aliases
|
||||||
|
field-arguments
|
||||||
|
object-values
|
||||||
|
list-values
|
||||||
|
enum-values
|
||||||
|
block-strings
|
||||||
|
comments
|
||||||
|
field-projection
|
||||||
|
nested-projection
|
||||||
|
list-projection
|
||||||
|
variable-substitution
|
||||||
|
fragment-resolution
|
||||||
|
custom-resolvers
|
||||||
|
default-io-resolver
|
||||||
|
aliased-execution
|
||||||
|
multi-root-fields
|
||||||
|
named-operations
|
||||||
|
operation-introspection
|
||||||
|
ast-to-source
|
||||||
|
round-trip
|
||||||
|
fetch-gql
|
||||||
|
fetch-gql-from
|
||||||
|
fetch-gql-mutation
|
||||||
|
fetch-gql-query)))
|
||||||
@@ -1,6 +1,6 @@
|
|||||||
(executables
|
(executables
|
||||||
(names run_tests debug_set sx_server integration_tests)
|
(names run_tests debug_set sx_server integration_tests)
|
||||||
(libraries sx unix))
|
(libraries sx unix threads.posix otfm yojson))
|
||||||
|
|
||||||
(executable
|
(executable
|
||||||
(name mcp_tree)
|
(name mcp_tree)
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -257,6 +257,7 @@ let closure_code cl = let c = unwrap_closure cl in
|
|||||||
Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
|
Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
|
||||||
Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
|
Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
|
||||||
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
|
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
|
||||||
|
Hashtbl.replace d "vc-rest-arity" (Number (float_of_int c.vm_code.vc_rest_arity));
|
||||||
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
|
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
|
||||||
Dict d
|
Dict d
|
||||||
|
|
||||||
@@ -376,7 +377,7 @@ let vm_create_closure vm_val frame_val code_val =
|
|||||||
|
|
||||||
(* --- JIT sentinel --- *)
|
(* --- JIT sentinel --- *)
|
||||||
let _jit_failed_sentinel = {
|
let _jit_failed_sentinel = {
|
||||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
||||||
vc_bytecode_list = None; vc_constants_list = None };
|
vc_bytecode_list = None; vc_constants_list = None };
|
||||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -35,4 +35,7 @@ cp -r dist/sx_browser.bc.wasm.assets ./ 2>/dev/null || true
|
|||||||
echo "=== 5. Run WASM tests ==="
|
echo "=== 5. Run WASM tests ==="
|
||||||
node test_wasm_native.js
|
node test_wasm_native.js
|
||||||
|
|
||||||
|
echo "=== 6. Run bytecode regression tests ==="
|
||||||
|
node test_bytecode_repeat.js
|
||||||
|
|
||||||
echo "=== Done ==="
|
echo "=== Done ==="
|
||||||
|
|||||||
@@ -71,6 +71,11 @@ cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/"
|
|||||||
cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/"
|
cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/"
|
||||||
cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
|
cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
|
||||||
|
|
||||||
|
# 10. Hyperscript
|
||||||
|
for f in tokenizer parser compiler runtime integration htmx; do
|
||||||
|
cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"
|
||||||
|
done
|
||||||
|
|
||||||
# Summary
|
# Summary
|
||||||
WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)
|
WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)
|
||||||
JS_SIZE=$(du -sh "$DIST/sx_browser.bc.js" | cut -f1)
|
JS_SIZE=$(du -sh "$DIST/sx_browser.bc.js" | cut -f1)
|
||||||
|
|||||||
@@ -47,6 +47,7 @@ const SOURCE_MAP = {
|
|||||||
'engine.sx': 'web/engine.sx', 'orchestration.sx': 'web/orchestration.sx',
|
'engine.sx': 'web/engine.sx', 'orchestration.sx': 'web/orchestration.sx',
|
||||||
'boot.sx': 'web/boot.sx',
|
'boot.sx': 'web/boot.sx',
|
||||||
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
|
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
|
||||||
|
'text-layout.sx': 'lib/text-layout.sx',
|
||||||
};
|
};
|
||||||
let synced = 0;
|
let synced = 0;
|
||||||
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
|
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
|
||||||
@@ -79,8 +80,13 @@ const FILES = [
|
|||||||
'page-helpers.sx', 'freeze.sx', 'bytecode.sx', 'compiler.sx', 'vm.sx',
|
'page-helpers.sx', 'freeze.sx', 'bytecode.sx', 'compiler.sx', 'vm.sx',
|
||||||
'dom.sx', 'browser.sx', 'adapter-html.sx', 'adapter-sx.sx', 'adapter-dom.sx',
|
'dom.sx', 'browser.sx', 'adapter-html.sx', 'adapter-sx.sx', 'adapter-dom.sx',
|
||||||
'tw-layout.sx', 'tw-type.sx', 'tw.sx',
|
'tw-layout.sx', 'tw-type.sx', 'tw.sx',
|
||||||
|
'text-layout.sx',
|
||||||
'boot-helpers.sx', 'hypersx.sx', 'harness.sx', 'harness-reactive.sx',
|
'boot-helpers.sx', 'hypersx.sx', 'harness.sx', 'harness-reactive.sx',
|
||||||
'harness-web.sx', 'engine.sx', 'orchestration.sx', 'boot.sx',
|
'harness-web.sx', 'engine.sx', 'orchestration.sx',
|
||||||
|
// Hyperscript modules — loaded on demand via transparent lazy loader
|
||||||
|
'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
|
||||||
|
'hs-integration.sx', 'hs-htmx.sx',
|
||||||
|
'boot.sx',
|
||||||
];
|
];
|
||||||
|
|
||||||
|
|
||||||
@@ -122,36 +128,102 @@ for (const file of FILES) {
|
|||||||
// ---------------------------------------------------------------------------
|
// ---------------------------------------------------------------------------
|
||||||
|
|
||||||
function stripLibraryWrapper(source) {
|
function stripLibraryWrapper(source) {
|
||||||
// Line-based stripping: unwrap (define-library ... (begin BODY)), keep (import ...).
|
// Paren-aware stripping: find (begin ...) inside (define-library ...), extract body.
|
||||||
const lines = source.split('\n');
|
// Keep top-level (import ...) forms outside the define-library.
|
||||||
const result = [];
|
|
||||||
let skip = false; // inside header region (define-library, export)
|
|
||||||
|
|
||||||
for (let i = 0; i < lines.length; i++) {
|
// Find (define-library at the start
|
||||||
const line = lines[i];
|
const dlMatch = source.match(/^[\s\S]*?\(define-library\b/);
|
||||||
const trimmed = line.trim();
|
if (!dlMatch) return source; // no define-library, return as-is
|
||||||
|
|
||||||
// Skip (define-library ...) header lines until (begin
|
// Find the (begin that opens the body — skip past (export ...) using paren counting
|
||||||
if (trimmed.startsWith('(define-library ')) { skip = true; continue; }
|
const afterDL = dlMatch[0].length;
|
||||||
if (skip && trimmed.startsWith('(export')) { continue; }
|
let pos = afterDL;
|
||||||
if (skip && trimmed.match(/^\(begin/)) { skip = false; continue; }
|
let foundBegin = -1;
|
||||||
if (skip) continue;
|
|
||||||
|
|
||||||
// Skip closing )) of define-library — line is just ) or )) optionally with comments
|
while (pos < source.length) {
|
||||||
if (trimmed.match(/^\)+(\s*;.*)?$/)) {
|
// Skip whitespace and comments
|
||||||
// Check if this is the end-of-define-library closer (only `)` chars + optional comment)
|
while (pos < source.length && /[\s]/.test(source[pos])) pos++;
|
||||||
// vs a regular body closer like ` )` inside a nested form
|
if (pos >= source.length) break;
|
||||||
// Only skip if at column 0 (not indented = top-level closer)
|
if (source[pos] === ';') { // skip comment line
|
||||||
if (line.match(/^\)/)) continue;
|
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||||
|
continue;
|
||||||
}
|
}
|
||||||
|
|
||||||
// Skip standalone comments that are just structural markers
|
// Check for (begin
|
||||||
if (trimmed.match(/^;;\s*(end define-library|Re-export)/)) continue;
|
if (source.startsWith('(begin', pos)) {
|
||||||
|
foundBegin = pos;
|
||||||
result.push(line);
|
break;
|
||||||
}
|
}
|
||||||
|
|
||||||
return result.join('\n');
|
// Skip balanced sexp (the library name and export list)
|
||||||
|
if (source[pos] === '(') {
|
||||||
|
let depth = 1;
|
||||||
|
pos++;
|
||||||
|
while (pos < source.length && depth > 0) {
|
||||||
|
if (source[pos] === '(') depth++;
|
||||||
|
else if (source[pos] === ')') depth--;
|
||||||
|
else if (source[pos] === '"') { // skip strings
|
||||||
|
pos++;
|
||||||
|
while (pos < source.length && source[pos] !== '"') {
|
||||||
|
if (source[pos] === '\\') pos++;
|
||||||
|
pos++;
|
||||||
|
}
|
||||||
|
} else if (source[pos] === ';') { // skip comments
|
||||||
|
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
pos++;
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
// Skip atom
|
||||||
|
while (pos < source.length && !/[\s()]/.test(source[pos])) pos++;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (foundBegin === -1) return source; // no (begin found
|
||||||
|
|
||||||
|
// Find the body inside (begin ...) — skip "(begin" + optional whitespace
|
||||||
|
let bodyStart = foundBegin + 6; // len("(begin") = 6
|
||||||
|
// Skip optional newline/whitespace after (begin
|
||||||
|
while (bodyStart < source.length && /[\s]/.test(source[bodyStart])) bodyStart++;
|
||||||
|
|
||||||
|
// Find matching close of (begin ...) using paren counting from foundBegin
|
||||||
|
pos = foundBegin + 1; // after opening (
|
||||||
|
let depth = 1;
|
||||||
|
while (pos < source.length && depth > 0) {
|
||||||
|
if (source[pos] === '(') depth++;
|
||||||
|
else if (source[pos] === ')') depth--;
|
||||||
|
else if (source[pos] === '"') {
|
||||||
|
pos++;
|
||||||
|
while (pos < source.length && source[pos] !== '"') {
|
||||||
|
if (source[pos] === '\\') pos++;
|
||||||
|
pos++;
|
||||||
|
}
|
||||||
|
} else if (source[pos] === ';') {
|
||||||
|
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
if (depth > 0) pos++;
|
||||||
|
}
|
||||||
|
const beginClose = pos; // position of closing ) for (begin ...)
|
||||||
|
|
||||||
|
// Extract body (everything between (begin and its closing paren)
|
||||||
|
const body = source.slice(bodyStart, beginClose);
|
||||||
|
|
||||||
|
// Find any (import ...) forms AFTER the define-library
|
||||||
|
// The define-library's closing paren is right after begin's
|
||||||
|
let dlClose = beginClose + 1;
|
||||||
|
while (dlClose < source.length && source[dlClose] !== ')') {
|
||||||
|
if (source[dlClose] === ';') {
|
||||||
|
while (dlClose < source.length && source[dlClose] !== '\n') dlClose++;
|
||||||
|
}
|
||||||
|
dlClose++;
|
||||||
|
}
|
||||||
|
dlClose++; // past the closing )
|
||||||
|
|
||||||
|
const afterDLForm = source.slice(dlClose);
|
||||||
|
|
||||||
|
return body + '\n' + afterDLForm;
|
||||||
}
|
}
|
||||||
|
|
||||||
// Compile each module (stripped of define-library/import wrappers)
|
// Compile each module (stripped of define-library/import wrappers)
|
||||||
@@ -339,6 +411,18 @@ function libKey(spec) {
|
|||||||
return spec.replace(/^\(/, '').replace(/\)$/, '');
|
return spec.replace(/^\(/, '').replace(/\)$/, '');
|
||||||
}
|
}
|
||||||
|
|
||||||
|
// Extract top-level (define name ...) symbols from a non-library file
|
||||||
|
function extractDefines(source) {
|
||||||
|
const names = [];
|
||||||
|
const re = /^\(define\s+(\S+)/gm;
|
||||||
|
let m;
|
||||||
|
while ((m = re.exec(source)) !== null) {
|
||||||
|
const name = m[1];
|
||||||
|
if (name && !name.startsWith('(') && !name.startsWith(':')) names.push(name);
|
||||||
|
}
|
||||||
|
return names;
|
||||||
|
}
|
||||||
|
|
||||||
const manifest = {};
|
const manifest = {};
|
||||||
let entryFile = null;
|
let entryFile = null;
|
||||||
|
|
||||||
@@ -360,6 +444,26 @@ for (const file of FILES) {
|
|||||||
} else if (deps.length > 0) {
|
} else if (deps.length > 0) {
|
||||||
// Entry point (no define-library, has imports)
|
// Entry point (no define-library, has imports)
|
||||||
entryFile = { file: sxbcFile, deps: deps.map(libKey) };
|
entryFile = { file: sxbcFile, deps: deps.map(libKey) };
|
||||||
|
} else {
|
||||||
|
// Non-library file (e.g. hyperscript modules) — extract top-level defines
|
||||||
|
// as exports so the transparent lazy loader can resolve symbols to files.
|
||||||
|
const defines = extractDefines(src);
|
||||||
|
if (defines.length > 0) {
|
||||||
|
const key = file.replace(/\.sx$/, '');
|
||||||
|
// HS modules form a dependency chain — loading one loads all predecessors.
|
||||||
|
const HS_DEPS = {
|
||||||
|
'hs-parser': ['hs-tokenizer'],
|
||||||
|
'hs-compiler': ['hs-tokenizer', 'hs-parser'],
|
||||||
|
'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
|
||||||
|
'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
|
||||||
|
'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
|
||||||
|
};
|
||||||
|
manifest[key] = {
|
||||||
|
file: sxbcFile,
|
||||||
|
deps: HS_DEPS[key] || [],
|
||||||
|
exports: defines,
|
||||||
|
};
|
||||||
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -371,6 +475,16 @@ if (entryFile) {
|
|||||||
]);
|
]);
|
||||||
const eagerDeps = entryFile.deps.filter(d => !LAZY_ENTRY_DEPS.has(d));
|
const eagerDeps = entryFile.deps.filter(d => !LAZY_ENTRY_DEPS.has(d));
|
||||||
const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
|
const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
|
||||||
|
// Hyperscript modules aren't define-library, so not auto-detected as deps.
|
||||||
|
// Load them lazily after boot — eager loading breaks the boot sequence.
|
||||||
|
const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx'];
|
||||||
|
for (const m of HS_LAZY) {
|
||||||
|
if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
|
||||||
|
}
|
||||||
|
// Text layout library — loaded eagerly for Pretext island
|
||||||
|
if (manifest['sx text-layout'] && !eagerDeps.includes('sx text-layout')) {
|
||||||
|
eagerDeps.push('sx text-layout');
|
||||||
|
}
|
||||||
manifest['_entry'] = {
|
manifest['_entry'] = {
|
||||||
file: entryFile.file,
|
file: entryFile.file,
|
||||||
deps: eagerDeps,
|
deps: eagerDeps,
|
||||||
|
|||||||
@@ -40,7 +40,12 @@
|
|||||||
var obj = args[0], prop = args[1];
|
var obj = args[0], prop = args[1];
|
||||||
if (obj == null) return null;
|
if (obj == null) return null;
|
||||||
var v = obj[prop];
|
var v = obj[prop];
|
||||||
return v === undefined ? null : v;
|
if (v === undefined) return null;
|
||||||
|
// Functions can't cross the WASM boundary — return true as a truthy
|
||||||
|
// sentinel so (host-get el "getAttribute") works as a guard.
|
||||||
|
// Use host-call to actually invoke the method.
|
||||||
|
if (typeof v === "function") return true;
|
||||||
|
return v;
|
||||||
});
|
});
|
||||||
|
|
||||||
K.registerNative("host-set!", function(args) {
|
K.registerNative("host-set!", function(args) {
|
||||||
@@ -79,16 +84,87 @@
|
|||||||
}
|
}
|
||||||
});
|
});
|
||||||
|
|
||||||
|
// IO suspension driver — resumes suspended callFn results (wait, fetch, etc.)
|
||||||
|
if (!window._driveAsync) {
|
||||||
|
window._driveAsync = function driveAsync(result) {
|
||||||
|
if (!result || !result.suspended) return;
|
||||||
|
var req = result.request;
|
||||||
|
var items = req && (req.items || req);
|
||||||
|
var op = items && items[0];
|
||||||
|
var opName = typeof op === "string" ? op : (op && op.name) || String(op);
|
||||||
|
var arg = items && items[1];
|
||||||
|
if (opName === "io-sleep" || opName === "wait") {
|
||||||
|
setTimeout(function() {
|
||||||
|
try { driveAsync(result.resume(null)); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||||
|
}, typeof arg === "number" ? arg : 0);
|
||||||
|
} else if (opName === "io-fetch") {
|
||||||
|
var fetchUrl = typeof arg === "string" ? arg : "";
|
||||||
|
var fetchMethod = (items && items[2]) || "GET";
|
||||||
|
var fetchBody = items && items[3];
|
||||||
|
var fetchHeaders = items && items[4];
|
||||||
|
var fetchOpts = { method: typeof fetchMethod === "string" ? fetchMethod : "GET" };
|
||||||
|
if (fetchBody && typeof fetchBody !== "boolean") {
|
||||||
|
fetchOpts.body = typeof fetchBody === "string" ? fetchBody : JSON.stringify(fetchBody);
|
||||||
|
}
|
||||||
|
if (fetchHeaders && typeof fetchHeaders === "object") {
|
||||||
|
var h = {};
|
||||||
|
var keys = fetchHeaders._keys || Object.keys(fetchHeaders);
|
||||||
|
for (var fi = 0; fi < keys.length; fi++) {
|
||||||
|
var k = keys[fi], v = fetchHeaders[k];
|
||||||
|
if (typeof k === "string" && typeof v === "string") h[k] = v;
|
||||||
|
}
|
||||||
|
fetchOpts.headers = h;
|
||||||
|
}
|
||||||
|
fetch(fetchUrl, fetchOpts).then(function(r) {
|
||||||
|
var hdrs = {};
|
||||||
|
try { r.headers.forEach(function(v, k) { hdrs[k] = v; }); } catch(e) {}
|
||||||
|
return r.text().then(function(t) {
|
||||||
|
return { status: r.status, body: t, headers: hdrs, ok: r.ok };
|
||||||
|
});
|
||||||
|
}).then(function(resp) {
|
||||||
|
try { driveAsync(result.resume(resp)); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||||
|
}).catch(function(e) {
|
||||||
|
try { driveAsync(result.resume({status: 0, body: "", headers: {}, ok: false})); } catch(e2) { console.error("[sx] driveAsync:", e2.message); }
|
||||||
|
});
|
||||||
|
} else if (opName === "io-navigate") {
|
||||||
|
// navigation — don't resume
|
||||||
|
} else if (opName === "text-measure") {
|
||||||
|
// Pretext: measure text using offscreen canvas
|
||||||
|
var font = arg;
|
||||||
|
var size = items && items[2];
|
||||||
|
var text = items && items[3];
|
||||||
|
var canvas = document.createElement("canvas");
|
||||||
|
var ctx = canvas.getContext("2d");
|
||||||
|
ctx.font = (size || 16) + "px " + (font || "serif");
|
||||||
|
var m = ctx.measureText(text || "");
|
||||||
|
try {
|
||||||
|
driveAsync(result.resume({
|
||||||
|
width: m.width,
|
||||||
|
height: m.actualBoundingBoxAscent + m.actualBoundingBoxDescent,
|
||||||
|
ascent: m.actualBoundingBoxAscent,
|
||||||
|
descent: m.actualBoundingBoxDescent
|
||||||
|
}));
|
||||||
|
} catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||||
|
} else {
|
||||||
|
console.warn("[sx] unhandled IO:", opName);
|
||||||
|
}
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
K.registerNative("host-callback", function(args) {
|
K.registerNative("host-callback", function(args) {
|
||||||
var fn = args[0];
|
var fn = args[0];
|
||||||
// Native JS function — pass through
|
// Native JS function — pass through
|
||||||
if (typeof fn === "function") return fn;
|
if (typeof fn === "function") return fn;
|
||||||
// SX callable (has __sx_handle) — wrap as JS function
|
// SX callable (has __sx_handle) — wrap as JS function
|
||||||
if (fn && fn.__sx_handle !== undefined) {
|
if (fn && fn.__sx_handle !== undefined) {
|
||||||
return function() {
|
var wrappedFn = function() {
|
||||||
var a = Array.prototype.slice.call(arguments);
|
var a = Array.prototype.slice.call(arguments);
|
||||||
return K.callFn(fn, a);
|
var r = K.callFn(fn, a);
|
||||||
|
if (window._driveAsync) window._driveAsync(r);
|
||||||
|
return r;
|
||||||
};
|
};
|
||||||
|
wrappedFn.__host_callback = true;
|
||||||
|
return wrappedFn;
|
||||||
}
|
}
|
||||||
return function() {};
|
return function() {};
|
||||||
});
|
});
|
||||||
@@ -223,6 +299,11 @@
|
|||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
// Content-addressed boot: script loaded from /sx/h/{hash}, not /static/wasm/.
|
||||||
|
// Fall back to /static/wasm/ base URL for module-manifest.sx and .sx sources.
|
||||||
|
if (!_baseUrl || _baseUrl.indexOf("/sx/h/") !== -1) {
|
||||||
|
_baseUrl = "/static/wasm/";
|
||||||
|
}
|
||||||
}
|
}
|
||||||
})();
|
})();
|
||||||
|
|
||||||
@@ -301,19 +382,56 @@
|
|||||||
/**
|
/**
|
||||||
* Try loading a pre-compiled .sxbc bytecode module (SX text format).
|
* Try loading a pre-compiled .sxbc bytecode module (SX text format).
|
||||||
* Uses K.loadModule which handles VM suspension (import requests).
|
* Uses K.loadModule which handles VM suspension (import requests).
|
||||||
|
* Content-addressed: checks localStorage by hash, fetches /sx/h/{hash} on miss.
|
||||||
* Returns true on success, null on failure (caller falls back to .sx source).
|
* Returns true on success, null on failure (caller falls back to .sx source).
|
||||||
*/
|
*/
|
||||||
function loadBytecodeFile(path) {
|
function loadBytecodeFile(path) {
|
||||||
var sxbcPath = path.replace(/\.sx$/, '.sxbc');
|
var sxbcPath = path.replace(/\.sx$/, '.sxbc');
|
||||||
|
var sxbcFile = sxbcPath.split('/').pop(); // e.g. "dom.sxbc"
|
||||||
|
|
||||||
|
// Content-addressed resolution: manifest → localStorage → fetch by hash
|
||||||
|
var text = null;
|
||||||
|
var manifest = loadPageManifest();
|
||||||
|
if (manifest && manifest.modules && manifest.modules[sxbcFile]) {
|
||||||
|
var hash = manifest.modules[sxbcFile];
|
||||||
|
var lsKey = "sx:h:" + hash;
|
||||||
|
try {
|
||||||
|
text = localStorage.getItem(lsKey);
|
||||||
|
} catch(e) {}
|
||||||
|
if (!text) {
|
||||||
|
// Fetch by content hash
|
||||||
|
try {
|
||||||
|
var xhr2 = new XMLHttpRequest();
|
||||||
|
xhr2.open("GET", "/sx/h/" + hash, false);
|
||||||
|
xhr2.send();
|
||||||
|
if (xhr2.status === 200) {
|
||||||
|
text = xhr2.responseText;
|
||||||
|
// Strip comment line if present
|
||||||
|
if (text.charAt(0) === ';') {
|
||||||
|
var nl = text.indexOf('\n');
|
||||||
|
if (nl >= 0) text = text.substring(nl + 1);
|
||||||
|
}
|
||||||
|
try { localStorage.setItem(lsKey, text); } catch(e) {}
|
||||||
|
}
|
||||||
|
} catch(e) {}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Fallback: fetch by URL (pre-content-addressed path)
|
||||||
|
if (!text) {
|
||||||
var url = _baseUrl + sxbcPath + _sxbcCacheBust;
|
var url = _baseUrl + sxbcPath + _sxbcCacheBust;
|
||||||
try {
|
try {
|
||||||
var xhr = new XMLHttpRequest();
|
var xhr = new XMLHttpRequest();
|
||||||
xhr.open("GET", url, false);
|
xhr.open("GET", url, false);
|
||||||
xhr.send();
|
xhr.send();
|
||||||
if (xhr.status !== 200) return null;
|
if (xhr.status !== 200) return null;
|
||||||
|
text = xhr.responseText;
|
||||||
|
} catch(e) { return null; }
|
||||||
|
}
|
||||||
|
|
||||||
|
try {
|
||||||
// Parse the sxbc text to get the SX tree
|
// Parse the sxbc text to get the SX tree
|
||||||
var parsed = K.parse(xhr.responseText);
|
var parsed = K.parse(text);
|
||||||
if (!parsed || !parsed.length) return null;
|
if (!parsed || !parsed.length) return null;
|
||||||
var sxbc = parsed[0]; // (sxbc version hash (code ...))
|
var sxbc = parsed[0]; // (sxbc version hash (code ...))
|
||||||
if (!sxbc || sxbc._type !== "list" || !sxbc.items) return null;
|
if (!sxbc || sxbc._type !== "list" || !sxbc.items) return null;
|
||||||
@@ -431,6 +549,22 @@
|
|||||||
var _manifest = null;
|
var _manifest = null;
|
||||||
var _loadedLibs = {};
|
var _loadedLibs = {};
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Convert K.parse output (tagged {_type, ...} objects) to plain JS.
|
||||||
|
* SX nil (from empty lists `()`) becomes [].
|
||||||
|
*/
|
||||||
|
function sxDataToJs(v) {
|
||||||
|
if (v === null || v === undefined) return [];
|
||||||
|
if (typeof v !== "object") return v;
|
||||||
|
if (v._type === "list") return (v.items || []).map(sxDataToJs);
|
||||||
|
if (v._type === "dict") {
|
||||||
|
var out = {};
|
||||||
|
for (var k in v) if (k !== "_type") out[k] = sxDataToJs(v[k]);
|
||||||
|
return out;
|
||||||
|
}
|
||||||
|
return v;
|
||||||
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Fetch and parse the module manifest (library deps + file paths).
|
* Fetch and parse the module manifest (library deps + file paths).
|
||||||
*/
|
*/
|
||||||
@@ -438,12 +572,15 @@
|
|||||||
if (_manifest) return _manifest;
|
if (_manifest) return _manifest;
|
||||||
try {
|
try {
|
||||||
var xhr = new XMLHttpRequest();
|
var xhr = new XMLHttpRequest();
|
||||||
xhr.open("GET", _baseUrl + "sx/module-manifest.json" + _cacheBust, false);
|
xhr.open("GET", _baseUrl + "sx/module-manifest.sx" + _cacheBust, false);
|
||||||
xhr.send();
|
xhr.send();
|
||||||
if (xhr.status === 200) {
|
if (xhr.status === 200) {
|
||||||
_manifest = JSON.parse(xhr.responseText);
|
var parsed = K.parse(xhr.responseText);
|
||||||
|
if (parsed && parsed.length > 0) {
|
||||||
|
_manifest = sxDataToJs(parsed[0]);
|
||||||
return _manifest;
|
return _manifest;
|
||||||
}
|
}
|
||||||
|
}
|
||||||
} catch(e) {}
|
} catch(e) {}
|
||||||
console.warn("[sx-platform] No manifest found, falling back to full load");
|
console.warn("[sx-platform] No manifest found, falling back to full load");
|
||||||
return null;
|
return null;
|
||||||
@@ -474,7 +611,7 @@
|
|||||||
// will see it as already loaded and skip rather than infinite-looping.
|
// will see it as already loaded and skip rather than infinite-looping.
|
||||||
_loadedLibs[name] = true;
|
_loadedLibs[name] = true;
|
||||||
|
|
||||||
// Load this module
|
// Load this module (bytecode first, fallback to source)
|
||||||
var ok = loadBytecodeFile("sx/" + info.file);
|
var ok = loadBytecodeFile("sx/" + info.file);
|
||||||
if (!ok) {
|
if (!ok) {
|
||||||
var sxFile = info.file.replace(/\.sxbc$/, '.sx');
|
var sxFile = info.file.replace(/\.sxbc$/, '.sx');
|
||||||
@@ -577,10 +714,201 @@
|
|||||||
return _symbolIndex;
|
return _symbolIndex;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Content-addressed definition loader
|
||||||
|
//
|
||||||
|
// The page manifest maps component names to content hashes.
|
||||||
|
// When a ~component symbol is missing, we resolve its hash,
|
||||||
|
// check localStorage, fetch from /sx/h/{hash} if needed,
|
||||||
|
// then load the definition (recursively resolving @h: deps).
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
var _pageManifest = null; // { defs: { "~name": "hash", ... } }
|
||||||
|
var _hashToName = {}; // hash → "~name"
|
||||||
|
var _hashCache = {}; // hash → definition text (in-memory)
|
||||||
|
var _loadedHashes = {}; // hash → true (already K.load'd)
|
||||||
|
|
||||||
|
function loadPageManifest() {
|
||||||
|
if (_pageManifest) return _pageManifest;
|
||||||
|
var el = document.querySelector('script[data-sx-manifest]');
|
||||||
|
if (!el) return null;
|
||||||
|
try {
|
||||||
|
_pageManifest = JSON.parse(el.textContent);
|
||||||
|
var defs = _pageManifest.defs || {};
|
||||||
|
for (var name in defs) {
|
||||||
|
_hashToName[defs[name]] = name;
|
||||||
|
}
|
||||||
|
return _pageManifest;
|
||||||
|
} catch(e) {
|
||||||
|
console.warn("[sx] Failed to parse manifest:", e);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Merge definitions from a new page's manifest (called during navigation)
|
||||||
|
function mergeManifest(el) {
|
||||||
|
if (!el) return;
|
||||||
|
try {
|
||||||
|
var incoming = JSON.parse(el.textContent);
|
||||||
|
var newDefs = incoming.defs || {};
|
||||||
|
// Ensure base manifest is loaded
|
||||||
|
if (!_pageManifest) loadPageManifest();
|
||||||
|
if (!_pageManifest) _pageManifest = { defs: {} };
|
||||||
|
if (!_pageManifest.defs) _pageManifest.defs = {};
|
||||||
|
for (var name in newDefs) {
|
||||||
|
_pageManifest.defs[name] = newDefs[name];
|
||||||
|
_hashToName[newDefs[name]] = name;
|
||||||
|
}
|
||||||
|
// Merge hash store entries
|
||||||
|
if (incoming.store) {
|
||||||
|
if (!_pageManifest.store) _pageManifest.store = {};
|
||||||
|
for (var h in incoming.store) {
|
||||||
|
_pageManifest.store[h] = incoming.store[h];
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} catch(e) {
|
||||||
|
console.warn("[sx] Failed to merge manifest:", e);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
function resolveHash(hash) {
|
||||||
|
// 1. In-memory cache
|
||||||
|
if (_hashCache[hash]) return _hashCache[hash];
|
||||||
|
// 2. localStorage
|
||||||
|
var key = "sx:h:" + hash;
|
||||||
|
try {
|
||||||
|
var cached = localStorage.getItem(key);
|
||||||
|
if (cached) {
|
||||||
|
_hashCache[hash] = cached;
|
||||||
|
return cached;
|
||||||
|
}
|
||||||
|
} catch(e) {}
|
||||||
|
// 3. Fetch from server
|
||||||
|
try {
|
||||||
|
var xhr = new XMLHttpRequest();
|
||||||
|
xhr.open("GET", "/sx/h/" + hash, false);
|
||||||
|
xhr.send();
|
||||||
|
if (xhr.status === 200) {
|
||||||
|
var def = xhr.responseText;
|
||||||
|
_hashCache[hash] = def;
|
||||||
|
try { localStorage.setItem(key, def); } catch(e) {}
|
||||||
|
return def;
|
||||||
|
}
|
||||||
|
} catch(e) {
|
||||||
|
console.warn("[sx] Failed to fetch hash " + hash + ":", e);
|
||||||
|
}
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
|
||||||
|
function loadDefinitionByHash(hash) {
|
||||||
|
if (_loadedHashes[hash]) return true;
|
||||||
|
// Mark in-progress immediately to prevent circular recursion
|
||||||
|
_loadedHashes[hash] = "loading";
|
||||||
|
var def = resolveHash(hash);
|
||||||
|
if (!def) { delete _loadedHashes[hash]; return false; }
|
||||||
|
|
||||||
|
// Strip comment line (;; ~name\n) from start
|
||||||
|
var src = def;
|
||||||
|
if (src.charAt(0) === ';') {
|
||||||
|
var nl = src.indexOf('\n');
|
||||||
|
if (nl >= 0) src = src.substring(nl + 1);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Find and recursively load @h: dependencies before loading this one
|
||||||
|
var hashRe = /@h:([0-9a-f]{16})/g;
|
||||||
|
var match;
|
||||||
|
while ((match = hashRe.exec(src)) !== null) {
|
||||||
|
var depHash = match[1];
|
||||||
|
if (!_loadedHashes[depHash]) {
|
||||||
|
loadDefinitionByHash(depHash);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Rewrite @h:xxx back to ~names for the SX evaluator
|
||||||
|
var rewritten = src.replace(/@h:([0-9a-f]{16})/g, function(_m, h) {
|
||||||
|
return _hashToName[h] || ("@h:" + h);
|
||||||
|
});
|
||||||
|
|
||||||
|
// Eagerly pre-load any plain manifest symbols referenced in this definition.
|
||||||
|
// The CEK evaluator doesn't call __resolve-symbol, so deps must be present
|
||||||
|
// before the definition is called. Scan for word boundaries matching manifest keys.
|
||||||
|
if (_pageManifest && _pageManifest.defs) {
|
||||||
|
var words = rewritten.match(/[a-zA-Z_][a-zA-Z0-9_?!-]*/g) || [];
|
||||||
|
for (var wi = 0; wi < words.length; wi++) {
|
||||||
|
var w = words[wi];
|
||||||
|
if (w !== name && _pageManifest.defs[w] && !_loadedHashes[_pageManifest.defs[w]]) {
|
||||||
|
loadDefinitionByHash(_pageManifest.defs[w]);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Prepend the component name back into the definition.
|
||||||
|
// Only for single-definition forms (defcomp/defisland/defmacro) where
|
||||||
|
// the name was stripped for hashing. Multi-define files (client libs)
|
||||||
|
// already contain named (define name ...) forms.
|
||||||
|
var name = _hashToName[hash];
|
||||||
|
if (name) {
|
||||||
|
// Check if this is a multi-define file (client lib with top-level defines).
|
||||||
|
// Only top-level (define ...) forms count — nested ones inside defisland/defcomp
|
||||||
|
// bodies should NOT suppress name insertion.
|
||||||
|
var startsWithDef = /^\((defcomp|defisland|defmacro)\s/.test(rewritten);
|
||||||
|
var isMultiDefine = !startsWithDef && /\(define\s+[a-zA-Z]/.test(rewritten);
|
||||||
|
if (!isMultiDefine) {
|
||||||
|
rewritten = rewritten.replace(
|
||||||
|
/^\((defcomp|defisland|defmacro|define)\s/,
|
||||||
|
function(_m, kw) { return "(" + kw + " " + name + " "; }
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
try {
|
||||||
|
var loadRv = K.load(rewritten);
|
||||||
|
if (typeof loadRv === "string" && loadRv.indexOf("Error") >= 0) {
|
||||||
|
console.warn("[sx] K.load error for", (_hashToName[hash] || hash) + ":", loadRv);
|
||||||
|
delete _loadedHashes[hash];
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
_loadedHashes[hash] = true;
|
||||||
|
return true;
|
||||||
|
} catch(e) {
|
||||||
|
console.warn("[sx] Failed to load hash " + hash + " (" + (name || "?") + "):", e);
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Eagerly pre-load island definitions from the manifest.
|
||||||
|
// Called from boot.sx before hydration. Scans the DOM for data-sx-island
|
||||||
|
// attributes and loads definitions via the content-addressed manifest.
|
||||||
|
// Unlike __resolve-symbol (called from inside env_get), this runs at the
|
||||||
|
// top level so K.load can register bindings without reentrancy issues.
|
||||||
|
K.registerNative("preload-island-defs", function() {
|
||||||
|
var manifest = loadPageManifest();
|
||||||
|
if (!manifest || !manifest.defs) return null;
|
||||||
|
var els = document.querySelectorAll('[data-sx-island]');
|
||||||
|
for (var i = 0; i < els.length; i++) {
|
||||||
|
var name = "~" + els[i].getAttribute("data-sx-island");
|
||||||
|
if (manifest.defs[name] && !_loadedHashes[manifest.defs[name]]) {
|
||||||
|
loadDefinitionByHash(manifest.defs[name]);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
|
||||||
// Register the resolve hook — called by the VM when GLOBAL_GET fails
|
// Register the resolve hook — called by the VM when GLOBAL_GET fails
|
||||||
K.registerNative("__resolve-symbol", function(args) {
|
K.registerNative("__resolve-symbol", function(args) {
|
||||||
var name = args[0];
|
var name = args[0];
|
||||||
if (!name) return null;
|
if (!name) return null;
|
||||||
|
// Content-addressed resolution — components, libraries, macros
|
||||||
|
var manifest = loadPageManifest();
|
||||||
|
if (manifest && manifest.defs && manifest.defs[name]) {
|
||||||
|
var hash = manifest.defs[name];
|
||||||
|
if (!_loadedHashes[hash]) {
|
||||||
|
loadDefinitionByHash(hash);
|
||||||
|
return null; // VM re-lookups after hook
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Library-level resolution (existing path — .sxbc modules)
|
||||||
var idx = buildSymbolIndex();
|
var idx = buildSymbolIndex();
|
||||||
if (!idx || !idx[name]) return null;
|
if (!idx || !idx[name]) return null;
|
||||||
var lib = idx[name];
|
var lib = idx[name];
|
||||||
@@ -603,6 +931,7 @@
|
|||||||
renderToHtml: function(expr) { return K.renderToHtml(expr); },
|
renderToHtml: function(expr) { return K.renderToHtml(expr); },
|
||||||
callFn: function(fn, args) { return K.callFn(fn, args); },
|
callFn: function(fn, args) { return K.callFn(fn, args); },
|
||||||
engine: function() { return K.engine(); },
|
engine: function() { return K.engine(); },
|
||||||
|
mergeManifest: function(el) { return mergeManifest(el); },
|
||||||
// Boot entry point (called by auto-init or manually)
|
// Boot entry point (called by auto-init or manually)
|
||||||
init: function() {
|
init: function() {
|
||||||
if (typeof K.eval === "function") {
|
if (typeof K.eval === "function") {
|
||||||
@@ -617,6 +946,20 @@
|
|||||||
K.eval("(process-sx-scripts nil)");
|
K.eval("(process-sx-scripts nil)");
|
||||||
console.log("[sx] sx-hydrate-elements...");
|
console.log("[sx] sx-hydrate-elements...");
|
||||||
K.eval("(sx-hydrate-elements nil)");
|
K.eval("(sx-hydrate-elements nil)");
|
||||||
|
// Pre-load island definitions from manifest before hydration.
|
||||||
|
// Must happen at JS level (not from inside SX eval) to avoid
|
||||||
|
// K.load reentrancy issues with the symbol resolve hook.
|
||||||
|
var manifest = loadPageManifest();
|
||||||
|
if (manifest && manifest.defs) {
|
||||||
|
var islandEls = document.querySelectorAll("[data-sx-island]");
|
||||||
|
for (var ii = 0; ii < islandEls.length; ii++) {
|
||||||
|
var iname = "~" + islandEls[ii].getAttribute("data-sx-island");
|
||||||
|
var ihash = manifest.defs[iname];
|
||||||
|
if (ihash && !_loadedHashes[ihash]) {
|
||||||
|
loadDefinitionByHash(ihash);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
console.log("[sx] sx-hydrate-islands...");
|
console.log("[sx] sx-hydrate-islands...");
|
||||||
K.eval("(sx-hydrate-islands nil)");
|
K.eval("(sx-hydrate-islands nil)");
|
||||||
console.log("[sx] process-elements...");
|
console.log("[sx] process-elements...");
|
||||||
@@ -650,6 +993,20 @@
|
|||||||
var scrollY = (state && state.scrollY) ? state.scrollY : 0;
|
var scrollY = (state && state.scrollY) ? state.scrollY : 0;
|
||||||
K.eval("(handle-popstate " + scrollY + ")");
|
K.eval("(handle-popstate " + scrollY + ")");
|
||||||
});
|
});
|
||||||
|
// Wire up streaming suspense resolution
|
||||||
|
var _resolveFn = K.eval("resolve-suspense");
|
||||||
|
Sx.resolveSuspense = function(id, sx) {
|
||||||
|
try { K.callFn(_resolveFn, [id, sx]); }
|
||||||
|
catch(e) { console.error("[sx] resolveSuspense error:", e); }
|
||||||
|
};
|
||||||
|
// Drain any pending resolves that arrived before boot
|
||||||
|
if (window.__sxPending) {
|
||||||
|
for (var pi = 0; pi < window.__sxPending.length; pi++) {
|
||||||
|
Sx.resolveSuspense(window.__sxPending[pi].id, window.__sxPending[pi].sx);
|
||||||
|
}
|
||||||
|
window.__sxPending = null;
|
||||||
|
}
|
||||||
|
window.__sxResolve = function(id, sx) { Sx.resolveSuspense(id, sx); };
|
||||||
// Signal boot complete
|
// Signal boot complete
|
||||||
document.documentElement.setAttribute("data-sx-ready", "true");
|
document.documentElement.setAttribute("data-sx-ready", "true");
|
||||||
console.log("[sx] boot done");
|
console.log("[sx] boot done");
|
||||||
|
|||||||
@@ -108,6 +108,50 @@ let rec value_to_js (v : value) : Js.Unsafe.any =
|
|||||||
let result = call_sx_fn v args in
|
let result = call_sx_fn v args in
|
||||||
value_to_js result
|
value_to_js result
|
||||||
with
|
with
|
||||||
|
| Sx_vm.VmSuspended (request, vm) ->
|
||||||
|
(* Transfer reuse_stack from the active VM to the suspension VM.
|
||||||
|
call_closure_reuse saves caller frames on _active_vm AFTER the
|
||||||
|
inner VmSuspended propagates, so the suspension VM doesn't have them. *)
|
||||||
|
(match !Sx_vm._active_vm with
|
||||||
|
| Some active when active.Sx_vm.reuse_stack <> [] ->
|
||||||
|
vm.Sx_vm.reuse_stack <- vm.Sx_vm.reuse_stack @ active.Sx_vm.reuse_stack;
|
||||||
|
active.Sx_vm.reuse_stack <- []
|
||||||
|
| _ -> ());
|
||||||
|
(* Build {suspended, request, resume} and hand to _driveAsync.
|
||||||
|
The resume callback must also catch VmSuspended for chaining
|
||||||
|
(e.g. repeat 3 times ... wait ... end). *)
|
||||||
|
let rec make_suspension req v =
|
||||||
|
let obj = Js.Unsafe.obj [||] in
|
||||||
|
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject Js._true);
|
||||||
|
Js.Unsafe.set obj (Js.string "request") (value_to_js req);
|
||||||
|
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun result_js ->
|
||||||
|
let result = js_to_value result_js in
|
||||||
|
try value_to_js (Sx_vm.resume_vm v result)
|
||||||
|
with
|
||||||
|
| Sx_vm.VmSuspended (req2, vm2) ->
|
||||||
|
(* Return suspension object — the JS driveAsync caller handles scheduling *)
|
||||||
|
Js.Unsafe.inject (make_suspension req2 vm2)
|
||||||
|
| Eval_error msg ->
|
||||||
|
(* Enhanced error: show pending_cek kont, reuse_stack, and VM frame info *)
|
||||||
|
let vm_frame_names = String.concat "," (List.map (fun f ->
|
||||||
|
match f.Sx_vm.closure.Sx_types.vm_name with Some n -> n | None -> "?"
|
||||||
|
) v.Sx_vm.frames) in
|
||||||
|
let extra = Printf.sprintf " [vm: pending_cek=%b reuse=%d frames=[%s] sp=%d]"
|
||||||
|
(v.Sx_vm.pending_cek <> None)
|
||||||
|
(List.length v.Sx_vm.reuse_stack)
|
||||||
|
vm_frame_names
|
||||||
|
v.Sx_vm.sp in
|
||||||
|
ignore (Js.Unsafe.meth_call
|
||||||
|
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||||
|
"error" [| Js.Unsafe.inject (Js.string ("[sx] resume: " ^ msg ^ extra)) |]);
|
||||||
|
Js.Unsafe.inject Js.null));
|
||||||
|
obj
|
||||||
|
in
|
||||||
|
let s = make_suspension request vm in
|
||||||
|
let drive = Js.Unsafe.get Js.Unsafe.global (Js.string "_driveAsync") in
|
||||||
|
if not (Js.Unsafe.equals drive Js.undefined) then
|
||||||
|
ignore (Js.Unsafe.fun_call drive [| Js.Unsafe.inject s |]);
|
||||||
|
Js.Unsafe.inject s
|
||||||
| Eval_error msg ->
|
| Eval_error msg ->
|
||||||
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
||||||
ignore (Js.Unsafe.meth_call
|
ignore (Js.Unsafe.meth_call
|
||||||
@@ -141,13 +185,18 @@ and js_to_value (js : Js.Unsafe.any) : value =
|
|||||||
| "string" -> String (Js.to_string (Js.Unsafe.coerce js))
|
| "string" -> String (Js.to_string (Js.Unsafe.coerce js))
|
||||||
| "function" ->
|
| "function" ->
|
||||||
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||||
if not (Js.Unsafe.equals h Js.undefined) then
|
let has_host_cb = Js.to_bool (Js.Unsafe.coerce (Js.Unsafe.get js (Js.string "__host_callback"))) in
|
||||||
|
if not (Js.Unsafe.equals h Js.undefined) && not has_host_cb then
|
||||||
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
|
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
|
||||||
else
|
else
|
||||||
(* Plain JS function — wrap as NativeFn *)
|
(* Plain JS function — store as host object so value_to_js
|
||||||
NativeFn ("js-callback", fun args ->
|
returns the ORIGINAL JS function when passed to host-call.
|
||||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
This preserves wrappers like _driveAsync that host-callback
|
||||||
js_to_value (Js.Unsafe.fun_call js (Array.map Fun.id js_args)))
|
attaches for IO suspension handling. *)
|
||||||
|
let id = host_put js in
|
||||||
|
let d = Hashtbl.create 2 in
|
||||||
|
Hashtbl.replace d "__host_handle" (Number (float_of_int id));
|
||||||
|
Dict d
|
||||||
| "object" ->
|
| "object" ->
|
||||||
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||||
if not (Js.Unsafe.equals h Js.undefined) then
|
if not (Js.Unsafe.equals h Js.undefined) then
|
||||||
@@ -205,6 +254,7 @@ let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
|||||||
VmClosures from bytecode modules hold vm_env_ref pointing here.
|
VmClosures from bytecode modules hold vm_env_ref pointing here.
|
||||||
Must stay in sync so VmClosures see post-boot definitions. *)
|
Must stay in sync so VmClosures see post-boot definitions. *)
|
||||||
let _vm_globals : (string, value) Hashtbl.t = Hashtbl.create 512
|
let _vm_globals : (string, value) Hashtbl.t = Hashtbl.create 512
|
||||||
|
let () = Sx_types._default_vm_globals := _vm_globals
|
||||||
let _in_batch = ref false
|
let _in_batch = ref false
|
||||||
|
|
||||||
(* Sync env→VM: copy all bindings from global_env.bindings to _vm_globals.
|
(* Sync env→VM: copy all bindings from global_env.bindings to _vm_globals.
|
||||||
@@ -242,7 +292,9 @@ let () =
|
|||||||
(* Check if the symbol appeared in globals after the load *)
|
(* Check if the symbol appeared in globals after the load *)
|
||||||
match Hashtbl.find_opt _vm_globals name with
|
match Hashtbl.find_opt _vm_globals name with
|
||||||
| Some v -> Some v
|
| Some v -> Some v
|
||||||
| None -> None)
|
| None ->
|
||||||
|
(* Fallback: check global_env directly if vm_globals missed the sync *)
|
||||||
|
Hashtbl.find_opt global_env.bindings (Sx_types.intern name))
|
||||||
|
|
||||||
(* ================================================================== *)
|
(* ================================================================== *)
|
||||||
(* Core API *)
|
(* Core API *)
|
||||||
@@ -487,22 +539,58 @@ let api_register_native name_js callback_js =
|
|||||||
Hashtbl.replace _vm_globals name v;
|
Hashtbl.replace _vm_globals name v;
|
||||||
Js.Unsafe.inject Js.null
|
Js.Unsafe.inject Js.null
|
||||||
|
|
||||||
|
let rec make_js_callFn_suspension request vm =
|
||||||
|
let obj = Js.Unsafe.obj [||] in
|
||||||
|
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject Js._true);
|
||||||
|
Js.Unsafe.set obj (Js.string "request") (value_to_js request);
|
||||||
|
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun result_js ->
|
||||||
|
let result = js_to_value result_js in
|
||||||
|
try
|
||||||
|
let v = Sx_vm.resume_vm vm result in
|
||||||
|
sync_vm_to_env ();
|
||||||
|
value_to_js v
|
||||||
|
with
|
||||||
|
| Sx_vm.VmSuspended (req2, vm2) ->
|
||||||
|
Js.Unsafe.inject (make_js_callFn_suspension req2 vm2)
|
||||||
|
| Eval_error msg ->
|
||||||
|
let vm_frame_names = String.concat "," (List.map (fun f ->
|
||||||
|
match f.Sx_vm.closure.Sx_types.vm_name with Some n -> n | None -> "?"
|
||||||
|
) vm.Sx_vm.frames) in
|
||||||
|
let extra = Printf.sprintf " [vm: pending_cek=%b reuse=%d frames=[%s] sp=%d]"
|
||||||
|
(vm.Sx_vm.pending_cek <> None)
|
||||||
|
(List.length vm.Sx_vm.reuse_stack)
|
||||||
|
vm_frame_names
|
||||||
|
vm.Sx_vm.sp in
|
||||||
|
ignore (Js.Unsafe.meth_call
|
||||||
|
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||||
|
"error" [| Js.Unsafe.inject (Js.string ("[sx] resume: " ^ msg ^ extra)) |]);
|
||||||
|
Js.Unsafe.inject Js.null));
|
||||||
|
obj
|
||||||
|
|
||||||
let api_call_fn fn_js args_js =
|
let api_call_fn fn_js args_js =
|
||||||
try
|
try
|
||||||
let fn = js_to_value fn_js in
|
let fn = js_to_value fn_js in
|
||||||
let args = Array.to_list (Array.map js_to_value (Js.to_array (Js.Unsafe.coerce args_js))) in
|
let args = Array.to_list (Array.map js_to_value (Js.to_array (Js.Unsafe.coerce args_js))) in
|
||||||
return_via_side_channel (value_to_js (call_sx_fn fn args))
|
return_via_side_channel (value_to_js (call_sx_fn fn args))
|
||||||
with
|
with
|
||||||
|
| Sx_vm.VmSuspended (request, vm) ->
|
||||||
|
(* Transfer reuse_stack from active VM *)
|
||||||
|
(match !Sx_vm._active_vm with
|
||||||
|
| Some active when active.Sx_vm.reuse_stack <> [] ->
|
||||||
|
vm.Sx_vm.reuse_stack <- vm.Sx_vm.reuse_stack @ active.Sx_vm.reuse_stack;
|
||||||
|
active.Sx_vm.reuse_stack <- []
|
||||||
|
| _ -> ());
|
||||||
|
sync_vm_to_env ();
|
||||||
|
Js.Unsafe.inject (make_js_callFn_suspension request vm)
|
||||||
| Eval_error msg ->
|
| Eval_error msg ->
|
||||||
ignore (Js.Unsafe.meth_call
|
(* Store the error message so callers can detect it *)
|
||||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
let err_obj = Js.Unsafe.obj [| ("__sx_error", Js.Unsafe.inject Js._true);
|
||||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] callFn: " ^ msg)) |]);
|
("message", Js.Unsafe.inject (Js.string msg)) |] in
|
||||||
Js.Unsafe.inject Js.null
|
Js.Unsafe.inject err_obj
|
||||||
| exn ->
|
| exn ->
|
||||||
ignore (Js.Unsafe.meth_call
|
let err_obj = Js.Unsafe.obj [| ("__sx_error", Js.Unsafe.inject Js._true);
|
||||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
("message", Js.Unsafe.inject (Js.string (Printexc.to_string exn))) |] in
|
||||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] callFn: " ^ Printexc.to_string exn)) |]);
|
Js.Unsafe.inject err_obj
|
||||||
Js.Unsafe.inject Js.null
|
|
||||||
|
|
||||||
let api_is_callable fn_js =
|
let api_is_callable fn_js =
|
||||||
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
||||||
@@ -635,7 +723,14 @@ let () =
|
|||||||
in
|
in
|
||||||
let module_val = convert_code code_form in
|
let module_val = convert_code code_form in
|
||||||
let code = Sx_vm.code_from_value module_val in
|
let code = Sx_vm.code_from_value module_val in
|
||||||
let _result = Sx_vm.execute_module code _vm_globals in
|
(* Use execute_module_safe to handle import suspension.
|
||||||
|
Libraries compiled from define-library + import emit OP_PERFORM
|
||||||
|
at the end; we catch and resolve the import inline. *)
|
||||||
|
(try
|
||||||
|
ignore (Sx_vm.execute_module code _vm_globals)
|
||||||
|
with
|
||||||
|
| Sx_vm.VmSuspended _ -> () (* Import suspension — defines already in globals *)
|
||||||
|
| _ -> ());
|
||||||
sync_vm_to_env ();
|
sync_vm_to_env ();
|
||||||
Number (float_of_int (Hashtbl.length _vm_globals))
|
Number (float_of_int (Hashtbl.length _vm_globals))
|
||||||
| _ -> raise (Eval_error "load-sxbc: expected (sxbc version hash (code ...))"));
|
| _ -> raise (Eval_error "load-sxbc: expected (sxbc version hash (code ...))"));
|
||||||
@@ -992,4 +1087,16 @@ let () =
|
|||||||
let log = Sx_primitives.scope_trace_drain () in
|
let log = Sx_primitives.scope_trace_drain () in
|
||||||
Js.Unsafe.inject (Js.array (Array.of_list (List.map (fun s -> Js.Unsafe.inject (Js.string s)) log)))));
|
Js.Unsafe.inject (Js.array (Array.of_list (List.map (fun s -> Js.Unsafe.inject (Js.string s)) log)))));
|
||||||
|
|
||||||
|
(* Step limit for timeout protection *)
|
||||||
|
Js.Unsafe.set sx (Js.string "setStepLimit") (Js.wrap_callback (fun n ->
|
||||||
|
let limit = Js.float_of_number (Js.Unsafe.coerce n) |> int_of_float in
|
||||||
|
Sx_ref.step_limit := limit;
|
||||||
|
Sx_ref.step_count := 0;
|
||||||
|
Sx_vm.vm_reset_counters ();
|
||||||
|
Js.Unsafe.inject Js.null));
|
||||||
|
Js.Unsafe.set sx (Js.string "resetStepCount") (Js.wrap_callback (fun () ->
|
||||||
|
Sx_ref.step_count := 0;
|
||||||
|
Sx_vm.vm_reset_counters ();
|
||||||
|
Js.Unsafe.inject Js.null));
|
||||||
|
|
||||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||||
|
|||||||
230
hosts/ocaml/browser/test_bytecode_repeat.js
Normal file
230
hosts/ocaml/browser/test_bytecode_repeat.js
Normal file
@@ -0,0 +1,230 @@
|
|||||||
|
#!/usr/bin/env node
|
||||||
|
// test_bytecode_repeat.js — Regression test for bytecode when/do/perform bug
|
||||||
|
//
|
||||||
|
// Tests that (when cond (do (perform ...) (recurse))) correctly resumes
|
||||||
|
// the do continuation after perform/cek_resume in bytecode-compiled code.
|
||||||
|
//
|
||||||
|
// The bug: bytecode-compiled hs-repeat-times only iterates 2x instead of 3x
|
||||||
|
// because the do continuation is lost after perform suspension.
|
||||||
|
//
|
||||||
|
// Source-loaded code works (CEK handles when/do/perform correctly).
|
||||||
|
// Bytecode-compiled code fails (VM/CEK handoff loses the continuation).
|
||||||
|
//
|
||||||
|
// Usage: node hosts/ocaml/browser/test_bytecode_repeat.js
|
||||||
|
//
|
||||||
|
// Expected output when bug is fixed:
|
||||||
|
// SOURCE: 6 suspensions (3 iterations × 2 waits) ✓
|
||||||
|
// BYTECODE: 6 suspensions (3 iterations × 2 waits) ✓
|
||||||
|
|
||||||
|
const fs = require('fs');
|
||||||
|
const path = require('path');
|
||||||
|
|
||||||
|
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||||
|
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||||
|
const SX_DIR = path.join(WASM_DIR, 'sx');
|
||||||
|
|
||||||
|
// --- Minimal DOM stubs ---
|
||||||
|
function makeElement(tag) {
|
||||||
|
const el = {
|
||||||
|
tagName: tag, _attrs: {}, _classes: new Set(), style: {},
|
||||||
|
childNodes: [], children: [], textContent: '', nodeType: 1,
|
||||||
|
classList: {
|
||||||
|
add(c) { el._classes.add(c); },
|
||||||
|
remove(c) { el._classes.delete(c); },
|
||||||
|
contains(c) { return el._classes.has(c); },
|
||||||
|
},
|
||||||
|
setAttribute(k, v) { el._attrs[k] = String(v); },
|
||||||
|
getAttribute(k) { return el._attrs[k] || null; },
|
||||||
|
removeAttribute(k) { delete el._attrs[k]; },
|
||||||
|
appendChild(c) { el.children.push(c); el.childNodes.push(c); return c; },
|
||||||
|
insertBefore(c) { el.children.push(c); el.childNodes.push(c); return c; },
|
||||||
|
removeChild(c) { return c; }, replaceChild(n) { return n; },
|
||||||
|
cloneNode() { return makeElement(tag); },
|
||||||
|
addEventListener() {}, removeEventListener() {}, dispatchEvent() {},
|
||||||
|
get className() { return [...el._classes].join(' '); },
|
||||||
|
get innerHTML() { return ''; }, set innerHTML(v) {},
|
||||||
|
get outerHTML() { return '<' + tag + '>'; },
|
||||||
|
dataset: {}, querySelectorAll() { return []; }, querySelector() { return null; },
|
||||||
|
};
|
||||||
|
return el;
|
||||||
|
}
|
||||||
|
|
||||||
|
global.window = global;
|
||||||
|
global.document = {
|
||||||
|
createElement: makeElement,
|
||||||
|
createDocumentFragment() { return makeElement('fragment'); },
|
||||||
|
head: makeElement('head'), body: makeElement('body'),
|
||||||
|
querySelector() { return null; }, querySelectorAll() { return []; },
|
||||||
|
createTextNode(s) { return { _isText: true, textContent: String(s), nodeType: 3 }; },
|
||||||
|
addEventListener() {},
|
||||||
|
createComment(s) { return { _isComment: true, textContent: s || '', nodeType: 8 }; },
|
||||||
|
getElementsByTagName() { return []; },
|
||||||
|
};
|
||||||
|
global.localStorage = { getItem() { return null; }, setItem() {}, removeItem() {} };
|
||||||
|
global.CustomEvent = class { constructor(n, o) { this.type = n; this.detail = (o || {}).detail || {}; } };
|
||||||
|
global.MutationObserver = class { observe() {} disconnect() {} };
|
||||||
|
global.requestIdleCallback = fn => setTimeout(fn, 0);
|
||||||
|
global.matchMedia = () => ({ matches: false });
|
||||||
|
global.navigator = { serviceWorker: { register() { return Promise.resolve(); } } };
|
||||||
|
global.location = { href: '', pathname: '/', hostname: 'localhost' };
|
||||||
|
global.history = { pushState() {}, replaceState() {} };
|
||||||
|
global.fetch = () => Promise.resolve({ ok: true, text() { return Promise.resolve(''); } });
|
||||||
|
global.XMLHttpRequest = class { open() {} send() {} };
|
||||||
|
|
||||||
|
async function main() {
|
||||||
|
// Load WASM kernel
|
||||||
|
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||||
|
const K = globalThis.SxKernel;
|
||||||
|
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||||
|
|
||||||
|
// Register FFI
|
||||||
|
K.registerNative('host-global', args => (args[0] in globalThis) ? globalThis[args[0]] : null);
|
||||||
|
K.registerNative('host-get', args => { if (args[0] == null) return null; const v = args[0][args[1]]; return v === undefined ? null : v; });
|
||||||
|
K.registerNative('host-set!', args => { if (args[0] != null) args[0][args[1]] = args[2]; return args[2]; });
|
||||||
|
K.registerNative('host-call', args => {
|
||||||
|
const [obj, method, ...rest] = args;
|
||||||
|
if (obj == null || typeof obj[method] !== 'function') return null;
|
||||||
|
return obj[method].apply(obj, rest) ?? null;
|
||||||
|
});
|
||||||
|
K.registerNative('host-new', args => new (Function.prototype.bind.apply(args[0], [null, ...args.slice(1)])));
|
||||||
|
K.registerNative('host-callback', args => {
|
||||||
|
const fn = args[0];
|
||||||
|
return function() { return K.callFn(fn, Array.from(arguments)); };
|
||||||
|
});
|
||||||
|
K.registerNative('host-typeof', args => typeof args[0]);
|
||||||
|
K.registerNative('host-await', args => args[0]);
|
||||||
|
|
||||||
|
K.eval('(define SX_VERSION "test-bc-repeat")');
|
||||||
|
K.eval('(define SX_ENGINE "ocaml-vm-test")');
|
||||||
|
K.eval('(define parse sx-parse)');
|
||||||
|
K.eval('(define serialize sx-serialize)');
|
||||||
|
|
||||||
|
// DOM stubs for HS runtime
|
||||||
|
K.eval('(define dom-add-class (fn (el cls) (host-call (host-get el "classList") "add" cls)))');
|
||||||
|
K.eval('(define dom-remove-class (fn (el cls) (host-call (host-get el "classList") "remove" cls)))');
|
||||||
|
K.eval('(define dom-has-class? (fn (el cls) (host-call (host-get el "classList") "contains" cls)))');
|
||||||
|
K.eval('(define dom-listen (fn (target event-name handler) (handler {:type event-name :target target})))');
|
||||||
|
|
||||||
|
// --- Test helper: count suspensions ---
|
||||||
|
function countSuspensions(result) {
|
||||||
|
return new Promise(resolve => {
|
||||||
|
let count = 0;
|
||||||
|
function drive(r) {
|
||||||
|
if (!r || !r.suspended) { resolve(count); return; }
|
||||||
|
count++;
|
||||||
|
const req = r.request;
|
||||||
|
const items = req && (req.items || req);
|
||||||
|
const op = items && items[0];
|
||||||
|
const opName = typeof op === 'string' ? op : (op && op.name) || String(op);
|
||||||
|
if (opName === 'io-sleep' || opName === 'wait') {
|
||||||
|
setTimeout(() => {
|
||||||
|
try { drive(r.resume(null)); }
|
||||||
|
catch(e) { console.error(' resume error:', e.message); resolve(count); }
|
||||||
|
}, 1);
|
||||||
|
} else { resolve(count); }
|
||||||
|
}
|
||||||
|
drive(result);
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
||||||
|
let pass = 0, fail = 0;
|
||||||
|
function assert(name, got, expected) {
|
||||||
|
if (got === expected) { pass++; console.log(` ✓ ${name}`); }
|
||||||
|
else { fail++; console.error(` ✗ ${name}: got ${got}, expected ${expected}`); }
|
||||||
|
}
|
||||||
|
|
||||||
|
// =====================================================================
|
||||||
|
// Test 1: SOURCE — load hs-repeat-times from .sx, call with perform
|
||||||
|
// =====================================================================
|
||||||
|
console.log('\n=== Test: SOURCE-loaded hs-repeat-times ===');
|
||||||
|
|
||||||
|
// Load from source
|
||||||
|
const hsFiles = ['tokenizer', 'parser', 'compiler', 'runtime'];
|
||||||
|
for (const f of hsFiles) {
|
||||||
|
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'lib/hyperscript', f + '.sx'), 'utf8'));
|
||||||
|
}
|
||||||
|
|
||||||
|
// Build handler and call it
|
||||||
|
K.eval(`(define _src-handler
|
||||||
|
(eval-expr
|
||||||
|
(list 'fn '(me)
|
||||||
|
(list 'let '((it nil) (event {:type "click"}))
|
||||||
|
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 1ms then remove .active then wait 1ms end")))))`);
|
||||||
|
|
||||||
|
const srcMe = makeElement('button');
|
||||||
|
K.eval('(define _src-me (host-global "_srcMe"))');
|
||||||
|
global._srcMe = srcMe;
|
||||||
|
K.eval('(define _src-me (host-global "_srcMe"))');
|
||||||
|
|
||||||
|
let srcResult;
|
||||||
|
try { srcResult = K.callFn(K.eval('_src-handler'), [srcMe]); }
|
||||||
|
catch(e) { console.error('Source call error:', e.message); }
|
||||||
|
|
||||||
|
const srcSuspensions = await countSuspensions(srcResult);
|
||||||
|
assert('source: 6 suspensions (3 iters × 2 waits)', srcSuspensions, 6);
|
||||||
|
|
||||||
|
// =====================================================================
|
||||||
|
// Test 2: BYTECODE — load hs-repeat-times from .sxbc, call with perform
|
||||||
|
// =====================================================================
|
||||||
|
console.log('\n=== Test: BYTECODE-loaded hs-repeat-times ===');
|
||||||
|
|
||||||
|
// Reload from bytecode — overwrite the source-defined versions
|
||||||
|
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||||
|
for (const f of ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime']) {
|
||||||
|
const bcPath = path.join(SX_DIR, f + '.sxbc');
|
||||||
|
if (fs.existsSync(bcPath)) {
|
||||||
|
const bcSrc = fs.readFileSync(bcPath, 'utf8');
|
||||||
|
K.load('(load-sxbc (first (parse "' + bcSrc.replace(/\\/g, '\\\\').replace(/"/g, '\\"') + '")))');
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (K.endModuleLoad) K.endModuleLoad();
|
||||||
|
|
||||||
|
// Build handler with the bytecode-loaded hs-repeat-times
|
||||||
|
K.eval(`(define _bc-handler
|
||||||
|
(eval-expr
|
||||||
|
(list 'fn '(me)
|
||||||
|
(list 'let '((it nil) (event {:type "click"}))
|
||||||
|
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 1ms then remove .active then wait 1ms end")))))`);
|
||||||
|
|
||||||
|
const bcMe = makeElement('button');
|
||||||
|
global._bcMe = bcMe;
|
||||||
|
K.eval('(define _bc-me (host-global "_bcMe"))');
|
||||||
|
|
||||||
|
let bcResult;
|
||||||
|
try { bcResult = K.callFn(K.eval('_bc-handler'), [bcMe]); }
|
||||||
|
catch(e) { console.error('Bytecode call error:', e.message); }
|
||||||
|
|
||||||
|
const bcSuspensions = await countSuspensions(bcResult);
|
||||||
|
assert('bytecode: 6 suspensions (3 iters × 2 waits)', bcSuspensions, 6);
|
||||||
|
|
||||||
|
// =====================================================================
|
||||||
|
// Test 3: Minimal — just hs-repeat-times + perform, no hyperscript
|
||||||
|
// =====================================================================
|
||||||
|
console.log('\n=== Test: Minimal repeat + perform ===');
|
||||||
|
|
||||||
|
// Source version
|
||||||
|
K.eval('(define _src-count 0)');
|
||||||
|
K.eval(`(define _src-repeat-fn
|
||||||
|
(fn (n thunk)
|
||||||
|
(define do-repeat
|
||||||
|
(fn (i) (when (< i n) (do (thunk) (do-repeat (+ i 1))))))
|
||||||
|
(do-repeat 0)))`);
|
||||||
|
K.eval(`(define _src-repeat-thunk
|
||||||
|
(eval-expr '(fn () (_src-repeat-fn 3 (fn () (set! _src-count (+ _src-count 1)) (perform (list 'io-sleep 1)))))))`);
|
||||||
|
|
||||||
|
let minSrcResult;
|
||||||
|
try { minSrcResult = K.callFn(K.eval('_src-repeat-thunk'), []); }
|
||||||
|
catch(e) { console.error('Minimal source error:', e.message); }
|
||||||
|
const minSrcSusp = await countSuspensions(minSrcResult);
|
||||||
|
const minSrcCount = K.eval('_src-count');
|
||||||
|
assert('minimal source: 3 suspensions', minSrcSusp, 3);
|
||||||
|
assert('minimal source: count=3', minSrcCount, 3);
|
||||||
|
|
||||||
|
// =====================================================================
|
||||||
|
// Summary
|
||||||
|
// =====================================================================
|
||||||
|
console.log(`\n${pass} passed, ${fail} failed`);
|
||||||
|
process.exit(fail > 0 ? 1 : 0);
|
||||||
|
}
|
||||||
|
|
||||||
|
main().catch(e => { console.error('FATAL:', e.message); process.exit(1); });
|
||||||
294
hosts/ocaml/browser/test_driveAsync_order.js
Normal file
294
hosts/ocaml/browser/test_driveAsync_order.js
Normal file
@@ -0,0 +1,294 @@
|
|||||||
|
#!/usr/bin/env node
|
||||||
|
// test_driveAsync_order.js — Verify DOM mutation order with real _driveAsync
|
||||||
|
//
|
||||||
|
// This test mimics the exact browser flow:
|
||||||
|
// 1. host-callback wraps handler with K.callFn + _driveAsync
|
||||||
|
// 2. dom-listen uses host-callback + host-call addEventListener
|
||||||
|
// 3. Event fires → wrapper runs → _driveAsync drives suspension chain
|
||||||
|
//
|
||||||
|
// If there's a dual-path issue (_driveAsync + CEK chain both driving),
|
||||||
|
// mutations will appear out of order.
|
||||||
|
//
|
||||||
|
// Expected: +active, -active, +active, -active, +active, -active (3 iterations)
|
||||||
|
// Bug: +active, +active, -active, ... (overlapping iterations)
|
||||||
|
|
||||||
|
const fs = require('fs');
|
||||||
|
const path = require('path');
|
||||||
|
|
||||||
|
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||||
|
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||||
|
|
||||||
|
// --- Track ALL mutations in order ---
|
||||||
|
const mutations = [];
|
||||||
|
|
||||||
|
function makeElement(tag) {
|
||||||
|
const el = {
|
||||||
|
tagName: tag, _attrs: {}, _children: [], _classes: new Set(),
|
||||||
|
_listeners: {},
|
||||||
|
style: {}, childNodes: [], children: [], textContent: '',
|
||||||
|
nodeType: 1,
|
||||||
|
classList: {
|
||||||
|
add(c) {
|
||||||
|
el._classes.add(c);
|
||||||
|
mutations.push('+' + c);
|
||||||
|
console.log(' [DOM] classList.add("' + c + '") → {' + [...el._classes] + '}');
|
||||||
|
},
|
||||||
|
remove(c) {
|
||||||
|
el._classes.delete(c);
|
||||||
|
mutations.push('-' + c);
|
||||||
|
console.log(' [DOM] classList.remove("' + c + '") → {' + [...el._classes] + '}');
|
||||||
|
},
|
||||||
|
contains(c) { return el._classes.has(c); },
|
||||||
|
toggle(c) { if (el._classes.has(c)) el._classes.delete(c); else el._classes.add(c); },
|
||||||
|
},
|
||||||
|
setAttribute(k, v) { el._attrs[k] = String(v); },
|
||||||
|
getAttribute(k) { return el._attrs[k] || null; },
|
||||||
|
removeAttribute(k) { delete el._attrs[k]; },
|
||||||
|
appendChild(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||||
|
insertBefore(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||||
|
removeChild(c) { return c; }, replaceChild(n) { return n; },
|
||||||
|
cloneNode() { return makeElement(tag); },
|
||||||
|
addEventListener(event, fn) {
|
||||||
|
if (!el._listeners[event]) el._listeners[event] = [];
|
||||||
|
el._listeners[event].push(fn);
|
||||||
|
},
|
||||||
|
removeEventListener(event, fn) {
|
||||||
|
if (el._listeners[event]) {
|
||||||
|
el._listeners[event] = el._listeners[event].filter(f => f !== fn);
|
||||||
|
}
|
||||||
|
},
|
||||||
|
dispatchEvent(e) {
|
||||||
|
const name = typeof e === 'string' ? e : e.type;
|
||||||
|
(el._listeners[name] || []).forEach(fn => fn(e));
|
||||||
|
},
|
||||||
|
get innerHTML() { return ''; }, set innerHTML(v) {},
|
||||||
|
get outerHTML() { return '<' + tag + '>'; },
|
||||||
|
dataset: {}, querySelectorAll() { return []; }, querySelector() { return null; },
|
||||||
|
};
|
||||||
|
return el;
|
||||||
|
}
|
||||||
|
|
||||||
|
global.window = global;
|
||||||
|
global.document = {
|
||||||
|
createElement: makeElement,
|
||||||
|
createDocumentFragment() { return makeElement('fragment'); },
|
||||||
|
head: makeElement('head'), body: makeElement('body'),
|
||||||
|
querySelector() { return null; }, querySelectorAll() { return []; },
|
||||||
|
createTextNode(s) { return { _isText: true, textContent: String(s), nodeType: 3 }; },
|
||||||
|
addEventListener() {},
|
||||||
|
createComment(s) { return { _isComment: true, textContent: s || '', nodeType: 8 }; },
|
||||||
|
getElementsByTagName() { return []; },
|
||||||
|
};
|
||||||
|
global.localStorage = { getItem() { return null; }, setItem() {}, removeItem() {} };
|
||||||
|
global.CustomEvent = class { constructor(n, o) { this.type = n; this.detail = (o || {}).detail || {}; } };
|
||||||
|
global.MutationObserver = class { observe() {} disconnect() {} };
|
||||||
|
global.requestIdleCallback = fn => setTimeout(fn, 0);
|
||||||
|
global.matchMedia = () => ({ matches: false });
|
||||||
|
global.navigator = { serviceWorker: { register() { return Promise.resolve(); } } };
|
||||||
|
global.location = { href: '', pathname: '/', hostname: 'localhost' };
|
||||||
|
global.history = { pushState() {}, replaceState() {} };
|
||||||
|
global.fetch = () => Promise.resolve({ ok: true, text() { return Promise.resolve(''); } });
|
||||||
|
global.XMLHttpRequest = class { open() {} send() {} };
|
||||||
|
|
||||||
|
async function main() {
|
||||||
|
// Load WASM kernel
|
||||||
|
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||||
|
const K = globalThis.SxKernel;
|
||||||
|
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||||
|
console.log('WASM kernel loaded');
|
||||||
|
|
||||||
|
// --- Register FFI with the REAL _driveAsync (same as sx-platform.js) ---
|
||||||
|
K.registerNative('host-global', function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
if (name in globalThis) return globalThis[name];
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
K.registerNative('host-get', function(args) {
|
||||||
|
var obj = args[0], prop = args[1];
|
||||||
|
if (obj == null) return null;
|
||||||
|
var v = obj[prop];
|
||||||
|
return v === undefined ? null : v;
|
||||||
|
});
|
||||||
|
K.registerNative('host-set!', function(args) {
|
||||||
|
if (args[0] != null) args[0][args[1]] = args[2];
|
||||||
|
});
|
||||||
|
K.registerNative('host-call', function(args) {
|
||||||
|
var obj = args[0], method = args[1];
|
||||||
|
var callArgs = [];
|
||||||
|
for (var i = 2; i < args.length; i++) callArgs.push(args[i]);
|
||||||
|
if (obj == null) return null;
|
||||||
|
if (typeof obj[method] === 'function') {
|
||||||
|
try { return obj[method].apply(obj, callArgs); }
|
||||||
|
catch(e) { console.error('[sx] host-call error:', e); return null; }
|
||||||
|
}
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
K.registerNative('host-new', function(args) {
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
K.registerNative('host-typeof', function(args) { return typeof args[0]; });
|
||||||
|
K.registerNative('host-await', function(args) { return args[0]; });
|
||||||
|
|
||||||
|
// THE REAL host-callback (same as sx-platform.js lines 82-97)
|
||||||
|
K.registerNative('host-callback', function(args) {
|
||||||
|
var fn = args[0];
|
||||||
|
if (typeof fn === 'function' && fn.__sx_handle === undefined) return fn;
|
||||||
|
if (fn && fn.__sx_handle !== undefined) {
|
||||||
|
return function() {
|
||||||
|
var a = Array.prototype.slice.call(arguments);
|
||||||
|
var result = K.callFn(fn, a);
|
||||||
|
// This is the line under investigation:
|
||||||
|
_driveAsync(result);
|
||||||
|
return result;
|
||||||
|
};
|
||||||
|
}
|
||||||
|
return function() {};
|
||||||
|
});
|
||||||
|
|
||||||
|
// THE REAL _driveAsync (same as sx-platform.js lines 104-138)
|
||||||
|
var _asyncPending = 0;
|
||||||
|
function _driveAsync(result) {
|
||||||
|
if (!result || !result.suspended) return;
|
||||||
|
_asyncPending++;
|
||||||
|
console.log('[driveAsync] suspension detected, pending=' + _asyncPending);
|
||||||
|
var req = result.request;
|
||||||
|
if (!req) { _asyncPending--; return; }
|
||||||
|
var items = req.items || req;
|
||||||
|
var op = (items && items[0]) || req;
|
||||||
|
var opName = (typeof op === 'string') ? op : (op && op.name) || String(op);
|
||||||
|
|
||||||
|
if (opName === 'wait' || opName === 'io-sleep') {
|
||||||
|
var ms = (items && items[1]) || 0;
|
||||||
|
if (typeof ms !== 'number') ms = parseFloat(ms) || 0;
|
||||||
|
// Use 1ms for test speed
|
||||||
|
setTimeout(function() {
|
||||||
|
try {
|
||||||
|
var resumed = result.resume(null);
|
||||||
|
_asyncPending--;
|
||||||
|
console.log('[driveAsync] resumed, pending=' + _asyncPending +
|
||||||
|
', suspended=' + (resumed && resumed.suspended));
|
||||||
|
_driveAsync(resumed);
|
||||||
|
} catch(e) {
|
||||||
|
_asyncPending--;
|
||||||
|
console.error('[driveAsync] resume error:', e);
|
||||||
|
}
|
||||||
|
}, 1);
|
||||||
|
} else {
|
||||||
|
_asyncPending--;
|
||||||
|
console.warn('[driveAsync] unhandled IO:', opName);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
K.eval('(define SX_VERSION "test-drive-async")');
|
||||||
|
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
|
||||||
|
K.eval('(define parse sx-parse)');
|
||||||
|
K.eval('(define serialize sx-serialize)');
|
||||||
|
|
||||||
|
// Load the REAL dom-listen (uses host-callback + host-call addEventListener)
|
||||||
|
K.eval(`(define dom-listen
|
||||||
|
(fn (el event-name handler)
|
||||||
|
(let ((cb (host-callback handler)))
|
||||||
|
(host-call el "addEventListener" event-name cb)
|
||||||
|
(fn () (host-call el "removeEventListener" event-name cb)))))`);
|
||||||
|
|
||||||
|
K.eval('(define dom-add-class (fn (el cls) (host-call (host-get el "classList") "add" cls)))');
|
||||||
|
K.eval('(define dom-remove-class (fn (el cls) (host-call (host-get el "classList") "remove" cls)))');
|
||||||
|
K.eval('(define dom-has-class? (fn (el cls) (host-call (host-get el "classList") "contains" cls)))');
|
||||||
|
|
||||||
|
// Load hyperscript modules — try bytecode first, fall back to source
|
||||||
|
const SX_DIR = path.join(WASM_DIR, 'sx');
|
||||||
|
const useBytecode = process.argv.includes('--bytecode');
|
||||||
|
if (useBytecode) {
|
||||||
|
console.log('Loading BYTECODE modules...');
|
||||||
|
const bcNames = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'];
|
||||||
|
for (const f of bcNames) {
|
||||||
|
const bcPath = path.join(SX_DIR, f + '.sxbc');
|
||||||
|
if (fs.existsSync(bcPath)) {
|
||||||
|
const bcSrc = fs.readFileSync(bcPath, 'utf8');
|
||||||
|
K.load('(load-sxbc (first (parse "' + bcSrc.replace(/\\/g, '\\\\').replace(/"/g, '\\"') + '")))');
|
||||||
|
console.log(' loaded ' + f + '.sxbc');
|
||||||
|
} else {
|
||||||
|
console.error(' MISSING ' + bcPath);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
console.log('Loading SOURCE modules...');
|
||||||
|
const hsFiles = ['tokenizer', 'parser', 'compiler', 'runtime'];
|
||||||
|
for (const f of hsFiles) {
|
||||||
|
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'lib/hyperscript', f + '.sx'), 'utf8'));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
console.log('Hyperscript modules loaded');
|
||||||
|
|
||||||
|
// Create element
|
||||||
|
const btn = makeElement('button');
|
||||||
|
global._testBtn = btn;
|
||||||
|
K.eval('(define _btn (host-global "_testBtn"))');
|
||||||
|
|
||||||
|
// Compile + register handler using hs-on (which uses dom-listen → host-callback → addEventListener)
|
||||||
|
console.log('\n=== Setting up hs-on handler ===');
|
||||||
|
K.eval(`(hs-on _btn "click"
|
||||||
|
(fn (event)
|
||||||
|
(hs-repeat-times 3
|
||||||
|
(fn ()
|
||||||
|
(do
|
||||||
|
(dom-add-class _btn "active")
|
||||||
|
(hs-wait 300)
|
||||||
|
(dom-remove-class _btn "active")
|
||||||
|
(hs-wait 300))))))`);
|
||||||
|
|
||||||
|
console.log('Handler registered, listeners:', Object.keys(btn._listeners));
|
||||||
|
console.log('Click listeners count:', (btn._listeners.click || []).length);
|
||||||
|
|
||||||
|
// Simulate click — fires the event listener which goes through host-callback + _driveAsync
|
||||||
|
console.log('\n=== Simulating click ===');
|
||||||
|
mutations.length = 0;
|
||||||
|
btn.dispatchEvent({ type: 'click', target: btn });
|
||||||
|
|
||||||
|
// Wait for all async resumes to complete
|
||||||
|
await new Promise(resolve => {
|
||||||
|
function check() {
|
||||||
|
if (_asyncPending === 0 && mutations.length > 0) {
|
||||||
|
// Give a tiny extra delay to make sure nothing else fires
|
||||||
|
setTimeout(() => {
|
||||||
|
if (_asyncPending === 0) resolve();
|
||||||
|
else check();
|
||||||
|
}, 10);
|
||||||
|
} else {
|
||||||
|
setTimeout(check, 5);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
setTimeout(check, 50);
|
||||||
|
});
|
||||||
|
|
||||||
|
// Verify mutation order
|
||||||
|
console.log('\n=== Results ===');
|
||||||
|
console.log('Mutations:', mutations.join(', '));
|
||||||
|
console.log('Count:', mutations.length, '(expected: 6)');
|
||||||
|
|
||||||
|
const expected = ['+active', '-active', '+active', '-active', '+active', '-active'];
|
||||||
|
let pass = true;
|
||||||
|
if (mutations.length !== expected.length) {
|
||||||
|
console.error(`FAIL: expected ${expected.length} mutations, got ${mutations.length}`);
|
||||||
|
pass = false;
|
||||||
|
} else {
|
||||||
|
for (let i = 0; i < expected.length; i++) {
|
||||||
|
if (mutations[i] !== expected[i]) {
|
||||||
|
console.error(`FAIL at index ${i}: expected ${expected[i]}, got ${mutations[i]}`);
|
||||||
|
pass = false;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (pass) {
|
||||||
|
console.log('PASS: mutation order is correct');
|
||||||
|
} else {
|
||||||
|
console.log('FAIL: mutation order is wrong');
|
||||||
|
console.log('Expected:', expected.join(', '));
|
||||||
|
console.log('Got: ', mutations.join(', '));
|
||||||
|
}
|
||||||
|
|
||||||
|
process.exit(pass ? 0 : 1);
|
||||||
|
}
|
||||||
|
|
||||||
|
main().catch(e => { console.error('FATAL:', e); process.exit(1); });
|
||||||
229
hosts/ocaml/browser/test_hs_repeat.js
Normal file
229
hosts/ocaml/browser/test_hs_repeat.js
Normal file
@@ -0,0 +1,229 @@
|
|||||||
|
#!/usr/bin/env node
|
||||||
|
// test_hs_repeat.js — Debug hyperscript repeat+wait continuation bug
|
||||||
|
//
|
||||||
|
// Runs the exact expression that fails in the browser:
|
||||||
|
// on click repeat 3 times add .active to me then wait 300ms
|
||||||
|
// then remove .active then wait 300ms end
|
||||||
|
//
|
||||||
|
// Uses the real WASM kernel with perform/resume_vm, NOT mock IO.
|
||||||
|
// Waits are shortened to 1ms. All IO suspensions are logged.
|
||||||
|
//
|
||||||
|
// Usage: node hosts/ocaml/browser/test_hs_repeat.js
|
||||||
|
|
||||||
|
const fs = require('fs');
|
||||||
|
const path = require('path');
|
||||||
|
|
||||||
|
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||||
|
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||||
|
|
||||||
|
// --- DOM stubs with class tracking ---
|
||||||
|
function makeElement(tag) {
|
||||||
|
const el = {
|
||||||
|
tagName: tag, _attrs: {}, _children: [], _classes: new Set(),
|
||||||
|
style: {}, childNodes: [], children: [], textContent: '',
|
||||||
|
nodeType: 1,
|
||||||
|
classList: {
|
||||||
|
add(c) { el._classes.add(c); console.log(` [dom] classList.add("${c}") → {${[...el._classes]}}`); },
|
||||||
|
remove(c) { el._classes.delete(c); console.log(` [dom] classList.remove("${c}") → {${[...el._classes]}}`); },
|
||||||
|
contains(c) { return el._classes.has(c); },
|
||||||
|
toggle(c) { if (el._classes.has(c)) el._classes.delete(c); else el._classes.add(c); },
|
||||||
|
},
|
||||||
|
setAttribute(k, v) { el._attrs[k] = String(v); },
|
||||||
|
getAttribute(k) { return el._attrs[k] || null; },
|
||||||
|
removeAttribute(k) { delete el._attrs[k]; },
|
||||||
|
appendChild(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||||
|
insertBefore(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||||
|
removeChild(c) { return c; },
|
||||||
|
replaceChild(n) { return n; },
|
||||||
|
cloneNode() { return makeElement(tag); },
|
||||||
|
addEventListener() {}, removeEventListener() {}, dispatchEvent() {},
|
||||||
|
get innerHTML() {
|
||||||
|
return el._children.map(c => {
|
||||||
|
if (c._isText) return c.textContent || '';
|
||||||
|
if (c._isComment) return '<!--' + (c.textContent || '') + '-->';
|
||||||
|
return c.outerHTML || '';
|
||||||
|
}).join('');
|
||||||
|
},
|
||||||
|
set innerHTML(v) { el._children = []; el.childNodes = []; el.children = []; },
|
||||||
|
get outerHTML() {
|
||||||
|
let s = '<' + tag;
|
||||||
|
for (const k of Object.keys(el._attrs).sort()) s += ` ${k}="${el._attrs[k]}"`;
|
||||||
|
s += '>';
|
||||||
|
if (['br','hr','img','input','meta','link'].includes(tag)) return s;
|
||||||
|
return s + el.innerHTML + '</' + tag + '>';
|
||||||
|
},
|
||||||
|
dataset: new Proxy({}, {
|
||||||
|
get(_, k) { return el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())]; },
|
||||||
|
set(_, k, v) { el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())] = v; return true; }
|
||||||
|
}),
|
||||||
|
querySelectorAll() { return []; },
|
||||||
|
querySelector() { return null; },
|
||||||
|
};
|
||||||
|
return el;
|
||||||
|
}
|
||||||
|
|
||||||
|
global.window = global;
|
||||||
|
global.document = {
|
||||||
|
createElement: makeElement,
|
||||||
|
createDocumentFragment() { return makeElement('fragment'); },
|
||||||
|
head: makeElement('head'), body: makeElement('body'),
|
||||||
|
querySelector() { return null; }, querySelectorAll() { return []; },
|
||||||
|
createTextNode(s) { return { _isText: true, textContent: String(s), nodeType: 3 }; },
|
||||||
|
addEventListener() {},
|
||||||
|
createComment(s) { return { _isComment: true, textContent: s || '', nodeType: 8 }; },
|
||||||
|
getElementsByTagName() { return []; },
|
||||||
|
};
|
||||||
|
global.localStorage = { getItem() { return null; }, setItem() {}, removeItem() {} };
|
||||||
|
global.CustomEvent = class { constructor(n, o) { this.type = n; this.detail = (o || {}).detail || {}; } };
|
||||||
|
global.MutationObserver = class { observe() {} disconnect() {} };
|
||||||
|
global.requestIdleCallback = fn => setTimeout(fn, 0);
|
||||||
|
global.matchMedia = () => ({ matches: false });
|
||||||
|
global.navigator = { serviceWorker: { register() { return Promise.resolve(); } } };
|
||||||
|
global.location = { href: '', pathname: '/', hostname: 'localhost' };
|
||||||
|
global.history = { pushState() {}, replaceState() {} };
|
||||||
|
global.fetch = () => Promise.resolve({ ok: true, text() { return Promise.resolve(''); } });
|
||||||
|
global.XMLHttpRequest = class { open() {} send() {} };
|
||||||
|
|
||||||
|
async function main() {
|
||||||
|
// Load WASM kernel
|
||||||
|
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||||
|
const K = globalThis.SxKernel;
|
||||||
|
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||||
|
console.log('WASM kernel loaded');
|
||||||
|
|
||||||
|
// Register FFI primitives
|
||||||
|
K.registerNative('host-global', args => {
|
||||||
|
const name = args[0];
|
||||||
|
return (name in globalThis) ? globalThis[name] : null;
|
||||||
|
});
|
||||||
|
K.registerNative('host-get', args => {
|
||||||
|
const [obj, prop] = args;
|
||||||
|
if (obj == null) return null;
|
||||||
|
const v = obj[prop];
|
||||||
|
return v === undefined ? null : v;
|
||||||
|
});
|
||||||
|
K.registerNative('host-set!', args => { if (args[0] != null) args[0][args[1]] = args[2]; return args[2]; });
|
||||||
|
K.registerNative('host-call', args => {
|
||||||
|
const [obj, method, ...rest] = args;
|
||||||
|
if (obj == null || typeof obj[method] !== 'function') return null;
|
||||||
|
const r = obj[method].apply(obj, rest);
|
||||||
|
return r === undefined ? null : r;
|
||||||
|
});
|
||||||
|
K.registerNative('host-new', args => new (Function.prototype.bind.apply(args[0], [null, ...args.slice(1)])));
|
||||||
|
K.registerNative('host-callback', args => {
|
||||||
|
const fn = args[0];
|
||||||
|
return function() { return K.callFn(fn, Array.from(arguments)); };
|
||||||
|
});
|
||||||
|
K.registerNative('host-typeof', args => typeof args[0]);
|
||||||
|
K.registerNative('host-await', args => args[0]);
|
||||||
|
|
||||||
|
K.eval('(define SX_VERSION "test-hs-1.0")');
|
||||||
|
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
|
||||||
|
K.eval('(define parse sx-parse)');
|
||||||
|
K.eval('(define serialize sx-serialize)');
|
||||||
|
|
||||||
|
// Stub DOM primitives that HS runtime calls
|
||||||
|
// dom-listen fires handler immediately (simulates the event)
|
||||||
|
K.eval('(define dom-add-class (fn (el cls) (dict-set! (get el "classes") cls true) nil))');
|
||||||
|
K.eval('(define dom-remove-class (fn (el cls) (dict-delete! (get el "classes") cls) nil))');
|
||||||
|
K.eval('(define dom-has-class? (fn (el cls) (dict-has? (get el "classes") cls)))');
|
||||||
|
K.eval('(define dom-listen (fn (target event-name handler) (handler {:type event-name :target target})))');
|
||||||
|
|
||||||
|
// Load hyperscript modules
|
||||||
|
const hsFiles = [
|
||||||
|
'lib/hyperscript/tokenizer.sx',
|
||||||
|
'lib/hyperscript/parser.sx',
|
||||||
|
'lib/hyperscript/compiler.sx',
|
||||||
|
'lib/hyperscript/runtime.sx',
|
||||||
|
];
|
||||||
|
for (const f of hsFiles) {
|
||||||
|
const src = fs.readFileSync(path.join(PROJECT_ROOT, f), 'utf8');
|
||||||
|
const r = K.load(src);
|
||||||
|
if (typeof r === 'string' && r.startsWith('Error')) {
|
||||||
|
console.error(`Load failed: ${f}: ${r}`);
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
console.log('Hyperscript modules loaded');
|
||||||
|
|
||||||
|
// Compile the expression
|
||||||
|
const compiled = K.eval('(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end")');
|
||||||
|
console.log('Compiled:', K.eval(`(inspect '${typeof compiled === 'string' ? compiled : '?'})`));
|
||||||
|
// Actually get it as a string
|
||||||
|
const compiledStr = K.eval('(inspect (hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end"))');
|
||||||
|
console.log('Compiled SX:', compiledStr);
|
||||||
|
|
||||||
|
// Create handler function (same as hs-handler does)
|
||||||
|
K.eval('(define _test-me {:tag "button" :id "test" :classes {} :_hs-activated true})');
|
||||||
|
|
||||||
|
// Build the handler — wraps compiled SX in (fn (me) (let ((it nil) (event ...)) <sx>))
|
||||||
|
const handlerSrc = K.eval('(inspect (hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end"))');
|
||||||
|
K.eval(`(define _test-handler
|
||||||
|
(eval-expr
|
||||||
|
(list 'fn '(me)
|
||||||
|
(list 'let '((it nil) (event {:type "click" :target _test-me}))
|
||||||
|
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end")))))`);
|
||||||
|
|
||||||
|
console.log('\n=== Invoking handler (simulates click event) ===');
|
||||||
|
console.log('Expected: 3 iterations × (add .active, wait 300, remove .active, wait 300)');
|
||||||
|
console.log('Expected: 6 IO suspensions total\n');
|
||||||
|
|
||||||
|
// Call the handler — this will suspend on the first hs-wait (perform)
|
||||||
|
let suspensionCount = 0;
|
||||||
|
let result;
|
||||||
|
try {
|
||||||
|
result = K.callFn(K.eval('_test-handler'), [K.eval('_test-me')]);
|
||||||
|
} catch(e) {
|
||||||
|
console.error('Initial call error:', e.message);
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Drive async suspension chain with real timeouts (1ms instead of 300ms)
|
||||||
|
function driveAsync(res) {
|
||||||
|
return new Promise((resolve) => {
|
||||||
|
function step(r) {
|
||||||
|
if (!r || !r.suspended) {
|
||||||
|
console.log(`\n=== Done. Total suspensions: ${suspensionCount} (expected: 6) ===`);
|
||||||
|
console.log(`Result: ${r === null ? 'null' : typeof r === 'object' ? JSON.stringify(r) : r}`);
|
||||||
|
resolve();
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
suspensionCount++;
|
||||||
|
const req = r.request;
|
||||||
|
const items = req && (req.items || req);
|
||||||
|
const op = items && items[0];
|
||||||
|
const opName = typeof op === 'string' ? op : (op && op.name) || String(op);
|
||||||
|
const arg = items && items[1];
|
||||||
|
|
||||||
|
console.log(`Suspension #${suspensionCount}: op=${opName} arg=${arg}`);
|
||||||
|
|
||||||
|
if (opName === 'io-sleep' || opName === 'wait') {
|
||||||
|
// Resume after 1ms (not real 300ms)
|
||||||
|
setTimeout(() => {
|
||||||
|
try {
|
||||||
|
const resumed = r.resume(null);
|
||||||
|
console.log(` Resumed: suspended=${resumed && resumed.suspended}, type=${typeof resumed}`);
|
||||||
|
step(resumed);
|
||||||
|
} catch(e) {
|
||||||
|
console.error(` Resume error: ${e.message}`);
|
||||||
|
resolve();
|
||||||
|
}
|
||||||
|
}, 1);
|
||||||
|
} else {
|
||||||
|
console.log(` Unhandled IO op: ${opName}`);
|
||||||
|
resolve();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
step(res);
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
||||||
|
await driveAsync(result);
|
||||||
|
|
||||||
|
// Check final element state
|
||||||
|
const classes = K.eval('(get _test-me "classes")');
|
||||||
|
console.log('\nFinal element classes:', JSON.stringify(classes));
|
||||||
|
}
|
||||||
|
|
||||||
|
main().catch(e => { console.error('FATAL:', e.message); process.exit(1); });
|
||||||
@@ -299,6 +299,48 @@ node -e '
|
|||||||
K.eval("(let ((d (list))) (let ((el (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (quote (div :class (deref test-reactive-sig) \"content\")) (global-env) nil))))) (reset! test-reactive-sig \"after\") (dom-get-attr el \"class\")))"),
|
K.eval("(let ((d (list))) (let ((el (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (quote (div :class (deref test-reactive-sig) \"content\")) (global-env) nil))))) (reset! test-reactive-sig \"after\") (dom-get-attr el \"class\")))"),
|
||||||
"after");
|
"after");
|
||||||
|
|
||||||
|
// =====================================================================
|
||||||
|
// Section 4: Letrec + perform resume (async _driveAsync)
|
||||||
|
// =====================================================================
|
||||||
|
|
||||||
|
// Define the letrec+perform pattern — this matches the test-runner island
|
||||||
|
K.eval("(define __letrec-test-fn (letrec ((other (fn () \"from-other\")) (go (fn () (do (perform {:op \"io-sleep\" :args (list 50)}) (other))))) go))");
|
||||||
|
|
||||||
|
// Get the function as a JS-callable value
|
||||||
|
var letrecFn = K.eval("__letrec-test-fn");
|
||||||
|
if (typeof letrecFn !== "function") {
|
||||||
|
fail++; console.error("FAIL: letrec-fn not callable, got: " + typeof letrecFn);
|
||||||
|
} else {
|
||||||
|
// Call via callFn — same path as island click handlers
|
||||||
|
var letrecResult = K.callFn(letrecFn, []);
|
||||||
|
// Resume through all suspensions — tests that resume() preserves letrec env
|
||||||
|
try {
|
||||||
|
while (letrecResult && letrecResult.suspended) { letrecResult = letrecResult.resume(null); }
|
||||||
|
assert("letrec sibling after perform resume", letrecResult, "from-other");
|
||||||
|
} catch(e) {
|
||||||
|
fail++; console.error("FAIL: letrec perform resume: " + (e.message || e));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Recursive letrec after perform — the wait-boot pattern
|
||||||
|
K.eval("(define __wb-counter 0)");
|
||||||
|
K.eval("(define __recur-test-fn (letrec ((recur (fn () (set! __wb-counter (+ __wb-counter 1)) (if (>= __wb-counter 3) \"done\" (do (perform {:op \"io-sleep\" :args (list 10)}) (recur)))))) (fn () (set! __wb-counter 0) (recur))))");
|
||||||
|
|
||||||
|
var recurFn = K.eval("__recur-test-fn");
|
||||||
|
if (typeof recurFn !== "function") {
|
||||||
|
fail++; console.error("FAIL: recur-fn not callable, got: " + typeof recurFn);
|
||||||
|
} else {
|
||||||
|
var recurResult = K.callFn(recurFn, []);
|
||||||
|
try {
|
||||||
|
// Resume through all suspensions synchronously
|
||||||
|
while (recurResult && recurResult.suspended) { recurResult = recurResult.resume(null); }
|
||||||
|
assert("recursive letrec after perform", recurResult, "done");
|
||||||
|
assert("recursive letrec counter", K.eval("__wb-counter"), 3);
|
||||||
|
} catch(e) {
|
||||||
|
fail++; console.error("FAIL: recursive letrec perform: " + (e.message || e));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
// =====================================================================
|
// =====================================================================
|
||||||
// Summary
|
// Summary
|
||||||
// =====================================================================
|
// =====================================================================
|
||||||
|
|||||||
@@ -104,6 +104,33 @@ let rec cst_to_ast = function
|
|||||||
Dict d
|
Dict d
|
||||||
|
|
||||||
|
|
||||||
|
(** Convert character offset to line/col (1-based lines, 0-based cols) *)
|
||||||
|
let offset_to_loc src offset =
|
||||||
|
let line = ref 1 and col = ref 0 in
|
||||||
|
for i = 0 to min (offset - 1) (String.length src - 1) do
|
||||||
|
if src.[i] = '\n' then (incr line; col := 0)
|
||||||
|
else col := !col + 1
|
||||||
|
done;
|
||||||
|
(!line, !col)
|
||||||
|
|
||||||
|
(** CST → AST with source location dicts ({:form value :line N :col N}) *)
|
||||||
|
let cst_to_ast_loc src nodes =
|
||||||
|
List.map (fun node ->
|
||||||
|
let span = match node with
|
||||||
|
| CstAtom { span; _ } -> span
|
||||||
|
| CstList { span; _ } -> span
|
||||||
|
| CstDict { span; _ } -> span
|
||||||
|
in
|
||||||
|
let value = cst_to_ast node in
|
||||||
|
let (line, col) = offset_to_loc src span.start_offset in
|
||||||
|
let d = make_dict () in
|
||||||
|
dict_set d "form" value;
|
||||||
|
dict_set d "line" (Number (float_of_int line));
|
||||||
|
dict_set d "col" (Number (float_of_int col));
|
||||||
|
Dict d
|
||||||
|
) nodes
|
||||||
|
|
||||||
|
|
||||||
(** {1 CST editing — apply AST-level edits back to the CST} *)
|
(** {1 CST editing — apply AST-level edits back to the CST} *)
|
||||||
|
|
||||||
(** Replace the CST node at [path] with [new_source], preserving the
|
(** Replace the CST node at [path] with [new_source], preserving the
|
||||||
|
|||||||
@@ -65,6 +65,7 @@ let read_string s =
|
|||||||
| 'r' -> Buffer.add_char buf '\r'
|
| 'r' -> Buffer.add_char buf '\r'
|
||||||
| '"' -> Buffer.add_char buf '"'
|
| '"' -> Buffer.add_char buf '"'
|
||||||
| '\\' -> Buffer.add_char buf '\\'
|
| '\\' -> Buffer.add_char buf '\\'
|
||||||
|
| '/' -> Buffer.add_char buf '/'
|
||||||
| 'u' ->
|
| 'u' ->
|
||||||
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
||||||
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
||||||
|
|||||||
@@ -79,9 +79,7 @@ let as_bool = function
|
|||||||
|
|
||||||
let rec to_string = function
|
let rec to_string = function
|
||||||
| String s -> s
|
| String s -> s
|
||||||
| Number n ->
|
| Number n -> Sx_types.format_number n
|
||||||
if Float.is_integer n then string_of_int (int_of_float n)
|
|
||||||
else Printf.sprintf "%g" n
|
|
||||||
| Bool true -> "true"
|
| Bool true -> "true"
|
||||||
| Bool false -> "false"
|
| Bool false -> "false"
|
||||||
| Nil -> ""
|
| Nil -> ""
|
||||||
@@ -144,6 +142,90 @@ let () =
|
|||||||
register "pow" (fun args ->
|
register "pow" (fun args ->
|
||||||
match args with [a; b] -> Number (as_number a ** as_number b)
|
match args with [a; b] -> Number (as_number a ** as_number b)
|
||||||
| _ -> raise (Eval_error "pow: 2 args"));
|
| _ -> raise (Eval_error "pow: 2 args"));
|
||||||
|
register "cbrt" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.cbrt (as_number a)) | _ -> raise (Eval_error "cbrt: 1 arg"));
|
||||||
|
register "exp" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.exp (as_number a)) | _ -> raise (Eval_error "exp: 1 arg"));
|
||||||
|
register "expm1" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.expm1 (as_number a)) | _ -> raise (Eval_error "expm1: 1 arg"));
|
||||||
|
register "log" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.log (as_number a)) | _ -> raise (Eval_error "log: 1 arg"));
|
||||||
|
register "log2" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.log (as_number a) /. Float.log 2.0) | _ -> raise (Eval_error "log2: 1 arg"));
|
||||||
|
register "log10" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.log10 (as_number a)) | _ -> raise (Eval_error "log10: 1 arg"));
|
||||||
|
register "log1p" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.log1p (as_number a)) | _ -> raise (Eval_error "log1p: 1 arg"));
|
||||||
|
register "sin" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.sin (as_number a)) | _ -> raise (Eval_error "sin: 1 arg"));
|
||||||
|
register "cos" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.cos (as_number a)) | _ -> raise (Eval_error "cos: 1 arg"));
|
||||||
|
register "tan" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.tan (as_number a)) | _ -> raise (Eval_error "tan: 1 arg"));
|
||||||
|
register "asin" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.asin (as_number a)) | _ -> raise (Eval_error "asin: 1 arg"));
|
||||||
|
register "acos" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.acos (as_number a)) | _ -> raise (Eval_error "acos: 1 arg"));
|
||||||
|
register "atan" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.atan (as_number a)) | _ -> raise (Eval_error "atan: 1 arg"));
|
||||||
|
register "atan2" (fun args ->
|
||||||
|
match args with [a; b] -> Number (Float.atan2 (as_number a) (as_number b))
|
||||||
|
| _ -> raise (Eval_error "atan2: 2 args"));
|
||||||
|
register "sinh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.sinh (as_number a)) | _ -> raise (Eval_error "sinh: 1 arg"));
|
||||||
|
register "cosh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.cosh (as_number a)) | _ -> raise (Eval_error "cosh: 1 arg"));
|
||||||
|
register "tanh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.tanh (as_number a)) | _ -> raise (Eval_error "tanh: 1 arg"));
|
||||||
|
register "asinh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.asinh (as_number a)) | _ -> raise (Eval_error "asinh: 1 arg"));
|
||||||
|
register "acosh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.acosh (as_number a)) | _ -> raise (Eval_error "acosh: 1 arg"));
|
||||||
|
register "atanh" (fun args ->
|
||||||
|
match args with [a] -> Number (Float.atanh (as_number a)) | _ -> raise (Eval_error "atanh: 1 arg"));
|
||||||
|
register "hypot" (fun args ->
|
||||||
|
let square x = x *. x in
|
||||||
|
let sum = List.fold_left (fun acc a -> acc +. square (as_number a)) 0.0 args in
|
||||||
|
Number (Float.sqrt sum));
|
||||||
|
register "sign" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [a] ->
|
||||||
|
let n = as_number a in
|
||||||
|
Number (if Float.is_nan n then Float.nan
|
||||||
|
else if n > 0.0 then 1.0
|
||||||
|
else if n < 0.0 then -1.0
|
||||||
|
else n)
|
||||||
|
| _ -> raise (Eval_error "sign: 1 arg"));
|
||||||
|
register "fround" (fun args ->
|
||||||
|
match args with [a] -> Number (Int32.float_of_bits (Int32.bits_of_float (as_number a)))
|
||||||
|
| _ -> raise (Eval_error "fround: 1 arg"));
|
||||||
|
register "clz32" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [a] ->
|
||||||
|
let n = as_number a in
|
||||||
|
let i = if Float.is_nan n || Float.is_infinite n then 0l
|
||||||
|
else Int32.of_float (Float.rem n 4294967296.0) in
|
||||||
|
if i = 0l then Number 32.0
|
||||||
|
else
|
||||||
|
let high_bit = Int32.shift_left 1l 31 in
|
||||||
|
let count = ref 0 in
|
||||||
|
let x = ref i in
|
||||||
|
while Int32.logand !x high_bit = 0l do
|
||||||
|
incr count;
|
||||||
|
x := Int32.shift_left !x 1
|
||||||
|
done;
|
||||||
|
Number (float_of_int !count)
|
||||||
|
| _ -> raise (Eval_error "clz32: 1 arg"));
|
||||||
|
register "imul" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [a; b] ->
|
||||||
|
let tou32 f =
|
||||||
|
if Float.is_nan f || Float.is_infinite f then 0l
|
||||||
|
else Int32.of_float (Float.rem f 4294967296.0) in
|
||||||
|
let ai = tou32 (as_number a) and bi = tou32 (as_number b) in
|
||||||
|
let r = Int32.mul ai bi in
|
||||||
|
Number (Int32.to_float r)
|
||||||
|
| _ -> raise (Eval_error "imul: 2 args"));
|
||||||
register "clamp" (fun args ->
|
register "clamp" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [x; lo; hi] ->
|
| [x; lo; hi] ->
|
||||||
@@ -346,13 +428,13 @@ let () =
|
|||||||
| [String s; String prefix] ->
|
| [String s; String prefix] ->
|
||||||
Bool (String.length s >= String.length prefix &&
|
Bool (String.length s >= String.length prefix &&
|
||||||
String.sub s 0 (String.length prefix) = prefix)
|
String.sub s 0 (String.length prefix) = prefix)
|
||||||
| _ -> raise (Eval_error "starts-with?: 2 string args"));
|
| _ -> Bool false);
|
||||||
register "ends-with?" (fun args ->
|
register "ends-with?" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [String s; String suffix] ->
|
| [String s; String suffix] ->
|
||||||
let sl = String.length s and xl = String.length suffix in
|
let sl = String.length s and xl = String.length suffix in
|
||||||
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
||||||
| _ -> raise (Eval_error "ends-with?: 2 string args"));
|
| _ -> Bool false);
|
||||||
register "index-of" (fun args ->
|
register "index-of" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [String haystack; String needle] ->
|
| [String haystack; String needle] ->
|
||||||
@@ -941,7 +1023,19 @@ let () =
|
|||||||
| [f; Nil] -> call f []
|
| [f; Nil] -> call f []
|
||||||
| _ -> raise (Eval_error "apply: function and list"));
|
| _ -> raise (Eval_error "apply: function and list"));
|
||||||
register "identical?" (fun args ->
|
register "identical?" (fun args ->
|
||||||
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
match args with
|
||||||
|
| [a; b] ->
|
||||||
|
(* Physical identity for reference types, structural for values.
|
||||||
|
Numbers/strings/booleans from different constant pools must
|
||||||
|
compare equal when their values match. *)
|
||||||
|
let identical = match a, b with
|
||||||
|
| Number x, Number y -> x = y
|
||||||
|
| String x, String y -> x = y (* String.equal *)
|
||||||
|
| Bool x, Bool y -> x = y
|
||||||
|
| Nil, Nil -> true
|
||||||
|
| _ -> a == b (* reference identity for dicts, lists, etc. *)
|
||||||
|
in Bool identical
|
||||||
|
| _ -> raise (Eval_error "identical?: 2 args"));
|
||||||
register "make-spread" (fun args ->
|
register "make-spread" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [Dict d] ->
|
| [Dict d] ->
|
||||||
@@ -1591,4 +1685,190 @@ let () =
|
|||||||
|
|
||||||
register "provide-pop!" (fun args ->
|
register "provide-pop!" (fun args ->
|
||||||
match Hashtbl.find_opt primitives "scope-pop!" with
|
match Hashtbl.find_opt primitives "scope-pop!" with
|
||||||
| Some fn -> fn args | None -> Nil)
|
| Some fn -> fn args | None -> Nil);
|
||||||
|
|
||||||
|
(* hs-safe-call: invoke a 0-arg thunk, return nil on any native error.
|
||||||
|
Used by the hyperscript compiler to wrap collection expressions in
|
||||||
|
for-loops, so `for x in doesNotExist` iterates over nil instead of
|
||||||
|
crashing with an undefined-symbol error. *)
|
||||||
|
register "hs-safe-call" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [thunk] ->
|
||||||
|
(try !Sx_types._cek_call_ref thunk Nil
|
||||||
|
with _ -> Nil)
|
||||||
|
| _ -> Nil);
|
||||||
|
|
||||||
|
(* === Regex === wrapping Re + Re.Pcre *)
|
||||||
|
let regex_table : (int, Re.re * string * string) Hashtbl.t = Hashtbl.create 32 in
|
||||||
|
let regex_next_id = ref 0 in
|
||||||
|
let parse_flags flags =
|
||||||
|
let opts = ref [] in
|
||||||
|
String.iter (function
|
||||||
|
| 'i' -> opts := `CASELESS :: !opts
|
||||||
|
| 'm' -> opts := `MULTILINE :: !opts
|
||||||
|
| 's' -> opts := `DOTALL :: !opts
|
||||||
|
| _ -> ()) flags;
|
||||||
|
!opts
|
||||||
|
in
|
||||||
|
let make_regex_value id source flags =
|
||||||
|
let d = Hashtbl.create 4 in
|
||||||
|
Hashtbl.replace d "__regex__" (Bool true);
|
||||||
|
Hashtbl.replace d "id" (Number (float_of_int id));
|
||||||
|
Hashtbl.replace d "source" (String source);
|
||||||
|
Hashtbl.replace d "flags" (String flags);
|
||||||
|
Dict d
|
||||||
|
in
|
||||||
|
let regex_of_value = function
|
||||||
|
| Dict d ->
|
||||||
|
(match Hashtbl.find_opt d "id" with
|
||||||
|
| Some (Number n) ->
|
||||||
|
(match Hashtbl.find_opt regex_table (int_of_float n) with
|
||||||
|
| Some r -> r
|
||||||
|
| None -> raise (Eval_error "regex: handle not found"))
|
||||||
|
| _ -> raise (Eval_error "regex: missing id"))
|
||||||
|
| _ -> raise (Eval_error "regex: expected regex dict")
|
||||||
|
in
|
||||||
|
let group_to_dict g input =
|
||||||
|
let d = Hashtbl.create 4 in
|
||||||
|
Hashtbl.replace d "match" (String (Re.Group.get g 0));
|
||||||
|
Hashtbl.replace d "index" (Number (float_of_int (Re.Group.start g 0)));
|
||||||
|
Hashtbl.replace d "input" (String input);
|
||||||
|
let count = Re.Group.nb_groups g in
|
||||||
|
let groups = ref [] in
|
||||||
|
for i = count - 1 downto 1 do
|
||||||
|
let s = try Re.Group.get g i with Not_found -> "" in
|
||||||
|
groups := String s :: !groups
|
||||||
|
done;
|
||||||
|
Hashtbl.replace d "groups" (List !groups);
|
||||||
|
Dict d
|
||||||
|
in
|
||||||
|
register "regex-compile" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [String source; String flags] | [String source; String flags; _] ->
|
||||||
|
let opts = parse_flags flags in
|
||||||
|
(try
|
||||||
|
let re = Re.compile (Re.Pcre.re ~flags:opts source) in
|
||||||
|
let id = !regex_next_id in
|
||||||
|
incr regex_next_id;
|
||||||
|
Hashtbl.replace regex_table id (re, source, flags);
|
||||||
|
make_regex_value id source flags
|
||||||
|
with _ -> raise (Eval_error ("regex-compile: invalid pattern " ^ source)))
|
||||||
|
| [String source] ->
|
||||||
|
(try
|
||||||
|
let re = Re.compile (Re.Pcre.re source) in
|
||||||
|
let id = !regex_next_id in
|
||||||
|
incr regex_next_id;
|
||||||
|
Hashtbl.replace regex_table id (re, source, "");
|
||||||
|
make_regex_value id source ""
|
||||||
|
with _ -> raise (Eval_error ("regex-compile: invalid pattern " ^ source)))
|
||||||
|
| _ -> raise (Eval_error "regex-compile: (source flags)"));
|
||||||
|
register "regex-test" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx; String s] ->
|
||||||
|
let (re, _, _) = regex_of_value rx in
|
||||||
|
Bool (Re.execp re s)
|
||||||
|
| _ -> raise (Eval_error "regex-test: (regex string)"));
|
||||||
|
register "regex-exec" (fun args ->
|
||||||
|
let (rx, s, start) = match args with
|
||||||
|
| [rx; String s] -> (rx, s, 0)
|
||||||
|
| [rx; String s; Number n] -> (rx, s, int_of_float n)
|
||||||
|
| _ -> raise (Eval_error "regex-exec: (regex string start?)")
|
||||||
|
in
|
||||||
|
let (re, _, _) = regex_of_value rx in
|
||||||
|
try
|
||||||
|
let g = Re.exec ~pos:start re s in
|
||||||
|
group_to_dict g s
|
||||||
|
with Not_found -> Nil);
|
||||||
|
register "regex-match-all" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx; String s] ->
|
||||||
|
let (re, _, _) = regex_of_value rx in
|
||||||
|
let all = Re.all re s in
|
||||||
|
List (List.map (fun g -> group_to_dict g s) all)
|
||||||
|
| _ -> raise (Eval_error "regex-match-all: (regex string)"));
|
||||||
|
register "regex-replace" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx; String s; String replacement] ->
|
||||||
|
let (re, _, flags) = regex_of_value rx in
|
||||||
|
let expand g =
|
||||||
|
let buf = Buffer.create (String.length replacement) in
|
||||||
|
let i = ref 0 in
|
||||||
|
let n = String.length replacement in
|
||||||
|
while !i < n do
|
||||||
|
let c = replacement.[!i] in
|
||||||
|
if c = '$' && !i + 1 < n then
|
||||||
|
(match replacement.[!i + 1] with
|
||||||
|
| '&' -> Buffer.add_string buf (Re.Group.get g 0); i := !i + 2
|
||||||
|
| '$' -> Buffer.add_char buf '$'; i := !i + 2
|
||||||
|
| c when c >= '0' && c <= '9' ->
|
||||||
|
let idx = Char.code c - Char.code '0' in
|
||||||
|
(try Buffer.add_string buf (Re.Group.get g idx) with Not_found -> ());
|
||||||
|
i := !i + 2
|
||||||
|
| _ -> Buffer.add_char buf c; incr i)
|
||||||
|
else (Buffer.add_char buf c; incr i)
|
||||||
|
done;
|
||||||
|
Buffer.contents buf
|
||||||
|
in
|
||||||
|
let global = String.contains flags 'g' in
|
||||||
|
if global then
|
||||||
|
String (Re.replace re ~f:expand s)
|
||||||
|
else
|
||||||
|
(match Re.exec_opt re s with
|
||||||
|
| None -> String s
|
||||||
|
| Some g ->
|
||||||
|
let repl = expand g in
|
||||||
|
let before = String.sub s 0 (Re.Group.start g 0) in
|
||||||
|
let after_start = Re.Group.stop g 0 in
|
||||||
|
let after = String.sub s after_start (String.length s - after_start) in
|
||||||
|
String (before ^ repl ^ after))
|
||||||
|
| _ -> raise (Eval_error "regex-replace: (regex string replacement)"));
|
||||||
|
register "regex-replace-fn" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx; String s; f] ->
|
||||||
|
let (re, _, flags) = regex_of_value rx in
|
||||||
|
let call_fn g =
|
||||||
|
let match_str = Re.Group.get g 0 in
|
||||||
|
let count = Re.Group.nb_groups g in
|
||||||
|
let groups_before = ref [] in
|
||||||
|
for i = count - 1 downto 1 do
|
||||||
|
let v = try String (Re.Group.get g i) with Not_found -> Nil in
|
||||||
|
groups_before := v :: !groups_before
|
||||||
|
done;
|
||||||
|
let idx = Number (float_of_int (Re.Group.start g 0)) in
|
||||||
|
let all_args = [String match_str] @ !groups_before @ [idx; String s] in
|
||||||
|
match !Sx_types._cek_call_ref f (List all_args) with
|
||||||
|
| String s -> s
|
||||||
|
| Number n -> Sx_types.format_number n
|
||||||
|
| v -> Sx_types.inspect v
|
||||||
|
in
|
||||||
|
let global = String.contains flags 'g' in
|
||||||
|
if global then
|
||||||
|
String (Re.replace re ~f:call_fn s)
|
||||||
|
else
|
||||||
|
(match Re.exec_opt re s with
|
||||||
|
| None -> String s
|
||||||
|
| Some g ->
|
||||||
|
let repl = call_fn g in
|
||||||
|
let before = String.sub s 0 (Re.Group.start g 0) in
|
||||||
|
let after_start = Re.Group.stop g 0 in
|
||||||
|
let after = String.sub s after_start (String.length s - after_start) in
|
||||||
|
String (before ^ repl ^ after))
|
||||||
|
| _ -> raise (Eval_error "regex-replace-fn: (regex string fn)"));
|
||||||
|
register "regex-split" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx; String s] ->
|
||||||
|
let (re, _, _) = regex_of_value rx in
|
||||||
|
List (List.map (fun x -> String x) (Re.split re s))
|
||||||
|
| _ -> raise (Eval_error "regex-split: (regex string)"));
|
||||||
|
register "regex-source" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx] ->
|
||||||
|
let (_, source, _) = regex_of_value rx in
|
||||||
|
String source
|
||||||
|
| _ -> raise (Eval_error "regex-source: (regex)"));
|
||||||
|
register "regex-flags" (fun args ->
|
||||||
|
match args with
|
||||||
|
| [rx] ->
|
||||||
|
let (_, _, flags) = regex_of_value rx in
|
||||||
|
String flags
|
||||||
|
| _ -> raise (Eval_error "regex-flags: (regex)"))
|
||||||
|
|||||||
File diff suppressed because one or more lines are too long
@@ -64,6 +64,7 @@ let expand_macro m args_val _env = match m with
|
|||||||
let try_catch try_fn catch_fn =
|
let try_catch try_fn catch_fn =
|
||||||
try sx_call try_fn []
|
try sx_call try_fn []
|
||||||
with
|
with
|
||||||
|
| Sx_vm.VmSuspended _ as e -> raise e
|
||||||
| Eval_error msg -> sx_call catch_fn [String msg]
|
| Eval_error msg -> sx_call catch_fn [String msg]
|
||||||
| e -> sx_call catch_fn [String (Printexc.to_string e)]
|
| e -> sx_call catch_fn [String (Printexc.to_string e)]
|
||||||
|
|
||||||
|
|||||||
@@ -15,9 +15,7 @@ let prim_call name args =
|
|||||||
(** Convert any SX value to an OCaml string (internal). *)
|
(** Convert any SX value to an OCaml string (internal). *)
|
||||||
let value_to_str = function
|
let value_to_str = function
|
||||||
| String s -> s
|
| String s -> s
|
||||||
| Number n ->
|
| Number n -> Sx_types.format_number n
|
||||||
if Float.is_integer n then string_of_int (int_of_float n)
|
|
||||||
else Printf.sprintf "%g" n
|
|
||||||
| Bool true -> "true"
|
| Bool true -> "true"
|
||||||
| Bool false -> "false"
|
| Bool false -> "false"
|
||||||
| Nil -> ""
|
| Nil -> ""
|
||||||
@@ -44,10 +42,8 @@ let sx_call f args =
|
|||||||
match f with
|
match f with
|
||||||
| NativeFn (_, fn) -> fn args
|
| NativeFn (_, fn) -> fn args
|
||||||
| VmClosure cl -> !Sx_types._vm_call_closure_ref cl args
|
| VmClosure cl -> !Sx_types._vm_call_closure_ref cl args
|
||||||
| Lambda l ->
|
| Lambda _ ->
|
||||||
let local = Sx_types.env_extend l.l_closure in
|
!Sx_types._cek_eval_lambda_ref f args
|
||||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
|
||||||
Thunk (l.l_body, local)
|
|
||||||
| Continuation (k, _) ->
|
| Continuation (k, _) ->
|
||||||
k (match args with x :: _ -> x | [] -> Nil)
|
k (match args with x :: _ -> x | [] -> Nil)
|
||||||
| CallccContinuation _ ->
|
| CallccContinuation _ ->
|
||||||
@@ -75,11 +71,22 @@ let sx_apply_cek f args_list =
|
|||||||
match f with
|
match f with
|
||||||
| NativeFn _ | VmClosure _ ->
|
| NativeFn _ | VmClosure _ ->
|
||||||
(try sx_apply f args_list
|
(try sx_apply f args_list
|
||||||
with Eval_error msg ->
|
with
|
||||||
|
| CekPerformRequest _ as e -> raise e
|
||||||
|
| exn ->
|
||||||
|
(* Check if this is a VM suspension — return marker dict so
|
||||||
|
continue_with_call can build a proper suspended CEK state
|
||||||
|
with vm-resume-frame on the kont. *)
|
||||||
|
(match !_vm_suspension_to_dict exn with
|
||||||
|
| Some marker -> marker
|
||||||
|
| None ->
|
||||||
|
(match exn with
|
||||||
|
| Eval_error msg ->
|
||||||
let d = Hashtbl.create 3 in
|
let d = Hashtbl.create 3 in
|
||||||
Hashtbl.replace d "__eval_error__" (Bool true);
|
Hashtbl.replace d "__eval_error__" (Bool true);
|
||||||
Hashtbl.replace d "message" (String msg);
|
Hashtbl.replace d "message" (String msg);
|
||||||
Dict d)
|
Dict d
|
||||||
|
| _ -> raise exn)))
|
||||||
| _ -> sx_apply f args_list
|
| _ -> sx_apply f args_list
|
||||||
|
|
||||||
(** Check if a value is an eval-error marker from sx_apply_cek. *)
|
(** Check if a value is an eval-error marker from sx_apply_cek. *)
|
||||||
@@ -186,6 +193,7 @@ let get_val container key =
|
|||||||
Hashtbl.replace d "vc-bytecode" (List bc);
|
Hashtbl.replace d "vc-bytecode" (List bc);
|
||||||
Hashtbl.replace d "vc-constants" (List consts);
|
Hashtbl.replace d "vc-constants" (List consts);
|
||||||
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
|
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
|
||||||
|
Hashtbl.replace d "vc-rest-arity" (Number (float_of_int c.vc_rest_arity));
|
||||||
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
|
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
|
||||||
Dict d
|
Dict d
|
||||||
| "vm-upvalues" ->
|
| "vm-upvalues" ->
|
||||||
@@ -496,13 +504,28 @@ let _jit_hit = ref 0
|
|||||||
let _jit_miss = ref 0
|
let _jit_miss = ref 0
|
||||||
let _jit_skip = ref 0
|
let _jit_skip = ref 0
|
||||||
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
|
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
|
||||||
|
(* Sentinel value for "JIT skipped — fall back to CEK".
|
||||||
|
Must be distinguishable from any legitimate return value including Nil.
|
||||||
|
We use a unique tagged dict that is_jit_skip can identify. *)
|
||||||
|
let _jit_skip_sentinel =
|
||||||
|
let d = Hashtbl.create 1 in
|
||||||
|
Hashtbl.replace d "__jit_skip" (Bool true);
|
||||||
|
Dict d
|
||||||
|
|
||||||
|
let is_jit_skip v = match v with
|
||||||
|
| Dict d -> Hashtbl.mem d "__jit_skip"
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
|
(* Platform function for the spec: (jit-skip? v) → transpiles to jit_skip_p *)
|
||||||
|
let jit_skip_p v = Bool (is_jit_skip v)
|
||||||
|
|
||||||
let jit_try_call f args =
|
let jit_try_call f args =
|
||||||
match !_jit_try_call_fn with
|
match !_jit_try_call_fn with
|
||||||
| None -> incr _jit_skip; Nil
|
| None -> incr _jit_skip; _jit_skip_sentinel
|
||||||
| Some hook ->
|
| Some hook ->
|
||||||
match f with
|
match f with
|
||||||
| Lambda l when l.l_name <> None ->
|
| Lambda l when l.l_name <> None ->
|
||||||
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
|
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
|
||||||
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; Nil)
|
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
|
||||||
| _ -> incr _jit_skip; Nil
|
| _ -> incr _jit_skip; _jit_skip_sentinel
|
||||||
|
|
||||||
|
|||||||
@@ -178,6 +178,7 @@ and parameter = {
|
|||||||
(** Compiled function body — bytecode + constant pool. *)
|
(** Compiled function body — bytecode + constant pool. *)
|
||||||
and vm_code = {
|
and vm_code = {
|
||||||
vc_arity : int;
|
vc_arity : int;
|
||||||
|
vc_rest_arity : int; (** -1 = no &rest; >= 0 = number of positional params before &rest *)
|
||||||
vc_locals : int;
|
vc_locals : int;
|
||||||
vc_bytecode : int array;
|
vc_bytecode : int array;
|
||||||
vc_constants : value array;
|
vc_constants : value array;
|
||||||
@@ -228,12 +229,50 @@ let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
|
|||||||
let _cek_call_ref : (value -> value -> value) ref =
|
let _cek_call_ref : (value -> value -> value) ref =
|
||||||
ref (fun _ _ -> raise (Failure "CEK call not initialized"))
|
ref (fun _ _ -> raise (Failure "CEK call not initialized"))
|
||||||
|
|
||||||
|
(** Forward ref: evaluate a Lambda via CEK (supports perform/suspension).
|
||||||
|
Set by sx_vm.ml to break the sx_runtime → sx_ref dependency cycle. *)
|
||||||
|
let _cek_eval_lambda_ref : (value -> value list -> value) ref =
|
||||||
|
ref (fun _ _ -> raise (Failure "CEK eval lambda not initialized"))
|
||||||
|
|
||||||
|
|
||||||
(** {1 Errors} *)
|
(** {1 Errors} *)
|
||||||
|
|
||||||
exception Eval_error of string
|
exception Eval_error of string
|
||||||
exception Parse_error of string
|
exception Parse_error of string
|
||||||
|
|
||||||
|
(** Raised when a VmClosure hits OP_PERFORM inside a CEK evaluation.
|
||||||
|
The CEK step loop catches this and creates a proper io-suspended state
|
||||||
|
with the continuation preserved for resume. Defined here (not in sx_vm)
|
||||||
|
to avoid a dependency cycle between sx_runtime and sx_vm. *)
|
||||||
|
exception CekPerformRequest of value
|
||||||
|
|
||||||
|
(** Hook: resolve IO suspension inline in cek_run.
|
||||||
|
When set, cek_run calls this instead of raising "IO suspension in non-IO context".
|
||||||
|
The function receives the suspended state and returns the resolved value.
|
||||||
|
Used by the HTTP server to handle perform (text-measure) during aser. *)
|
||||||
|
let _cek_io_resolver : (value -> value -> value) option ref = ref None
|
||||||
|
|
||||||
|
(** Hook: handle CEK IO suspension in eval_expr (cek_run_iterative).
|
||||||
|
When set, called with the suspended CEK state instead of raising
|
||||||
|
"IO suspension in non-IO context". Used by the browser WASM kernel
|
||||||
|
to convert CEK suspensions to VmSuspended for _driveAsync handling. *)
|
||||||
|
let _cek_io_suspend_hook : (value -> value) option ref = ref None
|
||||||
|
|
||||||
|
(** Default VM globals for stub VMs created during IO suspension.
|
||||||
|
Set by sx_browser.ml to _vm_globals so CEK resume can access platform functions. *)
|
||||||
|
let _default_vm_globals : (string, value) Hashtbl.t ref = ref (Hashtbl.create 0)
|
||||||
|
|
||||||
|
(** Hook: convert VM suspension exceptions to CekPerformRequest.
|
||||||
|
Set by sx_vm after it defines VmSuspended. Called by sx_runtime.sx_apply_cek. *)
|
||||||
|
let _convert_vm_suspension : (exn -> unit) ref = ref (fun _ -> ())
|
||||||
|
|
||||||
|
(** Hook: convert VM suspension to a __vm_suspended marker dict.
|
||||||
|
Returns Some(dict) for VmSuspended, None otherwise.
|
||||||
|
The dict has keys: __vm_suspended, request, resume.
|
||||||
|
Used by sx_apply_cek so continue_with_call can build a proper
|
||||||
|
suspended CEK state with vm-resume-frame on the kont. *)
|
||||||
|
let _vm_suspension_to_dict : (exn -> value option) ref = ref (fun _ -> None)
|
||||||
|
|
||||||
|
|
||||||
(** {1 Record type descriptor table} *)
|
(** {1 Record type descriptor table} *)
|
||||||
|
|
||||||
@@ -339,9 +378,21 @@ let env_merge base overlay =
|
|||||||
|
|
||||||
(** {1 Value extraction helpers} *)
|
(** {1 Value extraction helpers} *)
|
||||||
|
|
||||||
|
(** Format a float safely — defuse [int_of_float] overflow on huge
|
||||||
|
integer-valued floats, keep [%g] for fractions (unchanged). *)
|
||||||
|
let format_number n =
|
||||||
|
if Float.is_nan n then "nan"
|
||||||
|
else if n = Float.infinity then "inf"
|
||||||
|
else if n = Float.neg_infinity then "-inf"
|
||||||
|
else if Float.is_integer n && Float.abs n < 1e16 then
|
||||||
|
string_of_int (int_of_float n)
|
||||||
|
else if Float.is_integer n then
|
||||||
|
Printf.sprintf "%.17g" n
|
||||||
|
else Printf.sprintf "%g" n
|
||||||
|
|
||||||
let value_to_string = function
|
let value_to_string = function
|
||||||
| String s -> s | Symbol s -> s | Keyword k -> k
|
| String s -> s | Symbol s -> s | Keyword k -> k
|
||||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
| Number n -> format_number n
|
||||||
| Bool true -> "true" | Bool false -> "false"
|
| Bool true -> "true" | Bool false -> "false"
|
||||||
| Nil -> "" | _ -> "<value>"
|
| Nil -> "" | _ -> "<value>"
|
||||||
|
|
||||||
@@ -726,9 +777,7 @@ let rec inspect = function
|
|||||||
| Nil -> "nil"
|
| Nil -> "nil"
|
||||||
| Bool true -> "true"
|
| Bool true -> "true"
|
||||||
| Bool false -> "false"
|
| Bool false -> "false"
|
||||||
| Number n ->
|
| Number n -> format_number n
|
||||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
|
||||||
else Printf.sprintf "%g" n
|
|
||||||
| String s ->
|
| String s ->
|
||||||
let buf = Buffer.create (String.length s + 2) in
|
let buf = Buffer.create (String.length s + 2) in
|
||||||
Buffer.add_char buf '"';
|
Buffer.add_char buf '"';
|
||||||
|
|||||||
@@ -36,6 +36,7 @@ type vm = {
|
|||||||
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
|
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
|
||||||
mutable pending_cek : value option; (* suspended CEK state from Component/Lambda call *)
|
mutable pending_cek : value option; (* suspended CEK state from Component/Lambda call *)
|
||||||
mutable handler_stack : handler_entry list; (* exception handler stack *)
|
mutable handler_stack : handler_entry list; (* exception handler stack *)
|
||||||
|
mutable reuse_stack : (frame list * int) list; (* saved call_closure_reuse continuations *)
|
||||||
}
|
}
|
||||||
|
|
||||||
(** Raised when OP_PERFORM is executed. Carries the IO request dict
|
(** Raised when OP_PERFORM is executed. Carries the IO request dict
|
||||||
@@ -43,6 +44,15 @@ type vm = {
|
|||||||
ip past OP_PERFORM, stack ready for a result push). *)
|
ip past OP_PERFORM, stack ready for a result push). *)
|
||||||
exception VmSuspended of value * vm
|
exception VmSuspended of value * vm
|
||||||
|
|
||||||
|
(* Register the VM suspension converter so sx_runtime.sx_apply_cek can
|
||||||
|
catch VmSuspended and convert it to CekPerformRequest without a
|
||||||
|
direct dependency on this module. *)
|
||||||
|
let () = Sx_types._convert_vm_suspension := (fun exn ->
|
||||||
|
match exn with
|
||||||
|
| VmSuspended (request, _vm) -> raise (CekPerformRequest request)
|
||||||
|
| _ -> ())
|
||||||
|
|
||||||
|
|
||||||
(** Forward reference for JIT compilation — set after definition. *)
|
(** Forward reference for JIT compilation — set after definition. *)
|
||||||
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
||||||
ref (fun _ _ -> None)
|
ref (fun _ _ -> None)
|
||||||
@@ -50,7 +60,7 @@ let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option)
|
|||||||
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
||||||
Prevents retrying compilation on every call. *)
|
Prevents retrying compilation on every call. *)
|
||||||
let jit_failed_sentinel = {
|
let jit_failed_sentinel = {
|
||||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
||||||
vc_bytecode_list = None; vc_constants_list = None };
|
vc_bytecode_list = None; vc_constants_list = None };
|
||||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||||
}
|
}
|
||||||
@@ -65,7 +75,7 @@ let is_jit_failed cl = cl.vm_code.vc_arity = -1
|
|||||||
let _active_vm : vm option ref = ref None
|
let _active_vm : vm option ref = ref None
|
||||||
|
|
||||||
let create globals =
|
let create globals =
|
||||||
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals; pending_cek = None; handler_stack = [] }
|
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals; pending_cek = None; handler_stack = []; reuse_stack = [] }
|
||||||
|
|
||||||
(** Stack ops — inlined for speed. *)
|
(** Stack ops — inlined for speed. *)
|
||||||
let push vm v =
|
let push vm v =
|
||||||
@@ -133,38 +143,93 @@ let vm_report_counters () =
|
|||||||
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d comp_jit=%d comp_cek=%d\n%!"
|
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d comp_jit=%d comp_cek=%d\n%!"
|
||||||
!_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_comp_jit_count !_vm_comp_cek_count
|
!_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_comp_jit_count !_vm_comp_cek_count
|
||||||
|
|
||||||
|
(** Global flag: true while a JIT compilation is in progress.
|
||||||
|
Prevents the JIT hook from intercepting calls during compilation,
|
||||||
|
which would cause infinite cascades (compiling the compiler). *)
|
||||||
|
let _jit_compiling = ref false
|
||||||
|
|
||||||
(** Push a VM closure frame onto the current VM — no new VM allocation.
|
(** Push a VM closure frame onto the current VM — no new VM allocation.
|
||||||
This is the fast path for intra-VM closure calls. *)
|
This is the fast path for intra-VM closure calls. *)
|
||||||
let push_closure_frame vm cl args =
|
let push_closure_frame vm cl args =
|
||||||
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
|
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
|
||||||
|
let rest_arity = cl.vm_code.vc_rest_arity in
|
||||||
|
if rest_arity >= 0 then begin
|
||||||
|
(* &rest function: push positional args, collect remainder into a list.
|
||||||
|
For (fn (a b &rest c) body) with rest_arity=2:
|
||||||
|
slots: 0=a, 1=b, 2=c (the rest list) *)
|
||||||
|
let nargs = List.length args in
|
||||||
|
let rec push_args i = function
|
||||||
|
| [] ->
|
||||||
|
for _ = i to rest_arity - 1 do push vm Nil done;
|
||||||
|
push vm (List [])
|
||||||
|
| a :: remaining ->
|
||||||
|
if i < rest_arity then (push vm a; push_args (i + 1) remaining)
|
||||||
|
else push vm (List (a :: remaining))
|
||||||
|
in
|
||||||
|
push_args 0 args;
|
||||||
|
let used = (if nargs > rest_arity then rest_arity + 1 else nargs + 1) in
|
||||||
|
for _ = used to cl.vm_code.vc_locals - 1 do push vm Nil done
|
||||||
|
end else begin
|
||||||
List.iter (fun a -> push vm a) args;
|
List.iter (fun a -> push vm a) args;
|
||||||
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done;
|
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done
|
||||||
|
end;
|
||||||
vm.frames <- frame :: vm.frames
|
vm.frames <- frame :: vm.frames
|
||||||
|
|
||||||
(** Convert compiler output (SX dict) to a vm_code object. *)
|
(** Convert compiler output (SX dict) to a vm_code object. *)
|
||||||
let code_from_value v =
|
let code_from_value v =
|
||||||
match v with
|
match v with
|
||||||
| Dict d ->
|
| Dict d ->
|
||||||
let bc_list = match Hashtbl.find_opt d "bytecode" with
|
(* Accept both compiler output keys (bytecode/constants/arity) and
|
||||||
|
SX vm-code keys (vc-bytecode/vc-constants/vc-arity) *)
|
||||||
|
let find2 k1 k2 = match Hashtbl.find_opt d k1 with
|
||||||
|
| Some _ as r -> r | None -> Hashtbl.find_opt d k2 in
|
||||||
|
let bc_list = match find2 "bytecode" "vc-bytecode" with
|
||||||
| Some (List l | ListRef { contents = l }) ->
|
| Some (List l | ListRef { contents = l }) ->
|
||||||
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
|
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
|
||||||
| _ -> [||]
|
| _ -> [||]
|
||||||
in
|
in
|
||||||
let entries = match Hashtbl.find_opt d "constants" with
|
let entries = match find2 "constants" "vc-constants" with
|
||||||
| Some (List l | ListRef { contents = l }) -> Array.of_list l
|
| Some (List l | ListRef { contents = l }) -> Array.of_list l
|
||||||
| _ -> [||]
|
| _ -> [||]
|
||||||
in
|
in
|
||||||
let constants = Array.map (fun entry ->
|
let constants = Array.map (fun entry ->
|
||||||
match entry with
|
match entry with
|
||||||
| Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *)
|
| Dict ed when Hashtbl.mem ed "bytecode" || Hashtbl.mem ed "vc-bytecode" -> entry
|
||||||
| _ -> entry
|
| _ -> entry
|
||||||
) entries in
|
) entries in
|
||||||
let arity = match Hashtbl.find_opt d "arity" with
|
let arity = match find2 "arity" "vc-arity" with
|
||||||
| Some (Number n) -> int_of_float n | _ -> 0
|
| Some (Number n) -> int_of_float n | _ -> 0
|
||||||
in
|
in
|
||||||
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants;
|
let rest_arity = match find2 "rest-arity" "vc-rest-arity" with
|
||||||
|
| Some (Number n) -> int_of_float n | _ -> -1
|
||||||
|
in
|
||||||
|
(* Compute locals from bytecode: scan for highest LOCAL_GET/LOCAL_SET slot.
|
||||||
|
The compiler's arity may undercount when nested lets add many locals. *)
|
||||||
|
let max_local = ref (arity - 1) in
|
||||||
|
let len = Array.length bc_list in
|
||||||
|
let i = ref 0 in
|
||||||
|
while !i < len do
|
||||||
|
let op = bc_list.(!i) in
|
||||||
|
if (op = 16 (* LOCAL_GET *) || op = 17 (* LOCAL_SET *)) && !i + 1 < len then
|
||||||
|
(let slot = bc_list.(!i + 1) in
|
||||||
|
if slot > !max_local then max_local := slot;
|
||||||
|
i := !i + 2)
|
||||||
|
else if op = 18 (* UPVALUE_GET *) || op = 19 (* UPVALUE_SET *)
|
||||||
|
|| op = 8 (* JUMP_IF_FALSE *) || op = 33 (* JUMP_IF_FALSE_u16 *)
|
||||||
|
|| op = 34 (* JUMP_IF_TRUE *) then
|
||||||
|
i := !i + 2
|
||||||
|
else if op = 1 (* CONST *) || op = 20 (* GLOBAL_GET *) || op = 21 (* GLOBAL_SET *)
|
||||||
|
|| op = 32 (* JUMP *) || op = 51 (* CLOSURE *) || op = 52 (* CALL_PRIM *)
|
||||||
|
|| op = 64 (* MAKE_LIST *) || op = 65 (* MAKE_DICT *) then
|
||||||
|
i := !i + 3 (* u16 operand *)
|
||||||
|
else
|
||||||
|
i := !i + 1
|
||||||
|
done;
|
||||||
|
let locals = !max_local + 1 + 16 in (* +16 headroom for temporaries *)
|
||||||
|
{ vc_arity = arity; vc_rest_arity = rest_arity; vc_locals = locals;
|
||||||
|
vc_bytecode = bc_list; vc_constants = constants;
|
||||||
vc_bytecode_list = None; vc_constants_list = None }
|
vc_bytecode_list = None; vc_constants_list = None }
|
||||||
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||];
|
| _ -> { vc_arity = 0; vc_rest_arity = -1; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||];
|
||||||
vc_bytecode_list = None; vc_constants_list = None }
|
vc_bytecode_list = None; vc_constants_list = None }
|
||||||
|
|
||||||
(** JIT-compile a component or island body.
|
(** JIT-compile a component or island body.
|
||||||
@@ -205,9 +270,20 @@ let jit_compile_comp ~name ~params ~has_children ~body ~closure globals =
|
|||||||
Saves the suspended CEK state in vm.pending_cek for later resume. *)
|
Saves the suspended CEK state in vm.pending_cek for later resume. *)
|
||||||
let cek_call_or_suspend vm f args =
|
let cek_call_or_suspend vm f args =
|
||||||
incr _vm_cek_count;
|
incr _vm_cek_count;
|
||||||
|
(* Removed debug trace *)
|
||||||
let a = match args with Nil -> [] | List l -> l | _ -> [args] in
|
let a = match args with Nil -> [] | List l -> l | _ -> [args] in
|
||||||
|
(* Replace _active_vm with an empty isolation VM so call_closure_reuse
|
||||||
|
inside the CEK pushes onto an empty frame stack rather than the caller's.
|
||||||
|
Without this, a VmClosure called from within the CEK (e.g. hs-wait)
|
||||||
|
merges frames with the caller's VM (e.g. do-repeat), and on resume
|
||||||
|
the VM skips the CEK's remaining continuation (wrong mutation order).
|
||||||
|
Using Some(isolation) rather than None keeps the call_closure_reuse
|
||||||
|
"Some" path which preserves exception identity in js_of_ocaml. *)
|
||||||
|
let saved_active = !_active_vm in
|
||||||
|
_active_vm := Some (create vm.globals);
|
||||||
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
|
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
|
||||||
let final = Sx_ref.cek_step_loop state in
|
let final = Sx_ref.cek_step_loop state in
|
||||||
|
_active_vm := saved_active;
|
||||||
match Sx_runtime.get_val final (String "phase") with
|
match Sx_runtime.get_val final (String "phase") with
|
||||||
| String "io-suspended" ->
|
| String "io-suspended" ->
|
||||||
vm.pending_cek <- Some final;
|
vm.pending_cek <- Some final;
|
||||||
@@ -228,8 +304,30 @@ let rec call_closure cl args globals =
|
|||||||
|
|
||||||
(** Call a VmClosure on the active VM if one exists, otherwise create a new one.
|
(** Call a VmClosure on the active VM if one exists, otherwise create a new one.
|
||||||
This is the path used by HO primitives (map, filter, for-each, some) so
|
This is the path used by HO primitives (map, filter, for-each, some) so
|
||||||
callbacks can access upvalues that reference the calling VM's state. *)
|
callbacks run on the same VM, avoiding per-call VM allocation overhead. *)
|
||||||
and call_closure_reuse cl args =
|
and call_closure_reuse cl args =
|
||||||
|
match !_active_vm with
|
||||||
|
| Some vm ->
|
||||||
|
let saved_sp = vm.sp in
|
||||||
|
push_closure_frame vm cl args;
|
||||||
|
let saved_frames = List.tl vm.frames in
|
||||||
|
vm.frames <- [List.hd vm.frames];
|
||||||
|
(try run vm
|
||||||
|
with
|
||||||
|
| VmSuspended _ as e ->
|
||||||
|
(* IO suspension: save the caller's continuation on the reuse stack.
|
||||||
|
DON'T merge frames — that corrupts the frame chain with nested
|
||||||
|
closures. On resume, restore_reuse in resume_vm processes these
|
||||||
|
in innermost-first order after the callback finishes. *)
|
||||||
|
vm.reuse_stack <- (saved_frames, saved_sp) :: vm.reuse_stack;
|
||||||
|
raise e
|
||||||
|
| e ->
|
||||||
|
vm.frames <- saved_frames;
|
||||||
|
vm.sp <- saved_sp;
|
||||||
|
raise e);
|
||||||
|
vm.frames <- saved_frames;
|
||||||
|
pop vm
|
||||||
|
| None ->
|
||||||
call_closure cl args cl.vm_env_ref
|
call_closure cl args cl.vm_env_ref
|
||||||
|
|
||||||
(** Call a value as a function — dispatch by type.
|
(** Call a value as a function — dispatch by type.
|
||||||
@@ -247,25 +345,18 @@ and vm_call vm f args =
|
|||||||
| Lambda l ->
|
| Lambda l ->
|
||||||
(match l.l_compiled with
|
(match l.l_compiled with
|
||||||
| Some cl when not (is_jit_failed cl) ->
|
| Some cl when not (is_jit_failed cl) ->
|
||||||
(* Cached bytecode — run on VM using the closure's captured env,
|
(* Cached bytecode — push frame on current VM *)
|
||||||
not the caller's globals. Closure vars were merged at compile time. *)
|
push_closure_frame vm cl args
|
||||||
(try push vm (call_closure cl args cl.vm_env_ref)
|
|
||||||
with _e ->
|
|
||||||
(* Fallback to CEK — suspension-aware *)
|
|
||||||
push vm (cek_call_or_suspend vm f (List args)))
|
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
(* Compile failed — CEK, suspension-aware *)
|
|
||||||
push vm (cek_call_or_suspend vm f (List args))
|
push vm (cek_call_or_suspend vm f (List args))
|
||||||
| None ->
|
| None ->
|
||||||
if l.l_name <> None
|
if l.l_name <> None
|
||||||
then begin
|
then begin
|
||||||
(* Pre-mark before compile attempt to prevent re-entrancy *)
|
|
||||||
l.l_compiled <- Some jit_failed_sentinel;
|
l.l_compiled <- Some jit_failed_sentinel;
|
||||||
match !jit_compile_ref l vm.globals with
|
match !jit_compile_ref l vm.globals with
|
||||||
| Some cl ->
|
| Some cl ->
|
||||||
l.l_compiled <- Some cl;
|
l.l_compiled <- Some cl;
|
||||||
(try push vm (call_closure cl args cl.vm_env_ref)
|
push_closure_frame vm cl args
|
||||||
with _e -> push vm (cek_call_or_suspend vm f (List args)))
|
|
||||||
| None ->
|
| None ->
|
||||||
push vm (cek_call_or_suspend vm f (List args))
|
push vm (cek_call_or_suspend vm f (List args))
|
||||||
end
|
end
|
||||||
@@ -360,6 +451,10 @@ and run vm =
|
|||||||
let op = bc.(frame.ip) in
|
let op = bc.(frame.ip) in
|
||||||
frame.ip <- frame.ip + 1;
|
frame.ip <- frame.ip + 1;
|
||||||
incr _vm_insn_count;
|
incr _vm_insn_count;
|
||||||
|
(* Check timeout — compare VM instruction count against step limit *)
|
||||||
|
if !_vm_insn_count land 0xFFFF = 0 && !Sx_ref.step_limit > 0
|
||||||
|
&& !_vm_insn_count > !Sx_ref.step_limit then
|
||||||
|
raise (Eval_error "TIMEOUT: step limit exceeded");
|
||||||
(try match op with
|
(try match op with
|
||||||
(* ---- Constants ---- *)
|
(* ---- Constants ---- *)
|
||||||
| 1 (* OP_CONST *) ->
|
| 1 (* OP_CONST *) ->
|
||||||
@@ -426,7 +521,14 @@ and run vm =
|
|||||||
| None ->
|
| None ->
|
||||||
try Hashtbl.find vm.globals name with Not_found ->
|
try Hashtbl.find vm.globals name with Not_found ->
|
||||||
try Sx_primitives.get_primitive name
|
try Sx_primitives.get_primitive name
|
||||||
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
with _ ->
|
||||||
|
(* Try resolve hook — loads the library that exports this symbol *)
|
||||||
|
(try
|
||||||
|
let resolve_fn = Hashtbl.find vm.globals "__resolve-symbol" in
|
||||||
|
ignore (Sx_runtime.sx_call resolve_fn [String name]);
|
||||||
|
try Hashtbl.find vm.globals name
|
||||||
|
with Not_found -> raise (Eval_error ("VM undefined: " ^ name))
|
||||||
|
with Not_found -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||||
in
|
in
|
||||||
push vm v
|
push vm v
|
||||||
| 21 (* OP_GLOBAL_SET *) ->
|
| 21 (* OP_GLOBAL_SET *) ->
|
||||||
@@ -571,6 +673,11 @@ and run vm =
|
|||||||
Primitives are seeded into vm.globals at init as NativeFn values.
|
Primitives are seeded into vm.globals at init as NativeFn values.
|
||||||
OP_DEFINE and registerNative naturally override them. *)
|
OP_DEFINE and registerNative naturally override them. *)
|
||||||
let fn_val = try Hashtbl.find vm.globals name with Not_found ->
|
let fn_val = try Hashtbl.find vm.globals name with Not_found ->
|
||||||
|
(* Fallback to Sx_primitives — primitives registered AFTER JIT
|
||||||
|
setup (e.g. host-global, host-get registered inside the test
|
||||||
|
runner's bind/register path) are not in vm.globals. *)
|
||||||
|
try Sx_primitives.get_primitive name
|
||||||
|
with _ ->
|
||||||
raise (Eval_error ("VM: unknown primitive " ^ name))
|
raise (Eval_error ("VM: unknown primitive " ^ name))
|
||||||
in
|
in
|
||||||
(match fn_val with
|
(match fn_val with
|
||||||
@@ -732,23 +839,74 @@ and run vm =
|
|||||||
done
|
done
|
||||||
|
|
||||||
(** Resume a suspended VM by pushing the IO result and continuing.
|
(** Resume a suspended VM by pushing the IO result and continuing.
|
||||||
May raise VmSuspended again if the VM hits another OP_PERFORM. *)
|
May raise VmSuspended again if the VM hits another OP_PERFORM.
|
||||||
|
|
||||||
|
After the callback finishes, restores any call_closure_reuse
|
||||||
|
continuations saved on vm.reuse_stack (innermost first). *)
|
||||||
let resume_vm vm result =
|
let resume_vm vm result =
|
||||||
(match vm.pending_cek with
|
(match vm.pending_cek with
|
||||||
| Some cek_state ->
|
| Some cek_state ->
|
||||||
(* Resume the suspended CEK evaluation first *)
|
|
||||||
vm.pending_cek <- None;
|
vm.pending_cek <- None;
|
||||||
let final = Sx_ref.cek_resume cek_state result in
|
let final = Sx_ref.cek_resume cek_state result in
|
||||||
(match Sx_runtime.get_val final (String "phase") with
|
(match Sx_runtime.get_val final (String "phase") with
|
||||||
| String "io-suspended" ->
|
| String "io-suspended" ->
|
||||||
(* CEK suspended again — re-suspend the VM *)
|
|
||||||
vm.pending_cek <- Some final;
|
vm.pending_cek <- Some final;
|
||||||
raise (VmSuspended (Sx_runtime.get_val final (String "request"), vm))
|
raise (VmSuspended (Sx_runtime.get_val final (String "request"), vm))
|
||||||
| _ ->
|
| _ ->
|
||||||
push vm (Sx_ref.cek_value final))
|
push vm (Sx_ref.cek_value final))
|
||||||
| None ->
|
| None ->
|
||||||
push vm result);
|
push vm result);
|
||||||
|
(try run vm
|
||||||
|
with
|
||||||
|
| VmSuspended _ as e ->
|
||||||
|
(* Re-suspension during resume: the VM hit another perform. *)
|
||||||
|
raise e
|
||||||
|
| Eval_error msg ->
|
||||||
|
(* Error during resumed execution. If the VM has a handler on its
|
||||||
|
handler_stack, dispatch to it (same as OP_RAISE). This enables
|
||||||
|
try/catch across async perform/resume boundaries — the handler
|
||||||
|
was pushed before the perform and survives on the vm struct. *)
|
||||||
|
(match vm.handler_stack with
|
||||||
|
| entry :: rest ->
|
||||||
|
vm.handler_stack <- rest;
|
||||||
|
while List.length vm.frames > entry.h_frame_depth do
|
||||||
|
match vm.frames with _ :: fs -> vm.frames <- fs | [] -> ()
|
||||||
|
done;
|
||||||
|
vm.sp <- entry.h_sp;
|
||||||
|
entry.h_frame.ip <- entry.h_catch_ip;
|
||||||
|
push vm (String msg);
|
||||||
|
run vm
|
||||||
|
| [] -> raise (Eval_error msg)));
|
||||||
|
(* Clear reuse_stack — any entries here are stale from the original
|
||||||
|
suspension and don't apply to the current state. The VM just
|
||||||
|
completed its execution successfully. *)
|
||||||
|
vm.reuse_stack <- [];
|
||||||
|
(* Restore call_closure_reuse continuations saved during suspension.
|
||||||
|
reuse_stack is in catch order (outermost first from prepend) —
|
||||||
|
reverse to get innermost first, matching callback→caller unwinding. *)
|
||||||
|
let rec restore_reuse pending =
|
||||||
|
match pending with
|
||||||
|
| [] -> ()
|
||||||
|
| (saved_frames, _saved_sp) :: rest ->
|
||||||
|
let callback_result = pop vm in
|
||||||
|
vm.frames <- saved_frames;
|
||||||
|
push vm callback_result;
|
||||||
|
(try
|
||||||
run vm;
|
run vm;
|
||||||
|
(* Check for new reuse entries added by nested call_closure_reuse *)
|
||||||
|
let new_pending = List.rev vm.reuse_stack in
|
||||||
|
vm.reuse_stack <- [];
|
||||||
|
restore_reuse (new_pending @ rest)
|
||||||
|
with VmSuspended _ as e ->
|
||||||
|
(* Re-suspension: save unprocessed entries back for next resume.
|
||||||
|
rest is innermost-first; vm.reuse_stack is outermost-first.
|
||||||
|
Combine so next resume's reversal yields: new_inner, old_inner→outer. *)
|
||||||
|
vm.reuse_stack <- (List.rev rest) @ vm.reuse_stack;
|
||||||
|
raise e)
|
||||||
|
in
|
||||||
|
let pending = List.rev vm.reuse_stack in
|
||||||
|
vm.reuse_stack <- [];
|
||||||
|
restore_reuse pending;
|
||||||
pop vm
|
pop vm
|
||||||
|
|
||||||
(** Execute a compiled module (top-level bytecode). *)
|
(** Execute a compiled module (top-level bytecode). *)
|
||||||
@@ -782,33 +940,91 @@ let execute_module_safe code globals =
|
|||||||
The compilation cost is a single CEK evaluation of the compiler —
|
The compilation cost is a single CEK evaluation of the compiler —
|
||||||
microseconds per function. The result is cached in the lambda/component
|
microseconds per function. The result is cached in the lambda/component
|
||||||
record so subsequent calls go straight to the VM. *)
|
record so subsequent calls go straight to the VM. *)
|
||||||
|
(* Functions whose JIT bytecode is known broken (see project_jit_bytecode_bug):
|
||||||
|
parser combinators drop intermediate results, the hyperscript parse/compile
|
||||||
|
stack corrupts ASTs when compiled, and test-orchestration helpers have
|
||||||
|
call-count/arg-shape mismatches vs CEK. These must run under CEK. *)
|
||||||
|
let _jit_is_broken_name n =
|
||||||
|
(* Parser combinators *)
|
||||||
|
n = "parse-bind" || n = "seq" || n = "seq2" || n = "many" || n = "many1"
|
||||||
|
|| n = "satisfy" || n = "fmap" || n = "alt" || n = "alt2"
|
||||||
|
|| n = "skip-left" || n = "skip-right" || n = "skip-many" || n = "optional"
|
||||||
|
|| n = "between" || n = "sep-by" || n = "sep-by1" || n = "parse-char"
|
||||||
|
|| n = "parse-string" || n = "lazy-parser" || n = "label"
|
||||||
|
|| n = "not-followed-by" || n = "look-ahead"
|
||||||
|
(* Hyperscript orchestrators — call parser combinators *)
|
||||||
|
|| n = "hs-tokenize" || n = "hs-parse" || n = "hs-compile"
|
||||||
|
|| n = "hs-to-sx" || n = "hs-to-sx-from-source"
|
||||||
|
(* Test orchestration helpers *)
|
||||||
|
|| n = "eval-hs" || n = "eval-hs-inner" || n = "eval-hs-with-me"
|
||||||
|
|| n = "run-hs-fixture"
|
||||||
|
(* Large top-level functions whose JIT compile exceeds the 5s test
|
||||||
|
deadline — tw-resolve-style, tw-resolve-layout, graphql parse. *)
|
||||||
|
|| n = "tw-resolve-style" || n = "tw-resolve-layout"
|
||||||
|
|| n = "gql-ws?" || n = "gql-parse-tokens" || n = "gql-execute-operation"
|
||||||
|
(* Hyperscript loop runtime: uses `guard` to catch hs-break/hs-continue
|
||||||
|
exceptions. JIT-compiled guard drops the exception handler such that
|
||||||
|
break propagates out of the click handler instead of exiting the loop.
|
||||||
|
See hs-upstream-repeat/hs-upstream-put tests. *)
|
||||||
|
|| n = "hs-repeat-times" || n = "hs-repeat-forever"
|
||||||
|
|| n = "hs-repeat-while" || n = "hs-repeat-until"
|
||||||
|
|| n = "hs-for-each" || n = "hs-put!"
|
||||||
|
|
||||||
let jit_compile_lambda (l : lambda) globals =
|
let jit_compile_lambda (l : lambda) globals =
|
||||||
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
||||||
|
if !_jit_compiling then (
|
||||||
|
(* Already compiling — prevent cascade. The CEK will handle this call. *)
|
||||||
|
None
|
||||||
|
) else if List.mem "&key" l.l_params || List.mem ":as" l.l_params then (
|
||||||
|
(* &key/:as require complex runtime argument processing that the compiler
|
||||||
|
doesn't emit. These functions must run via CEK. *)
|
||||||
|
None
|
||||||
|
) else if l.l_name = None || l.l_closure.Sx_types.parent <> None then (
|
||||||
|
(* Anonymous or nested lambdas: skip JIT. Nested defines get re-created
|
||||||
|
on each outer call, so per-call compile cost is pure overhead. *)
|
||||||
|
None
|
||||||
|
) else if _jit_is_broken_name fn_name then (
|
||||||
|
None
|
||||||
|
) else
|
||||||
try
|
try
|
||||||
|
_jit_compiling := true;
|
||||||
let compile_fn = try Hashtbl.find globals "compile"
|
let compile_fn = try Hashtbl.find globals "compile"
|
||||||
with Not_found -> raise (Eval_error "JIT: compiler not loaded") in
|
with Not_found -> (_jit_compiling := false; 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 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 fn_expr = List [Symbol "fn"; param_syms; l.l_body] in
|
||||||
let quoted = List [Symbol "quote"; fn_expr] in
|
let quoted = List [Symbol "quote"; fn_expr] in
|
||||||
(* Use Symbol "compile" so the CEK resolves it from the env, not
|
(* Fast path: if compile has bytecode, call it directly via the VM.
|
||||||
an embedded VmClosure value — the CEK dispatches VmClosure calls
|
All helper calls (compile-expr, emit-byte, etc.) happen inside the
|
||||||
differently when the value is resolved from env vs embedded in AST. *)
|
same VM execution — no per-call VM allocation overhead. *)
|
||||||
|
let result = match compile_fn with
|
||||||
|
| Lambda { l_compiled = Some cl; _ } when not (is_jit_failed cl) ->
|
||||||
|
call_closure cl [fn_expr] globals
|
||||||
|
| _ ->
|
||||||
ignore compile_fn;
|
ignore compile_fn;
|
||||||
let compile_env = Sx_types.env_extend (Sx_types.make_env ()) in
|
let compile_env = Sx_types.env_extend (Sx_types.make_env ()) in
|
||||||
Hashtbl.iter (fun k v -> Hashtbl.replace compile_env.bindings (Sx_types.intern k) v) globals;
|
Hashtbl.iter (fun k v -> Hashtbl.replace compile_env.bindings (Sx_types.intern k) v) globals;
|
||||||
let result = Sx_ref.eval_expr (List [Symbol "compile"; quoted]) (Env compile_env) in
|
Sx_ref.eval_expr (List [Symbol "compile"; quoted]) (Env compile_env)
|
||||||
(* Closure vars are accessible via vm_closure_env (set on the VmClosure
|
in
|
||||||
at line ~617). OP_GLOBAL_GET falls back to vm_closure_env when vars
|
_jit_compiling := false;
|
||||||
aren't in globals. No injection into the shared globals table —
|
(* Merge closure bindings into effective_globals so GLOBAL_GET resolves
|
||||||
that would break closure isolation for factory functions like
|
variables from let/define blocks. The compiler emits GLOBAL_GET for
|
||||||
make-page-fn where multiple closures capture different values
|
free variables; the VM resolves them from vm_env_ref. *)
|
||||||
for the same variable names. *)
|
let effective_globals =
|
||||||
let effective_globals = globals in
|
if Hashtbl.length l.l_closure.Sx_types.bindings > 0 then begin
|
||||||
|
let merged = Hashtbl.copy globals in
|
||||||
|
let rec merge_env env =
|
||||||
|
Hashtbl.iter (fun id v ->
|
||||||
|
let name = Sx_types.unintern id in
|
||||||
|
if not (Hashtbl.mem merged name) then
|
||||||
|
Hashtbl.replace merged name v) env.Sx_types.bindings;
|
||||||
|
match env.Sx_types.parent with Some p -> merge_env p | None -> ()
|
||||||
|
in
|
||||||
|
merge_env l.l_closure;
|
||||||
|
merged
|
||||||
|
end else globals
|
||||||
|
in
|
||||||
(match result with
|
(match result with
|
||||||
| Dict d when Hashtbl.mem d "bytecode" ->
|
| Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
|
||||||
let outer_code = code_from_value result in
|
let outer_code = code_from_value result in
|
||||||
let bc = outer_code.vc_bytecode in
|
let bc = outer_code.vc_bytecode in
|
||||||
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
|
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
|
||||||
@@ -821,21 +1037,13 @@ let jit_compile_lambda (l : lambda) globals =
|
|||||||
else begin
|
else begin
|
||||||
Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
|
Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
|
||||||
fn_name idx (Array.length outer_code.vc_constants);
|
fn_name idx (Array.length outer_code.vc_constants);
|
||||||
|
|
||||||
None
|
None
|
||||||
end
|
end
|
||||||
end else begin
|
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
|
(try
|
||||||
let value = execute_module outer_code globals in
|
let value = execute_module outer_code globals in
|
||||||
Printf.eprintf "[jit] RESOLVED %s: %s (bc[0]=%d)\n%!"
|
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);
|
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
|
None
|
||||||
with _ ->
|
with _ ->
|
||||||
Printf.eprintf "[jit] SKIP %s: non-closure execution failed (bc[0]=%d, len=%d)\n%!"
|
Printf.eprintf "[jit] SKIP %s: non-closure execution failed (bc[0]=%d, len=%d)\n%!"
|
||||||
@@ -846,12 +1054,73 @@ let jit_compile_lambda (l : lambda) globals =
|
|||||||
Printf.eprintf "[jit] FAIL %s: compiler returned %s\n%!" fn_name (type_of result);
|
Printf.eprintf "[jit] FAIL %s: compiler returned %s\n%!" fn_name (type_of result);
|
||||||
None)
|
None)
|
||||||
with e ->
|
with e ->
|
||||||
|
_jit_compiling := false;
|
||||||
Printf.eprintf "[jit] FAIL %s: %s\n%!" fn_name (Printexc.to_string e);
|
Printf.eprintf "[jit] FAIL %s: %s\n%!" fn_name (Printexc.to_string e);
|
||||||
None
|
None
|
||||||
|
|
||||||
(* Wire up forward references *)
|
(* Wire up forward references *)
|
||||||
let () = jit_compile_ref := jit_compile_lambda
|
let () = jit_compile_ref := jit_compile_lambda
|
||||||
let () = _vm_call_closure_ref := (fun cl args -> call_closure cl args cl.vm_env_ref)
|
let () = _vm_call_closure_ref := (fun cl args -> call_closure_reuse cl args)
|
||||||
|
let () = _vm_suspension_to_dict := (fun exn ->
|
||||||
|
match exn with
|
||||||
|
| VmSuspended (request, vm) ->
|
||||||
|
(* Snapshot pending_cek and reuse_stack NOW — a nested cek_call_or_suspend
|
||||||
|
on the same VM may overwrite them before our resume function is called. *)
|
||||||
|
let saved_cek = vm.pending_cek in
|
||||||
|
let saved_reuse = vm.reuse_stack in
|
||||||
|
let d = Hashtbl.create 3 in
|
||||||
|
Hashtbl.replace d "__vm_suspended" (Bool true);
|
||||||
|
Hashtbl.replace d "request" request;
|
||||||
|
Hashtbl.replace d "resume" (NativeFn ("vm-resume", fun args ->
|
||||||
|
match args with
|
||||||
|
| [result] ->
|
||||||
|
(* Restore saved state before resuming — may have been overwritten
|
||||||
|
by a nested suspension on the same VM. *)
|
||||||
|
vm.pending_cek <- saved_cek;
|
||||||
|
vm.reuse_stack <- saved_reuse;
|
||||||
|
(try resume_vm vm result
|
||||||
|
with exn2 ->
|
||||||
|
match !_vm_suspension_to_dict exn2 with
|
||||||
|
| Some marker -> marker
|
||||||
|
| None -> raise exn2)
|
||||||
|
| _ -> Nil));
|
||||||
|
Some (Dict d)
|
||||||
|
| _ -> None)
|
||||||
|
(* Hook: when eval_expr (cek_run_iterative) encounters a CEK suspension,
|
||||||
|
convert it to VmSuspended so it propagates to the outer handler
|
||||||
|
(value_to_js wrapper, _driveAsync, etc.). Without this, perform
|
||||||
|
inside nested eval_expr calls (event handler → trampoline → eval_expr)
|
||||||
|
gets swallowed as "IO suspension in non-IO context". *)
|
||||||
|
let () = _cek_io_suspend_hook := Some (fun suspended_state ->
|
||||||
|
let request = Sx_ref.cek_io_request suspended_state in
|
||||||
|
let vm = create !_default_vm_globals in
|
||||||
|
vm.pending_cek <- Some suspended_state;
|
||||||
|
(* Transfer reuse_stack from the active VM so resume_vm can restore
|
||||||
|
caller frames saved by call_closure_reuse during the suspension chain. *)
|
||||||
|
(match !_active_vm with
|
||||||
|
| Some active when active.reuse_stack <> [] ->
|
||||||
|
vm.reuse_stack <- active.reuse_stack;
|
||||||
|
active.reuse_stack <- []
|
||||||
|
| _ -> ());
|
||||||
|
raise (VmSuspended (request, vm)))
|
||||||
|
|
||||||
|
let () = _cek_eval_lambda_ref := (fun f args ->
|
||||||
|
let state = Sx_ref.continue_with_call f (List args) (Env (make_env ())) (List args) (List []) in
|
||||||
|
let final = Sx_ref.cek_step_loop state in
|
||||||
|
match Sx_runtime.get_val final (String "phase") with
|
||||||
|
| String "io-suspended" ->
|
||||||
|
(* Create a stub VM to carry the suspended CEK state.
|
||||||
|
resume_vm will: cek_resume → push result → run (no-op, no frames) → pop *)
|
||||||
|
let vm = create (Hashtbl.create 0) in
|
||||||
|
vm.pending_cek <- Some final;
|
||||||
|
(* Transfer reuse_stack from active VM *)
|
||||||
|
(match !_active_vm with
|
||||||
|
| Some active when active.reuse_stack <> [] ->
|
||||||
|
vm.reuse_stack <- active.reuse_stack;
|
||||||
|
active.reuse_stack <- []
|
||||||
|
| _ -> ());
|
||||||
|
raise (VmSuspended (Sx_runtime.get_val final (String "request"), vm))
|
||||||
|
| _ -> Sx_ref.cek_value final)
|
||||||
|
|
||||||
|
|
||||||
(** {1 Debugging / introspection} *)
|
(** {1 Debugging / introspection} *)
|
||||||
|
|||||||
@@ -292,7 +292,7 @@ let vm_create_closure vm_val frame_val code_val =
|
|||||||
|
|
||||||
(* --- JIT sentinel --- *)
|
(* --- JIT sentinel --- *)
|
||||||
let _jit_failed_sentinel = {
|
let _jit_failed_sentinel = {
|
||||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
||||||
vc_bytecode_list = None; vc_constants_list = None };
|
vc_bytecode_list = None; vc_constants_list = None };
|
||||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||||
}
|
}
|
||||||
|
|||||||
749
hosts/ocaml/shared/static/wasm/sx-platform.js
Normal file
749
hosts/ocaml/shared/static/wasm/sx-platform.js
Normal file
@@ -0,0 +1,749 @@
|
|||||||
|
/**
|
||||||
|
* sx-platform.js — Browser platform layer for the SX WASM kernel.
|
||||||
|
*
|
||||||
|
* Registers the 8 FFI host primitives and loads web adapter .sx files.
|
||||||
|
* This is the only JS needed beyond the WASM kernel itself.
|
||||||
|
*
|
||||||
|
* Usage:
|
||||||
|
* <script src="sx_browser.bc.wasm.js"></script>
|
||||||
|
* <script src="sx-platform.js"></script>
|
||||||
|
*
|
||||||
|
* Or for js_of_ocaml mode:
|
||||||
|
* <script src="sx_browser.bc.js"></script>
|
||||||
|
* <script src="sx-platform.js"></script>
|
||||||
|
*/
|
||||||
|
|
||||||
|
(function() {
|
||||||
|
"use strict";
|
||||||
|
|
||||||
|
function boot(K) {
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// FFI Host Primitives
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
// Lazy module loading — islands/components call this to declare dependencies
|
||||||
|
K.registerNative("load-library!", function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
if (!name) return false;
|
||||||
|
return __sxLoadLibrary(name) || false;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-global", function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||||
|
if (typeof window !== "undefined" && name in window) return window[name];
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-get", function(args) {
|
||||||
|
var obj = args[0], prop = args[1];
|
||||||
|
if (obj == null) return null;
|
||||||
|
var v = obj[prop];
|
||||||
|
if (v === undefined) return null;
|
||||||
|
// Functions can't cross the WASM boundary — return true as a truthy
|
||||||
|
// sentinel so (host-get el "getAttribute") works as a guard.
|
||||||
|
// Use host-call to actually invoke the method.
|
||||||
|
if (typeof v === "function") return true;
|
||||||
|
return v;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-set!", function(args) {
|
||||||
|
var obj = args[0], prop = args[1], val = args[2];
|
||||||
|
if (obj != null) obj[prop] = val;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-call", function(args) {
|
||||||
|
var obj = args[0], method = args[1];
|
||||||
|
var callArgs = [];
|
||||||
|
for (var i = 2; i < args.length; i++) callArgs.push(args[i]);
|
||||||
|
if (obj == null) {
|
||||||
|
// Global function call
|
||||||
|
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
|
||||||
|
if (typeof fn === "function") return fn.apply(null, callArgs);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
if (typeof obj[method] === "function") {
|
||||||
|
try { return obj[method].apply(obj, callArgs); }
|
||||||
|
catch(e) { console.error("[sx] host-call error:", e); return null; }
|
||||||
|
}
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-new", function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
var cArgs = args.slice(1);
|
||||||
|
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
|
||||||
|
if (typeof Ctor !== "function") return null;
|
||||||
|
switch (cArgs.length) {
|
||||||
|
case 0: return new Ctor();
|
||||||
|
case 1: return new Ctor(cArgs[0]);
|
||||||
|
case 2: return new Ctor(cArgs[0], cArgs[1]);
|
||||||
|
case 3: return new Ctor(cArgs[0], cArgs[1], cArgs[2]);
|
||||||
|
default: return new Ctor(cArgs[0], cArgs[1], cArgs[2], cArgs[3]);
|
||||||
|
}
|
||||||
|
});
|
||||||
|
|
||||||
|
// IO suspension driver — resumes suspended callFn results (wait, fetch, etc.)
|
||||||
|
if (!window._driveAsync) {
|
||||||
|
window._driveAsync = function driveAsync(result) {
|
||||||
|
if (!result || !result.suspended) return;
|
||||||
|
var req = result.request;
|
||||||
|
var items = req && (req.items || req);
|
||||||
|
var op = items && items[0];
|
||||||
|
var opName = typeof op === "string" ? op : (op && op.name) || String(op);
|
||||||
|
var arg = items && items[1];
|
||||||
|
if (opName === "io-sleep" || opName === "wait") {
|
||||||
|
setTimeout(function() {
|
||||||
|
try { driveAsync(result.resume(null)); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||||
|
}, typeof arg === "number" ? arg : 0);
|
||||||
|
} else if (opName === "io-fetch") {
|
||||||
|
fetch(typeof arg === "string" ? arg : "").then(function(r) { return r.text(); }).then(function(t) {
|
||||||
|
try { driveAsync(result.resume({ok: true, text: t})); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||||
|
});
|
||||||
|
} else if (opName === "io-navigate") {
|
||||||
|
// navigation — don't resume
|
||||||
|
} else {
|
||||||
|
console.warn("[sx] unhandled IO:", opName);
|
||||||
|
}
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
|
K.registerNative("host-callback", function(args) {
|
||||||
|
var fn = args[0];
|
||||||
|
// Native JS function — pass through
|
||||||
|
if (typeof fn === "function") return fn;
|
||||||
|
// SX callable (has __sx_handle) — wrap as JS function
|
||||||
|
if (fn && fn.__sx_handle !== undefined) {
|
||||||
|
return function() {
|
||||||
|
var a = Array.prototype.slice.call(arguments);
|
||||||
|
var r = K.callFn(fn, a);
|
||||||
|
if (window._driveAsync) window._driveAsync(r);
|
||||||
|
return r;
|
||||||
|
};
|
||||||
|
}
|
||||||
|
return function() {};
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-typeof", function(args) {
|
||||||
|
var obj = args[0];
|
||||||
|
if (obj == null) 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;
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("host-await", function(args) {
|
||||||
|
var promise = args[0], callback = args[1];
|
||||||
|
if (promise && typeof promise.then === "function") {
|
||||||
|
var cb;
|
||||||
|
if (typeof callback === "function") cb = callback;
|
||||||
|
else if (callback && callback.__sx_handle !== undefined)
|
||||||
|
cb = function(v) { return K.callFn(callback, [v]); };
|
||||||
|
else cb = function() {};
|
||||||
|
promise.then(cb);
|
||||||
|
}
|
||||||
|
});
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Constants expected by .sx files
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
K.eval('(define SX_VERSION "wasm-1.0")');
|
||||||
|
K.eval('(define SX_ENGINE "ocaml-vm-wasm")');
|
||||||
|
K.eval('(define parse sx-parse)');
|
||||||
|
K.eval('(define serialize sx-serialize)');
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// DOM query helpers used by boot.sx / orchestration.sx
|
||||||
|
// (These are JS-native in the transpiled bundle; here via FFI.)
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
K.registerNative("query-sx-scripts", function(args) {
|
||||||
|
var root = (args[0] && args[0] !== null) ? args[0] : document;
|
||||||
|
if (typeof root.querySelectorAll !== "function") root = document;
|
||||||
|
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"]'));
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("query-page-scripts", function(args) {
|
||||||
|
return Array.prototype.slice.call(document.querySelectorAll('script[type="text/sx-pages"]'));
|
||||||
|
});
|
||||||
|
|
||||||
|
K.registerNative("query-component-scripts", function(args) {
|
||||||
|
var root = (args[0] && args[0] !== null) ? args[0] : document;
|
||||||
|
if (typeof root.querySelectorAll !== "function") root = document;
|
||||||
|
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"][data-components]'));
|
||||||
|
});
|
||||||
|
|
||||||
|
// localStorage
|
||||||
|
K.registerNative("local-storage-get", function(args) {
|
||||||
|
try { var v = localStorage.getItem(args[0]); return v === null ? null : v; }
|
||||||
|
catch(e) { return null; }
|
||||||
|
});
|
||||||
|
K.registerNative("local-storage-set", function(args) {
|
||||||
|
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||||
|
});
|
||||||
|
K.registerNative("local-storage-remove", function(args) {
|
||||||
|
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||||
|
});
|
||||||
|
|
||||||
|
// log-info/log-warn defined in browser.sx; log-error as native fallback
|
||||||
|
K.registerNative("log-error", function(args) { console.error.apply(console, ["[sx]"].concat(args)); });
|
||||||
|
|
||||||
|
// Cookie access (browser-side)
|
||||||
|
K.registerNative("get-cookie", function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
var match = document.cookie.match(new RegExp('(?:^|; )' + name.replace(/[.*+?^${}()|[\]\\]/g, '\\$&') + '=([^;]*)'));
|
||||||
|
return match ? decodeURIComponent(match[1]) : null;
|
||||||
|
});
|
||||||
|
K.registerNative("set-cookie", function(args) {
|
||||||
|
document.cookie = args[0] + "=" + encodeURIComponent(args[1] || "") + ";path=/;max-age=31536000;SameSite=Lax";
|
||||||
|
});
|
||||||
|
|
||||||
|
// IntersectionObserver — native JS to avoid bytecode callback issues
|
||||||
|
K.registerNative("observe-intersection", function(args) {
|
||||||
|
var el = args[0], callback = args[1], once = args[2], delay = args[3];
|
||||||
|
var obs = new IntersectionObserver(function(entries) {
|
||||||
|
for (var i = 0; i < entries.length; i++) {
|
||||||
|
if (entries[i].isIntersecting) {
|
||||||
|
var d = (delay && delay !== null) ? delay : 0;
|
||||||
|
setTimeout(function() { K.callFn(callback, []); }, d);
|
||||||
|
if (once) obs.unobserve(el);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
});
|
||||||
|
obs.observe(el);
|
||||||
|
return obs;
|
||||||
|
});
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Load SX web libraries and adapters
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
// Load order follows dependency graph:
|
||||||
|
// 1. Core spec files (parser, render, primitives already compiled into WASM kernel)
|
||||||
|
// 2. Spec modules: signals, deps, router, page-helpers
|
||||||
|
// 3. Bytecode compiler + VM (for JIT in browser)
|
||||||
|
// 4. Web libraries: dom.sx, browser.sx (built on 8 FFI primitives)
|
||||||
|
// 5. Web adapters: adapter-html, adapter-sx, adapter-dom
|
||||||
|
// 6. Web framework: engine, orchestration, boot
|
||||||
|
|
||||||
|
var _baseUrl = "";
|
||||||
|
|
||||||
|
// Detect base URL and cache-bust params from current script tag.
|
||||||
|
// _cacheBust comes from the script's own ?v= query string (used for .sx source fallback).
|
||||||
|
// _sxbcCacheBust comes from data-sxbc-hash attribute — a separate content hash
|
||||||
|
// covering all .sxbc files so each file gets its own correct cache buster.
|
||||||
|
var _cacheBust = "";
|
||||||
|
var _sxbcCacheBust = "";
|
||||||
|
(function() {
|
||||||
|
if (typeof document !== "undefined") {
|
||||||
|
var scripts = document.getElementsByTagName("script");
|
||||||
|
for (var i = scripts.length - 1; i >= 0; i--) {
|
||||||
|
var src = scripts[i].src || "";
|
||||||
|
if (src.indexOf("sx-platform") !== -1) {
|
||||||
|
_baseUrl = src.substring(0, src.lastIndexOf("/") + 1);
|
||||||
|
var qi = src.indexOf("?");
|
||||||
|
if (qi !== -1) _cacheBust = src.substring(qi);
|
||||||
|
var sxbcHash = scripts[i].getAttribute("data-sxbc-hash");
|
||||||
|
if (sxbcHash) _sxbcCacheBust = "?v=" + sxbcHash;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
})();
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Deserialize type-tagged JSON constant back to JS value for loadModule.
|
||||||
|
*/
|
||||||
|
function deserializeConstant(c) {
|
||||||
|
if (!c || !c.t) return null;
|
||||||
|
switch (c.t) {
|
||||||
|
case 's': return c.v;
|
||||||
|
case 'n': return c.v;
|
||||||
|
case 'b': return c.v;
|
||||||
|
case 'nil': return null;
|
||||||
|
case 'sym': return { _type: 'symbol', name: c.v };
|
||||||
|
case 'kw': return { _type: 'keyword', name: c.v };
|
||||||
|
case 'list': return { _type: 'list', items: (c.v || []).map(deserializeConstant) };
|
||||||
|
case 'code': return {
|
||||||
|
_type: 'dict',
|
||||||
|
bytecode: { _type: 'list', items: c.v.bytecode },
|
||||||
|
constants: { _type: 'list', items: (c.v.constants || []).map(deserializeConstant) },
|
||||||
|
arity: c.v.arity || 0,
|
||||||
|
'upvalue-count': c.v['upvalue-count'] || 0,
|
||||||
|
locals: c.v.locals || 0,
|
||||||
|
};
|
||||||
|
case 'dict': {
|
||||||
|
var d = { _type: 'dict' };
|
||||||
|
for (var k in c.v) d[k] = deserializeConstant(c.v[k]);
|
||||||
|
return d;
|
||||||
|
}
|
||||||
|
default: return null;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Convert a parsed SX code form ({_type:"list", items:[symbol"code", ...]})
|
||||||
|
* into the dict format that K.loadModule / js_to_value expects.
|
||||||
|
* Mirrors the OCaml convert_code/convert_const in sx_browser.ml.
|
||||||
|
*/
|
||||||
|
function convertCodeForm(form) {
|
||||||
|
if (!form || form._type !== "list" || !form.items || !form.items.length) return null;
|
||||||
|
var items = form.items;
|
||||||
|
if (!items[0] || items[0]._type !== "symbol" || items[0].name !== "code") return null;
|
||||||
|
|
||||||
|
var d = { _type: "dict", arity: 0, "upvalue-count": 0 };
|
||||||
|
for (var i = 1; i < items.length; i++) {
|
||||||
|
var item = items[i];
|
||||||
|
if (item && item._type === "keyword" && i + 1 < items.length) {
|
||||||
|
var val = items[i + 1];
|
||||||
|
if (item.name === "arity" || item.name === "upvalue-count") {
|
||||||
|
d[item.name] = (typeof val === "number") ? val : 0;
|
||||||
|
} else if (item.name === "bytecode" && val && val._type === "list") {
|
||||||
|
d.bytecode = val; // {_type:"list", items:[numbers...]}
|
||||||
|
} else if (item.name === "constants" && val && val._type === "list") {
|
||||||
|
d.constants = { _type: "list", items: (val.items || []).map(convertConst) };
|
||||||
|
}
|
||||||
|
i++; // skip value
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return d;
|
||||||
|
}
|
||||||
|
|
||||||
|
function convertConst(c) {
|
||||||
|
if (!c || typeof c !== "object") return c; // number, string, boolean, null pass through
|
||||||
|
if (c._type === "list" && c.items && c.items.length > 0) {
|
||||||
|
var head = c.items[0];
|
||||||
|
if (head && head._type === "symbol" && head.name === "code") {
|
||||||
|
return convertCodeForm(c);
|
||||||
|
}
|
||||||
|
if (head && head._type === "symbol" && head.name === "list") {
|
||||||
|
return { _type: "list", items: c.items.slice(1).map(convertConst) };
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return c; // symbols, keywords, etc. pass through
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Try loading a pre-compiled .sxbc bytecode module (SX text format).
|
||||||
|
* Uses K.loadModule which handles VM suspension (import requests).
|
||||||
|
* Returns true on success, null on failure (caller falls back to .sx source).
|
||||||
|
*/
|
||||||
|
function loadBytecodeFile(path) {
|
||||||
|
var sxbcPath = path.replace(/\.sx$/, '.sxbc');
|
||||||
|
var url = _baseUrl + sxbcPath + _sxbcCacheBust;
|
||||||
|
try {
|
||||||
|
var xhr = new XMLHttpRequest();
|
||||||
|
xhr.open("GET", url, false);
|
||||||
|
xhr.send();
|
||||||
|
if (xhr.status !== 200) return null;
|
||||||
|
|
||||||
|
// Parse the sxbc text to get the SX tree
|
||||||
|
var parsed = K.parse(xhr.responseText);
|
||||||
|
if (!parsed || !parsed.length) return null;
|
||||||
|
var sxbc = parsed[0]; // (sxbc version hash (code ...))
|
||||||
|
if (!sxbc || sxbc._type !== "list" || !sxbc.items) return null;
|
||||||
|
|
||||||
|
// Extract the code form — 3rd or 4th item (after sxbc, version, optional hash)
|
||||||
|
var codeForm = null;
|
||||||
|
for (var i = 1; i < sxbc.items.length; i++) {
|
||||||
|
var item = sxbc.items[i];
|
||||||
|
if (item && item._type === "list" && item.items && item.items.length > 0 &&
|
||||||
|
item.items[0] && item.items[0]._type === "symbol" && item.items[0].name === "code") {
|
||||||
|
codeForm = item;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (!codeForm) return null;
|
||||||
|
|
||||||
|
// Convert the SX code form to a dict for loadModule
|
||||||
|
var moduleDict = convertCodeForm(codeForm);
|
||||||
|
if (!moduleDict) return null;
|
||||||
|
|
||||||
|
// Load via K.loadModule which handles VmSuspended
|
||||||
|
var result = K.loadModule(moduleDict);
|
||||||
|
|
||||||
|
// Handle import suspensions — fetch missing libraries on demand
|
||||||
|
while (result && result.suspended && result.op === "import") {
|
||||||
|
var req = result.request;
|
||||||
|
var libName = req && req.library;
|
||||||
|
if (libName) {
|
||||||
|
// Try to find and load the library from the manifest
|
||||||
|
var loaded = handleImportSuspension(libName);
|
||||||
|
if (!loaded) {
|
||||||
|
console.warn("[sx-platform] lazy import: library not found:", libName);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
// Resume the suspended module (null = library is now in env)
|
||||||
|
result = result.resume(null);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (typeof result === 'string' && result.indexOf('Error') === 0) {
|
||||||
|
console.warn("[sx-platform] bytecode FAIL " + path + ":", result);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
return true;
|
||||||
|
} catch(e) {
|
||||||
|
console.warn("[sx-platform] bytecode FAIL " + path + ":", e.message || e);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Handle an import suspension by finding and loading the library.
|
||||||
|
* The library name may be an SX value (list/string) — normalize to manifest key.
|
||||||
|
*/
|
||||||
|
function handleImportSuspension(libSpec) {
|
||||||
|
// libSpec from the kernel is the library name spec, e.g. {_type:"list", items:[{name:"sx"},{name:"dom"}]}
|
||||||
|
// or a string like "sx dom"
|
||||||
|
var key;
|
||||||
|
if (typeof libSpec === "string") {
|
||||||
|
key = libSpec;
|
||||||
|
} else if (libSpec && libSpec._type === "list" && libSpec.items) {
|
||||||
|
key = libSpec.items.map(function(item) {
|
||||||
|
return (item && item.name) ? item.name : String(item);
|
||||||
|
}).join(" ");
|
||||||
|
} else if (libSpec && libSpec._type === "dict") {
|
||||||
|
// Dict with key/name fields
|
||||||
|
key = libSpec.key || libSpec.name || "";
|
||||||
|
} else {
|
||||||
|
key = String(libSpec);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (_loadedLibs[key]) return true; // already loaded
|
||||||
|
|
||||||
|
if (!_manifest) loadManifest();
|
||||||
|
if (!_manifest || !_manifest[key]) {
|
||||||
|
console.warn("[sx-platform] lazy import: unknown library key '" + key + "'");
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Load the library (and its deps) on demand
|
||||||
|
return loadLibrary(key, {});
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Load an .sx file synchronously via XHR (boot-time only).
|
||||||
|
* Returns the number of expressions loaded, or an error string.
|
||||||
|
*/
|
||||||
|
function loadSxFile(path) {
|
||||||
|
var url = _baseUrl + path + _cacheBust;
|
||||||
|
try {
|
||||||
|
var xhr = new XMLHttpRequest();
|
||||||
|
xhr.open("GET", url, false); // synchronous
|
||||||
|
xhr.send();
|
||||||
|
if (xhr.status === 200) {
|
||||||
|
var result = K.load(xhr.responseText);
|
||||||
|
if (typeof result === "string" && result.indexOf("Error") === 0) {
|
||||||
|
console.error("[sx-platform] FAIL " + path + ":", result);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
console.log("[sx-platform] ok " + path + " (" + result + " exprs)");
|
||||||
|
return result;
|
||||||
|
} else {
|
||||||
|
console.error("[sx] Failed to fetch " + path + ": HTTP " + xhr.status);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
} catch(e) {
|
||||||
|
console.error("[sx] Failed to load " + path + ":", e);
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Manifest-driven module loader — only loads what's needed
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
var _manifest = null;
|
||||||
|
var _loadedLibs = {};
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Fetch and parse the module manifest (library deps + file paths).
|
||||||
|
*/
|
||||||
|
function loadManifest() {
|
||||||
|
if (_manifest) return _manifest;
|
||||||
|
try {
|
||||||
|
var xhr = new XMLHttpRequest();
|
||||||
|
xhr.open("GET", _baseUrl + "sx/module-manifest.json" + _cacheBust, false);
|
||||||
|
xhr.send();
|
||||||
|
if (xhr.status === 200) {
|
||||||
|
_manifest = JSON.parse(xhr.responseText);
|
||||||
|
return _manifest;
|
||||||
|
}
|
||||||
|
} catch(e) {}
|
||||||
|
console.warn("[sx-platform] No manifest found, falling back to full load");
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Load a single library and all its dependencies (recursive).
|
||||||
|
* Cycle-safe: tracks in-progress loads to break circular deps.
|
||||||
|
* Functions in cyclic modules resolve symbols at call time via global env.
|
||||||
|
*/
|
||||||
|
function loadLibrary(name, loading) {
|
||||||
|
if (_loadedLibs[name]) return true;
|
||||||
|
if (loading[name]) return true; // cycle — skip
|
||||||
|
loading[name] = true;
|
||||||
|
|
||||||
|
var info = _manifest[name];
|
||||||
|
if (!info) {
|
||||||
|
console.warn("[sx-platform] Unknown library: " + name);
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Resolve deps first
|
||||||
|
for (var i = 0; i < info.deps.length; i++) {
|
||||||
|
loadLibrary(info.deps[i], loading);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Mark as loaded BEFORE executing — self-imports (define-library re-exports)
|
||||||
|
// will see it as already loaded and skip rather than infinite-looping.
|
||||||
|
_loadedLibs[name] = true;
|
||||||
|
|
||||||
|
// Load this module (bytecode first, fallback to source)
|
||||||
|
var ok = loadBytecodeFile("sx/" + info.file);
|
||||||
|
if (!ok) {
|
||||||
|
var sxFile = info.file.replace(/\.sxbc$/, '.sx');
|
||||||
|
ok = loadSxFile("sx/" + sxFile);
|
||||||
|
}
|
||||||
|
return !!ok;
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Load web stack using the module manifest.
|
||||||
|
* Only downloads libraries that the entry point transitively depends on.
|
||||||
|
*/
|
||||||
|
function loadWebStack() {
|
||||||
|
var manifest = loadManifest();
|
||||||
|
if (!manifest) return loadWebStackFallback();
|
||||||
|
|
||||||
|
var entry = manifest["_entry"];
|
||||||
|
if (!entry) {
|
||||||
|
console.warn("[sx-platform] No _entry in manifest, falling back");
|
||||||
|
return loadWebStackFallback();
|
||||||
|
}
|
||||||
|
|
||||||
|
var loading = {};
|
||||||
|
var t0 = performance.now();
|
||||||
|
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||||
|
|
||||||
|
// Load all entry point deps recursively
|
||||||
|
for (var i = 0; i < entry.deps.length; i++) {
|
||||||
|
loadLibrary(entry.deps[i], loading);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Load entry point itself (boot.sx — not a library, just defines + init)
|
||||||
|
loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));
|
||||||
|
|
||||||
|
if (K.endModuleLoad) K.endModuleLoad();
|
||||||
|
var count = Object.keys(_loadedLibs).length + 1; // +1 for entry
|
||||||
|
var dt = Math.round(performance.now() - t0);
|
||||||
|
console.log("[sx-platform] Loaded " + count + " modules in " + dt + "ms (manifest-driven)");
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Fallback: load all files in hardcoded order (pre-manifest compat).
|
||||||
|
*/
|
||||||
|
function loadWebStackFallback() {
|
||||||
|
var files = [
|
||||||
|
"sx/render.sx", "sx/core-signals.sx", "sx/signals.sx", "sx/deps.sx",
|
||||||
|
"sx/router.sx", "sx/page-helpers.sx", "sx/freeze.sx", "sx/highlight.sx",
|
||||||
|
"sx/bytecode.sx", "sx/compiler.sx", "sx/vm.sx", "sx/dom.sx", "sx/browser.sx",
|
||||||
|
"sx/adapter-html.sx", "sx/adapter-sx.sx", "sx/adapter-dom.sx",
|
||||||
|
"sx/boot-helpers.sx", "sx/hypersx.sx", "sx/harness.sx",
|
||||||
|
"sx/harness-reactive.sx", "sx/harness-web.sx",
|
||||||
|
"sx/engine.sx", "sx/orchestration.sx", "sx/boot.sx",
|
||||||
|
];
|
||||||
|
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||||
|
for (var i = 0; i < files.length; i++) {
|
||||||
|
if (!loadBytecodeFile(files[i])) loadSxFile(files[i]);
|
||||||
|
}
|
||||||
|
if (K.endModuleLoad) K.endModuleLoad();
|
||||||
|
console.log("[sx-platform] Loaded " + files.length + " files (fallback)");
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Load an optional library on demand (e.g., highlight, harness).
|
||||||
|
* Can be called after boot for pages that need extra modules.
|
||||||
|
*/
|
||||||
|
globalThis.__sxLoadLibrary = function(name) {
|
||||||
|
if (!_manifest) loadManifest();
|
||||||
|
if (!_manifest) return false;
|
||||||
|
if (_loadedLibs[name]) return true;
|
||||||
|
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||||
|
var ok = loadLibrary(name, {});
|
||||||
|
if (K.endModuleLoad) K.endModuleLoad();
|
||||||
|
return ok;
|
||||||
|
};
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Transparent lazy loading — symbol → library index
|
||||||
|
//
|
||||||
|
// When the VM hits an undefined symbol, the resolve hook checks this
|
||||||
|
// index, loads the library that exports it, and returns the value.
|
||||||
|
// The programmer just calls the function — loading is invisible.
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
var _symbolIndex = null; // symbol name → library key
|
||||||
|
|
||||||
|
function buildSymbolIndex() {
|
||||||
|
if (_symbolIndex) return _symbolIndex;
|
||||||
|
if (!_manifest) loadManifest();
|
||||||
|
if (!_manifest) return null;
|
||||||
|
_symbolIndex = {};
|
||||||
|
for (var key in _manifest) {
|
||||||
|
if (key.startsWith('_')) continue;
|
||||||
|
var entry = _manifest[key];
|
||||||
|
if (entry.exports) {
|
||||||
|
for (var i = 0; i < entry.exports.length; i++) {
|
||||||
|
_symbolIndex[entry.exports[i]] = key;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return _symbolIndex;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Register the resolve hook — called by the VM when GLOBAL_GET fails
|
||||||
|
K.registerNative("__resolve-symbol", function(args) {
|
||||||
|
var name = args[0];
|
||||||
|
if (!name) return null;
|
||||||
|
var idx = buildSymbolIndex();
|
||||||
|
if (!idx || !idx[name]) return null;
|
||||||
|
var lib = idx[name];
|
||||||
|
if (_loadedLibs[lib]) return null; // already loaded but symbol still missing — real error
|
||||||
|
// Load the library
|
||||||
|
__sxLoadLibrary(lib);
|
||||||
|
// Return null — the VM will re-lookup in globals after the hook loads the module
|
||||||
|
return null;
|
||||||
|
});
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Compatibility shim — expose Sx global matching current JS API
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
globalThis.Sx = {
|
||||||
|
VERSION: "wasm-1.0",
|
||||||
|
parse: function(src) { return K.parse(src); },
|
||||||
|
eval: function(src) { return K.eval(src); },
|
||||||
|
load: function(src) { return K.load(src); },
|
||||||
|
renderToHtml: function(expr) { return K.renderToHtml(expr); },
|
||||||
|
callFn: function(fn, args) { return K.callFn(fn, args); },
|
||||||
|
engine: function() { return K.engine(); },
|
||||||
|
// Boot entry point (called by auto-init or manually)
|
||||||
|
init: function() {
|
||||||
|
if (typeof K.eval === "function") {
|
||||||
|
// Check boot-init exists
|
||||||
|
// Step through boot manually
|
||||||
|
console.log("[sx] init-css-tracking...");
|
||||||
|
K.eval("(init-css-tracking)");
|
||||||
|
console.log("[sx] process-page-scripts...");
|
||||||
|
K.eval("(process-page-scripts)");
|
||||||
|
console.log("[sx] routes after pages:", K.eval("(len _page-routes)"));
|
||||||
|
console.log("[sx] process-sx-scripts...");
|
||||||
|
K.eval("(process-sx-scripts nil)");
|
||||||
|
console.log("[sx] sx-hydrate-elements...");
|
||||||
|
K.eval("(sx-hydrate-elements nil)");
|
||||||
|
console.log("[sx] sx-hydrate-islands...");
|
||||||
|
K.eval("(sx-hydrate-islands nil)");
|
||||||
|
console.log("[sx] process-elements...");
|
||||||
|
K.eval("(process-elements nil)");
|
||||||
|
// Debug islands
|
||||||
|
console.log("[sx] ~home/stepper defined?", K.eval("(type-of ~home/stepper)"));
|
||||||
|
console.log("[sx] ~layouts/header defined?", K.eval("(type-of ~layouts/header)"));
|
||||||
|
// Island count (JS-side, avoids VM overhead)
|
||||||
|
console.log("[sx] manual island query:", document.querySelectorAll("[data-sx-island]").length);
|
||||||
|
// Try hydrating again
|
||||||
|
console.log("[sx] retry hydrate-islands...");
|
||||||
|
K.eval("(sx-hydrate-islands nil)");
|
||||||
|
// Check if links are boosted
|
||||||
|
var links = document.querySelectorAll("a[href]");
|
||||||
|
var boosted = 0;
|
||||||
|
for (var i = 0; i < links.length; i++) {
|
||||||
|
if (links[i]._sxBoundboost) boosted++;
|
||||||
|
}
|
||||||
|
console.log("[sx] boosted links:", boosted, "/", links.length);
|
||||||
|
// Check island state
|
||||||
|
var islands = document.querySelectorAll("[data-sx-island]");
|
||||||
|
console.log("[sx] islands:", islands.length);
|
||||||
|
for (var j = 0; j < islands.length; j++) {
|
||||||
|
console.log("[sx] island:", islands[j].getAttribute("data-sx-island"),
|
||||||
|
"hydrated:", !!islands[j]._sxBoundislandhydrated || !!islands[j]["_sxBound" + "island-hydrated"],
|
||||||
|
"children:", islands[j].children.length);
|
||||||
|
}
|
||||||
|
// Register popstate handler for back/forward navigation
|
||||||
|
window.addEventListener("popstate", function(e) {
|
||||||
|
var state = e.state;
|
||||||
|
var scrollY = (state && state.scrollY) ? state.scrollY : 0;
|
||||||
|
K.eval("(handle-popstate " + scrollY + ")");
|
||||||
|
});
|
||||||
|
// Define resolveSuspense now that boot is complete and web stack is loaded.
|
||||||
|
// Must happen AFTER boot — resolve-suspense needs dom-query, render-to-dom etc.
|
||||||
|
Sx.resolveSuspense = function(id, sx) {
|
||||||
|
try {
|
||||||
|
K.eval('(resolve-suspense ' + JSON.stringify(id) + ' ' + JSON.stringify(sx) + ')');
|
||||||
|
} catch (e) {
|
||||||
|
console.error("[sx] resolveSuspense error for id=" + id, e);
|
||||||
|
}
|
||||||
|
};
|
||||||
|
// Process any streaming suspense resolutions that arrived before boot
|
||||||
|
if (globalThis.__sxPending && globalThis.__sxPending.length > 0) {
|
||||||
|
for (var pi = 0; pi < globalThis.__sxPending.length; pi++) {
|
||||||
|
try {
|
||||||
|
Sx.resolveSuspense(globalThis.__sxPending[pi].id, globalThis.__sxPending[pi].sx);
|
||||||
|
} catch(e) { console.error("[sx] pending resolve error:", e); }
|
||||||
|
}
|
||||||
|
globalThis.__sxPending = null;
|
||||||
|
}
|
||||||
|
// Set up direct resolution for future streaming chunks
|
||||||
|
globalThis.__sxResolve = function(id, sx) { Sx.resolveSuspense(id, sx); };
|
||||||
|
// Signal boot complete
|
||||||
|
document.documentElement.setAttribute("data-sx-ready", "true");
|
||||||
|
console.log("[sx] boot done");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
// ================================================================
|
||||||
|
// Auto-init: load web stack and boot on DOMContentLoaded
|
||||||
|
// ================================================================
|
||||||
|
|
||||||
|
if (typeof document !== "undefined") {
|
||||||
|
var _doInit = function() {
|
||||||
|
loadWebStack();
|
||||||
|
Sx.init();
|
||||||
|
// Enable JIT after all boot code has run.
|
||||||
|
// Lazy-load the compiler first — JIT needs it to compile functions.
|
||||||
|
setTimeout(function() {
|
||||||
|
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||||
|
loadLibrary("sx compiler", {});
|
||||||
|
if (K.endModuleLoad) K.endModuleLoad();
|
||||||
|
K.eval('(enable-jit!)');
|
||||||
|
}, 0);
|
||||||
|
};
|
||||||
|
|
||||||
|
if (document.readyState === "loading") {
|
||||||
|
document.addEventListener("DOMContentLoaded", _doInit);
|
||||||
|
} else {
|
||||||
|
_doInit();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
} // end boot
|
||||||
|
|
||||||
|
// SxKernel is available synchronously (js_of_ocaml) or after async
|
||||||
|
// WASM init. Poll briefly to handle both cases.
|
||||||
|
var K = globalThis.SxKernel;
|
||||||
|
if (K) { boot(K); return; }
|
||||||
|
var tries = 0;
|
||||||
|
var poll = setInterval(function() {
|
||||||
|
K = globalThis.SxKernel;
|
||||||
|
if (K) { clearInterval(poll); boot(K); }
|
||||||
|
else if (++tries > 100) { clearInterval(poll); console.error("[sx-platform] SxKernel not found after 5s"); }
|
||||||
|
}, 50);
|
||||||
|
})();
|
||||||
60695
hosts/ocaml/shared/static/wasm/sx_browser.bc.js
Normal file
60695
hosts/ocaml/shared/static/wasm/sx_browser.bc.js
Normal file
File diff suppressed because one or more lines are too long
1821
hosts/ocaml/shared/static/wasm/sx_browser.bc.wasm.js
Normal file
1821
hosts/ocaml/shared/static/wasm/sx_browser.bc.wasm.js
Normal file
File diff suppressed because it is too large
Load Diff
@@ -287,7 +287,7 @@ let vm_create_closure vm_val frame_val code_val =
|
|||||||
|
|
||||||
(* --- JIT sentinel --- *)
|
(* --- JIT sentinel --- *)
|
||||||
let _jit_failed_sentinel = {
|
let _jit_failed_sentinel = {
|
||||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
||||||
vc_bytecode_list = None; vc_constants_list = None };
|
vc_bytecode_list = None; vc_constants_list = None };
|
||||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -269,7 +269,8 @@
|
|||||||
"try-catch"
|
"try-catch"
|
||||||
"set-render-active!"
|
"set-render-active!"
|
||||||
"scope-emitted"
|
"scope-emitted"
|
||||||
"jit-try-call"))
|
"jit-try-call"
|
||||||
|
"jit-skip?"))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
ml-is-known-name?
|
ml-is-known-name?
|
||||||
|
|||||||
@@ -589,6 +589,43 @@
|
|||||||
(list (list (make-symbol loop-name) lambda-expr)))
|
(list (list (make-symbol loop-name) lambda-expr)))
|
||||||
(call-expr (cons (make-symbol loop-name) inits)))
|
(call-expr (cons (make-symbol loop-name) inits)))
|
||||||
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
|
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
|
||||||
|
(if
|
||||||
|
(dict? (first args))
|
||||||
|
(let
|
||||||
|
((pattern (first args))
|
||||||
|
(source-expr (nth args 1))
|
||||||
|
(body (slice args 2))
|
||||||
|
(let-scope (make-scope scope)))
|
||||||
|
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
||||||
|
(compile-expr em source-expr let-scope false)
|
||||||
|
(let
|
||||||
|
((temp-slot (scope-define-local let-scope "__dict_src")))
|
||||||
|
(emit-op em 17)
|
||||||
|
(emit-byte em temp-slot)
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(k)
|
||||||
|
(let
|
||||||
|
((var-name (get pattern k))
|
||||||
|
(key-str
|
||||||
|
(if
|
||||||
|
(= (type-of k) "keyword")
|
||||||
|
(keyword-name k)
|
||||||
|
(str k))))
|
||||||
|
(emit-op em 16)
|
||||||
|
(emit-byte em temp-slot)
|
||||||
|
(emit-const em key-str)
|
||||||
|
(let
|
||||||
|
((get-idx (pool-add (get em "pool") "get")))
|
||||||
|
(emit-op em 52)
|
||||||
|
(emit-u16 em get-idx)
|
||||||
|
(emit-byte em 2))
|
||||||
|
(let
|
||||||
|
((slot (scope-define-local let-scope (if (= (type-of var-name) "symbol") (symbol-name var-name) var-name))))
|
||||||
|
(emit-op em 17)
|
||||||
|
(emit-byte em slot))))
|
||||||
|
(keys pattern))
|
||||||
|
(compile-begin em body let-scope tail?)))
|
||||||
(let
|
(let
|
||||||
((bindings (first args))
|
((bindings (first args))
|
||||||
(body (rest args))
|
(body (rest args))
|
||||||
@@ -598,14 +635,15 @@
|
|||||||
(fn
|
(fn
|
||||||
(binding)
|
(binding)
|
||||||
(let
|
(let
|
||||||
((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding)))
|
((name (if (= (type-of (first binding)) "symbol") (first binding) (make-symbol (first binding))))
|
||||||
(value (nth binding 1))
|
(value (nth binding 1)))
|
||||||
(slot (scope-define-local let-scope name)))
|
|
||||||
(compile-expr em value let-scope false)
|
(compile-expr em value let-scope false)
|
||||||
|
(let
|
||||||
|
((slot (scope-define-local let-scope (symbol-name name))))
|
||||||
(emit-op em 17)
|
(emit-op em 17)
|
||||||
(emit-byte em slot)))
|
(emit-byte em slot))))
|
||||||
bindings)
|
bindings)
|
||||||
(compile-begin em body let-scope tail?)))))
|
(compile-begin em body let-scope tail?))))))
|
||||||
(define
|
(define
|
||||||
compile-letrec
|
compile-letrec
|
||||||
(fn
|
(fn
|
||||||
@@ -640,20 +678,29 @@
|
|||||||
(fn-scope (make-scope scope))
|
(fn-scope (make-scope scope))
|
||||||
(fn-em (make-emitter)))
|
(fn-em (make-emitter)))
|
||||||
(dict-set! fn-scope "is-function" true)
|
(dict-set! fn-scope "is-function" true)
|
||||||
|
(let
|
||||||
|
((rest-pos -1) (rest-name nil))
|
||||||
(for-each
|
(for-each
|
||||||
(fn
|
(fn
|
||||||
(p)
|
(p)
|
||||||
(let
|
(let
|
||||||
((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p)))
|
((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p)))
|
||||||
|
(cond
|
||||||
|
(= name "&rest")
|
||||||
|
(set! rest-pos (len (get fn-scope "locals")))
|
||||||
|
(= name "&key")
|
||||||
|
nil
|
||||||
|
:else (do
|
||||||
(when
|
(when
|
||||||
(and (not (= name "&key")) (not (= name "&rest")))
|
(and (> rest-pos -1) (nil? rest-name))
|
||||||
(scope-define-local fn-scope name))))
|
(set! rest-name name))
|
||||||
|
(scope-define-local fn-scope name)))))
|
||||||
params)
|
params)
|
||||||
(compile-begin fn-em body fn-scope true)
|
(compile-begin fn-em body fn-scope true)
|
||||||
(emit-op fn-em 50)
|
(emit-op fn-em 50)
|
||||||
(let
|
(let
|
||||||
((upvals (get fn-scope "upvalues"))
|
((upvals (get fn-scope "upvalues"))
|
||||||
(code {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")})
|
(code (if (> rest-pos -1) {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :rest-arity rest-pos :bytecode (get fn-em "bytecode")} {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")}))
|
||||||
(code-idx (pool-add (get em "pool") code)))
|
(code-idx (pool-add (get em "pool") code)))
|
||||||
(emit-op em 51)
|
(emit-op em 51)
|
||||||
(emit-u16 em code-idx)
|
(emit-u16 em code-idx)
|
||||||
@@ -662,7 +709,7 @@
|
|||||||
(uv)
|
(uv)
|
||||||
(emit-byte em (if (get uv "is-local") 1 0))
|
(emit-byte em (if (get uv "is-local") 1 0))
|
||||||
(emit-byte em (get uv "index")))
|
(emit-byte em (get uv "index")))
|
||||||
upvals)))))
|
upvals))))))
|
||||||
(define
|
(define
|
||||||
compile-define
|
compile-define
|
||||||
(fn
|
(fn
|
||||||
@@ -681,7 +728,7 @@
|
|||||||
(and
|
(and
|
||||||
(not (empty? rest-args))
|
(not (empty? rest-args))
|
||||||
(= (type-of (first rest-args)) "keyword"))
|
(= (type-of (first rest-args)) "keyword"))
|
||||||
(let
|
(letrec
|
||||||
((skip-annotations (fn (items) (if (empty? items) nil (if (= (type-of (first items)) "keyword") (skip-annotations (rest (rest items))) (first items))))))
|
((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))
|
(skip-annotations rest-args))
|
||||||
(first rest-args)))))
|
(first rest-args)))))
|
||||||
|
|||||||
49
lib/erlang/parser-core.sx
Normal file
49
lib/erlang/parser-core.sx
Normal file
@@ -0,0 +1,49 @@
|
|||||||
|
;; Core parser helpers — shared by er-parse-expr and er-parse-module.
|
||||||
|
;; Everything reads/mutates a parser state dict:
|
||||||
|
;; {:toks TOKS :idx INDEX}
|
||||||
|
|
||||||
|
(define er-state-make (fn (toks) {:idx 0 :toks toks}))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-peek
|
||||||
|
(fn
|
||||||
|
(st offset)
|
||||||
|
(let
|
||||||
|
((toks (get st :toks)) (idx (+ (get st :idx) offset)))
|
||||||
|
(if (< idx (len toks)) (nth toks idx) (nth toks (- (len toks) 1))))))
|
||||||
|
|
||||||
|
(define er-cur (fn (st) (er-peek st 0)))
|
||||||
|
|
||||||
|
(define er-cur-type (fn (st) (get (er-cur st) :type)))
|
||||||
|
(define er-cur-value (fn (st) (get (er-cur st) :value)))
|
||||||
|
|
||||||
|
(define er-advance! (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
||||||
|
|
||||||
|
(define er-at-eof? (fn (st) (= (er-cur-type st) "eof")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-is?
|
||||||
|
(fn
|
||||||
|
(st type value)
|
||||||
|
(and
|
||||||
|
(= (er-cur-type st) type)
|
||||||
|
(or (= value nil) (= (er-cur-value st) value)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-expect!
|
||||||
|
(fn
|
||||||
|
(st type value)
|
||||||
|
(if
|
||||||
|
(er-is? st type value)
|
||||||
|
(let ((t (er-cur st))) (er-advance! st) t)
|
||||||
|
(error
|
||||||
|
(str
|
||||||
|
"Erlang parse: expected "
|
||||||
|
type
|
||||||
|
(if value (str " '" value "'") "")
|
||||||
|
" but got "
|
||||||
|
(er-cur-type st)
|
||||||
|
" '"
|
||||||
|
(er-cur-value st)
|
||||||
|
"' at pos "
|
||||||
|
(get (er-cur st) :pos))))))
|
||||||
534
lib/erlang/parser-expr.sx
Normal file
534
lib/erlang/parser-expr.sx
Normal file
@@ -0,0 +1,534 @@
|
|||||||
|
;; Erlang expression parser — top-level fns operating on parser state.
|
||||||
|
;; Depends on parser-core.sx (er-state-*, er-cur-*, er-is?, er-expect!)
|
||||||
|
;; and parser.sx (er-is-binop?, er-any-binop?, er-build-cons, er-slice-list).
|
||||||
|
|
||||||
|
;; ── entry point ───────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-expr
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((st (er-state-make (er-tokenize src))))
|
||||||
|
(er-parse-expr-prec st 0))))
|
||||||
|
|
||||||
|
;; Pratt-like operator-precedence parser.
|
||||||
|
(define
|
||||||
|
er-parse-expr-prec
|
||||||
|
(fn
|
||||||
|
(st min-prec)
|
||||||
|
(let
|
||||||
|
((left (er-parse-unary st)))
|
||||||
|
(er-parse-expr-loop st min-prec left))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-expr-loop
|
||||||
|
(fn
|
||||||
|
(st min-prec left)
|
||||||
|
(if
|
||||||
|
(er-any-binop? (er-cur st) min-prec)
|
||||||
|
(let
|
||||||
|
((tok (er-cur st)))
|
||||||
|
(cond
|
||||||
|
(er-is-binop? tok 0)
|
||||||
|
(do (er-advance! st) (er-parse-expr-loop st min-prec {:rhs (er-parse-expr-prec st 0) :type "match" :lhs left}))
|
||||||
|
(er-is-binop? tok 1)
|
||||||
|
(do (er-advance! st) (er-parse-expr-loop st min-prec {:msg (er-parse-expr-prec st 1) :type "send" :to left}))
|
||||||
|
(er-is-binop? tok 2)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 3)) :type "op" :op op}))
|
||||||
|
(er-is-binop? tok 3)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 4)) :type "op" :op op}))
|
||||||
|
(er-is-binop? tok 4)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 5)) :type "op" :op op}))
|
||||||
|
(er-is-binop? tok 5)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 5)) :type "op" :op op}))
|
||||||
|
(er-is-binop? tok 6)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 7)) :type "op" :op op}))
|
||||||
|
(er-is-binop? tok 7)
|
||||||
|
(let
|
||||||
|
((op (get tok :value)))
|
||||||
|
(er-advance! st)
|
||||||
|
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 8)) :type "op" :op op}))
|
||||||
|
:else left))
|
||||||
|
left)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-unary
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(cond
|
||||||
|
(er-is? st "op" "-")
|
||||||
|
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "-"})
|
||||||
|
(er-is? st "op" "+")
|
||||||
|
(do (er-advance! st) (er-parse-unary st))
|
||||||
|
(er-is? st "keyword" "not")
|
||||||
|
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "not"})
|
||||||
|
(er-is? st "keyword" "bnot")
|
||||||
|
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "bnot"})
|
||||||
|
:else (er-parse-postfix st))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-postfix
|
||||||
|
(fn (st) (er-parse-postfix-loop st (er-parse-primary st))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-postfix-loop
|
||||||
|
(fn
|
||||||
|
(st node)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ":")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((rhs (er-parse-primary st)))
|
||||||
|
(er-parse-postfix-loop st {:fun rhs :mod node :type "remote"})))
|
||||||
|
(er-is? st "punct" "(")
|
||||||
|
(let
|
||||||
|
((args (er-parse-call-args st)))
|
||||||
|
(er-parse-postfix-loop st {:args args :fun node :type "call"}))
|
||||||
|
:else node)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-call-args
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "punct" "(")
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ")")
|
||||||
|
(do (er-advance! st) (list))
|
||||||
|
(let
|
||||||
|
((args (list (er-parse-expr-prec st 0))))
|
||||||
|
(er-parse-args-tail st args)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-args-tail
|
||||||
|
(fn
|
||||||
|
(st args)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! args (er-parse-expr-prec st 0))
|
||||||
|
(er-parse-args-tail st args))
|
||||||
|
(er-is? st "punct" ")")
|
||||||
|
(do (er-advance! st) args)
|
||||||
|
:else (error
|
||||||
|
(str
|
||||||
|
"Erlang parse: expected ',' or ')' in args, got '"
|
||||||
|
(er-cur-value st)
|
||||||
|
"'")))))
|
||||||
|
|
||||||
|
;; A body is: Expr {, Expr}
|
||||||
|
(define
|
||||||
|
er-parse-body
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((exprs (list (er-parse-expr-prec st 0))))
|
||||||
|
(er-parse-body-tail st exprs))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-body-tail
|
||||||
|
(fn
|
||||||
|
(st exprs)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! exprs (er-parse-expr-prec st 0))
|
||||||
|
(er-parse-body-tail st exprs))
|
||||||
|
exprs)))
|
||||||
|
|
||||||
|
;; Guards: G1 ; G2 ; ... where each Gi is a guard-conj (T, T, ...)
|
||||||
|
(define
|
||||||
|
er-parse-guards
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((alts (list (er-parse-guard-conj st))))
|
||||||
|
(er-parse-guards-tail st alts))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-guards-tail
|
||||||
|
(fn
|
||||||
|
(st alts)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! alts (er-parse-guard-conj st))
|
||||||
|
(er-parse-guards-tail st alts))
|
||||||
|
alts)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-guard-conj
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((ts (list (er-parse-expr-prec st 0))))
|
||||||
|
(er-parse-guard-conj-tail st ts))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-guard-conj-tail
|
||||||
|
(fn
|
||||||
|
(st ts)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! ts (er-parse-expr-prec st 0))
|
||||||
|
(er-parse-guard-conj-tail st ts))
|
||||||
|
ts)))
|
||||||
|
|
||||||
|
(define er-parse-pattern (fn (st) (er-parse-expr-prec st 0)))
|
||||||
|
|
||||||
|
;; ── primary expressions ──────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-primary
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((tok (er-cur st)))
|
||||||
|
(cond
|
||||||
|
(= (er-cur-type st) "integer")
|
||||||
|
(do (er-advance! st) {:value (get tok :value) :type "integer"})
|
||||||
|
(= (er-cur-type st) "float")
|
||||||
|
(do (er-advance! st) {:value (get tok :value) :type "float"})
|
||||||
|
(= (er-cur-type st) "string")
|
||||||
|
(do (er-advance! st) {:value (get tok :value) :type "string"})
|
||||||
|
(= (er-cur-type st) "atom")
|
||||||
|
(do (er-advance! st) {:value (get tok :value) :type "atom"})
|
||||||
|
(= (er-cur-type st) "var")
|
||||||
|
(do (er-advance! st) {:type "var" :name (get tok :value)})
|
||||||
|
(er-is? st "punct" "(")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((e (er-parse-expr-prec st 0)))
|
||||||
|
(er-expect! st "punct" ")")
|
||||||
|
e))
|
||||||
|
(er-is? st "punct" "{")
|
||||||
|
(er-parse-tuple st)
|
||||||
|
(er-is? st "punct" "[")
|
||||||
|
(er-parse-list st)
|
||||||
|
(er-is? st "keyword" "if")
|
||||||
|
(er-parse-if st)
|
||||||
|
(er-is? st "keyword" "case")
|
||||||
|
(er-parse-case st)
|
||||||
|
(er-is? st "keyword" "receive")
|
||||||
|
(er-parse-receive st)
|
||||||
|
(er-is? st "keyword" "begin")
|
||||||
|
(er-parse-begin st)
|
||||||
|
(er-is? st "keyword" "fun")
|
||||||
|
(er-parse-fun-expr st)
|
||||||
|
(er-is? st "keyword" "try")
|
||||||
|
(er-parse-try st)
|
||||||
|
:else (error
|
||||||
|
(str
|
||||||
|
"Erlang parse: unexpected "
|
||||||
|
(er-cur-type st)
|
||||||
|
" '"
|
||||||
|
(get tok :value)
|
||||||
|
"' at pos "
|
||||||
|
(get tok :pos)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-tuple
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "punct" "{")
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" "}")
|
||||||
|
(do (er-advance! st) {:elements (list) :type "tuple"})
|
||||||
|
(let
|
||||||
|
((elems (list (er-parse-expr-prec st 0))))
|
||||||
|
(er-parse-tuple-tail st elems)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-tuple-tail
|
||||||
|
(fn
|
||||||
|
(st elems)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! elems (er-parse-expr-prec st 0))
|
||||||
|
(er-parse-tuple-tail st elems))
|
||||||
|
(er-is? st "punct" "}")
|
||||||
|
(do (er-advance! st) {:elements elems :type "tuple"})
|
||||||
|
:else (error
|
||||||
|
(str
|
||||||
|
"Erlang parse: expected ',' or '}' in tuple, got '"
|
||||||
|
(er-cur-value st)
|
||||||
|
"'")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-list
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "punct" "[")
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" "]")
|
||||||
|
(do (er-advance! st) {:type "nil"})
|
||||||
|
(let
|
||||||
|
((elems (list (er-parse-expr-prec st 0))))
|
||||||
|
(er-parse-list-tail st elems)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-list-tail
|
||||||
|
(fn
|
||||||
|
(st elems)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! elems (er-parse-expr-prec st 0))
|
||||||
|
(er-parse-list-tail st elems))
|
||||||
|
(er-is? st "punct" "|")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((tail (er-parse-expr-prec st 0)))
|
||||||
|
(er-expect! st "punct" "]")
|
||||||
|
(er-build-cons elems tail)))
|
||||||
|
(er-is? st "punct" "]")
|
||||||
|
(do (er-advance! st) (er-build-cons elems {:type "nil"}))
|
||||||
|
:else (error
|
||||||
|
(str
|
||||||
|
"Erlang parse: expected ',' '|' or ']' in list, got '"
|
||||||
|
(er-cur-value st)
|
||||||
|
"'")))))
|
||||||
|
|
||||||
|
;; ── if ──────────────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-if
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "if")
|
||||||
|
(let
|
||||||
|
((clauses (list (er-parse-if-clause st))))
|
||||||
|
(er-parse-if-tail st clauses))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-if-tail
|
||||||
|
(fn
|
||||||
|
(st clauses)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-if-clause st))
|
||||||
|
(er-parse-if-tail st clauses))
|
||||||
|
(do (er-expect! st "keyword" "end") {:clauses clauses :type "if"}))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-if-clause
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((guards (er-parse-guards st)))
|
||||||
|
(er-expect! st "punct" "->")
|
||||||
|
(let ((body (er-parse-body st))) {:body body :guards guards}))))
|
||||||
|
|
||||||
|
;; ── case ────────────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-case
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "case")
|
||||||
|
(let
|
||||||
|
((e (er-parse-expr-prec st 0)))
|
||||||
|
(er-expect! st "keyword" "of")
|
||||||
|
(let
|
||||||
|
((clauses (list (er-parse-case-clause st))))
|
||||||
|
(er-parse-case-tail st e clauses)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-case-tail
|
||||||
|
(fn
|
||||||
|
(st e clauses)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-case-clause st))
|
||||||
|
(er-parse-case-tail st e clauses))
|
||||||
|
(do (er-expect! st "keyword" "end") {:expr e :clauses clauses :type "case"}))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-case-clause
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((pat (er-parse-pattern st)))
|
||||||
|
(let
|
||||||
|
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||||
|
(er-expect! st "punct" "->")
|
||||||
|
(let ((body (er-parse-body st))) {:pattern pat :body body :guards guards})))))
|
||||||
|
|
||||||
|
;; ── receive ─────────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-receive
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "receive")
|
||||||
|
(let
|
||||||
|
((clauses (if (er-is? st "keyword" "after") (list) (list (er-parse-case-clause st)))))
|
||||||
|
(er-parse-receive-clauses st clauses))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-receive-clauses
|
||||||
|
(fn
|
||||||
|
(st clauses)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-case-clause st))
|
||||||
|
(er-parse-receive-clauses st clauses))
|
||||||
|
(er-is? st "keyword" "after")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((after-ms (er-parse-expr-prec st 0)))
|
||||||
|
(er-expect! st "punct" "->")
|
||||||
|
(let
|
||||||
|
((after-body (er-parse-body st)))
|
||||||
|
(er-expect! st "keyword" "end")
|
||||||
|
{:clauses clauses :type "receive" :after-ms after-ms :after-body after-body})))
|
||||||
|
:else (do (er-expect! st "keyword" "end") {:clauses clauses :type "receive" :after-ms nil :after-body (list)}))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-begin
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "begin")
|
||||||
|
(let
|
||||||
|
((exprs (er-parse-body st)))
|
||||||
|
(er-expect! st "keyword" "end")
|
||||||
|
{:exprs exprs :type "block"})))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-fun-expr
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "fun")
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" "(")
|
||||||
|
(let
|
||||||
|
((clauses (list (er-parse-fun-clause st nil))))
|
||||||
|
(er-parse-fun-expr-tail st clauses))
|
||||||
|
:else (error "Erlang parse: fun-ref syntax not yet supported"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-fun-expr-tail
|
||||||
|
(fn
|
||||||
|
(st clauses)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-fun-clause st nil))
|
||||||
|
(er-parse-fun-expr-tail st clauses))
|
||||||
|
(do (er-expect! st "keyword" "end") {:clauses clauses :type "fun"}))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-fun-clause
|
||||||
|
(fn
|
||||||
|
(st named-name)
|
||||||
|
(er-expect! st "punct" "(")
|
||||||
|
(let
|
||||||
|
((patterns (if (er-is? st "punct" ")") (list) (er-parse-pattern-list st (list (er-parse-pattern st))))))
|
||||||
|
(er-expect! st "punct" ")")
|
||||||
|
(let
|
||||||
|
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||||
|
(er-expect! st "punct" "->")
|
||||||
|
(let ((body (er-parse-body st))) {:patterns patterns :body body :guards guards :name named-name})))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-pattern-list
|
||||||
|
(fn
|
||||||
|
(st pats)
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! pats (er-parse-pattern st))
|
||||||
|
(er-parse-pattern-list st pats))
|
||||||
|
pats)))
|
||||||
|
|
||||||
|
;; ── try ─────────────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-parse-try
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "keyword" "try")
|
||||||
|
(let
|
||||||
|
((exprs (er-parse-body st))
|
||||||
|
(of-clauses (list))
|
||||||
|
(catch-clauses (list))
|
||||||
|
(after-body (list)))
|
||||||
|
(when
|
||||||
|
(er-is? st "keyword" "of")
|
||||||
|
(er-advance! st)
|
||||||
|
(append! of-clauses (er-parse-case-clause st))
|
||||||
|
(er-parse-try-of-tail st of-clauses))
|
||||||
|
(when
|
||||||
|
(er-is? st "keyword" "catch")
|
||||||
|
(er-advance! st)
|
||||||
|
(append! catch-clauses (er-parse-catch-clause st))
|
||||||
|
(er-parse-try-catch-tail st catch-clauses))
|
||||||
|
(when
|
||||||
|
(er-is? st "keyword" "after")
|
||||||
|
(er-advance! st)
|
||||||
|
(set! after-body (er-parse-body st)))
|
||||||
|
(er-expect! st "keyword" "end")
|
||||||
|
{:exprs exprs :catch-clauses catch-clauses :type "try" :of-clauses of-clauses :after after-body})))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-try-of-tail
|
||||||
|
(fn
|
||||||
|
(st clauses)
|
||||||
|
(when
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-case-clause st))
|
||||||
|
(er-parse-try-of-tail st clauses))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-try-catch-tail
|
||||||
|
(fn
|
||||||
|
(st clauses)
|
||||||
|
(when
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-catch-clause st))
|
||||||
|
(er-parse-try-catch-tail st clauses))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-catch-clause
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((p1 (er-parse-pattern st)))
|
||||||
|
(let
|
||||||
|
((klass (if (= (get p1 :type) "remote") (get p1 :mod) {:value "throw" :type "atom"}))
|
||||||
|
(pat (if (= (get p1 :type) "remote") (get p1 :fun) p1)))
|
||||||
|
(let
|
||||||
|
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||||
|
(er-expect! st "punct" "->")
|
||||||
|
(let ((body (er-parse-body st))) {:pattern pat :body body :class klass :guards guards}))))))
|
||||||
113
lib/erlang/parser-module.sx
Normal file
113
lib/erlang/parser-module.sx
Normal file
@@ -0,0 +1,113 @@
|
|||||||
|
;; Erlang module parser — reads top-level forms and builds a module AST.
|
||||||
|
;;
|
||||||
|
;; Depends on parser-core.sx, parser.sx, parser-expr.sx.
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-module
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((st (er-state-make (er-tokenize src)))
|
||||||
|
(mod-ref (list nil))
|
||||||
|
(attrs (list))
|
||||||
|
(functions (list)))
|
||||||
|
(er-parse-module-loop st mod-ref attrs functions)
|
||||||
|
{:functions functions :type "module" :attrs attrs :name (nth mod-ref 0)})))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-module-loop
|
||||||
|
(fn
|
||||||
|
(st mod-ref attrs functions)
|
||||||
|
(when
|
||||||
|
(not (er-at-eof? st))
|
||||||
|
(er-parse-top-form st mod-ref attrs functions)
|
||||||
|
(er-parse-module-loop st mod-ref attrs functions))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-top-form
|
||||||
|
(fn
|
||||||
|
(st mod-ref attrs functions)
|
||||||
|
(cond
|
||||||
|
(er-is? st "op" "-")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((attr-name (er-cur-value st)))
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((args (er-parse-attr-args st)))
|
||||||
|
(er-expect! st "punct" ".")
|
||||||
|
(cond
|
||||||
|
(= attr-name "module")
|
||||||
|
(set-nth! mod-ref 0 (get (nth args 0) :value))
|
||||||
|
:else (append! attrs {:args args :name attr-name})))))
|
||||||
|
(= (er-cur-type st) "atom")
|
||||||
|
(append! functions (er-parse-function st))
|
||||||
|
:else (error
|
||||||
|
(str
|
||||||
|
"Erlang parse (top): unexpected "
|
||||||
|
(er-cur-type st)
|
||||||
|
" '"
|
||||||
|
(er-cur-value st)
|
||||||
|
"' at pos "
|
||||||
|
(get (er-cur st) :pos))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-attr-args
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(er-expect! st "punct" "(")
|
||||||
|
(if
|
||||||
|
(er-is? st "punct" ")")
|
||||||
|
(do (er-advance! st) (list))
|
||||||
|
(let
|
||||||
|
((args (list (er-parse-attr-arg st))))
|
||||||
|
(er-parse-attr-args-tail st args)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-attr-args-tail
|
||||||
|
(fn
|
||||||
|
(st args)
|
||||||
|
(cond
|
||||||
|
(er-is? st "punct" ",")
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! args (er-parse-attr-arg st))
|
||||||
|
(er-parse-attr-args-tail st args))
|
||||||
|
(er-is? st "punct" ")")
|
||||||
|
(do (er-advance! st) args)
|
||||||
|
:else (error (str "Erlang parse attr: got '" (er-cur-value st) "'")))))
|
||||||
|
|
||||||
|
;; Attribute args often contain `Name/Arity` pairs — parse as a
|
||||||
|
;; general expression so the caller can interpret the shape.
|
||||||
|
(define er-parse-attr-arg (fn (st) (er-parse-expr-prec st 0)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-function
|
||||||
|
(fn
|
||||||
|
(st)
|
||||||
|
(let
|
||||||
|
((name (er-cur-value st)))
|
||||||
|
(er-advance! st)
|
||||||
|
(let
|
||||||
|
((clauses (list (er-parse-fun-clause st name))))
|
||||||
|
(er-parse-function-tail st name clauses)
|
||||||
|
(er-expect! st "punct" ".")
|
||||||
|
(let ((arity (len (get (nth clauses 0) :patterns)))) {:arity arity :clauses clauses :type "function" :name name})))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-function-tail
|
||||||
|
(fn
|
||||||
|
(st name clauses)
|
||||||
|
(when
|
||||||
|
(er-is? st "punct" ";")
|
||||||
|
(let
|
||||||
|
((save (get st :idx)))
|
||||||
|
(er-advance! st)
|
||||||
|
(if
|
||||||
|
(and (= (er-cur-type st) "atom") (= (er-cur-value st) name))
|
||||||
|
(do
|
||||||
|
(er-advance! st)
|
||||||
|
(append! clauses (er-parse-fun-clause st name))
|
||||||
|
(er-parse-function-tail st name clauses))
|
||||||
|
(dict-set! st :idx save))))))
|
||||||
111
lib/erlang/parser.sx
Normal file
111
lib/erlang/parser.sx
Normal file
@@ -0,0 +1,111 @@
|
|||||||
|
;; Erlang parser — turns a token list into an AST.
|
||||||
|
;;
|
||||||
|
;; Shared state lives in the surrounding `let` of `er-parse-*`.
|
||||||
|
;; All helpers use recursion (no `while` in SX).
|
||||||
|
;;
|
||||||
|
;; AST node shapes:
|
||||||
|
;; {:type "atom" :value "foo"}
|
||||||
|
;; {:type "integer" :value "42"} ; value kept as string
|
||||||
|
;; {:type "float" :value "3.14"}
|
||||||
|
;; {:type "string" :value "hi"}
|
||||||
|
;; {:type "var" :name "X"} ; "_" is wildcard
|
||||||
|
;; {:type "nil"}
|
||||||
|
;; {:type "tuple" :elements [...]}
|
||||||
|
;; {:type "cons" :head E :tail E}
|
||||||
|
;; {:type "call" :fun E :args [...]}
|
||||||
|
;; {:type "remote" :mod E :fun E}
|
||||||
|
;; {:type "op" :op OP :args [L R]}
|
||||||
|
;; {:type "unop" :op OP :arg E}
|
||||||
|
;; {:type "match" :lhs P :rhs E}
|
||||||
|
;; {:type "send" :to E :msg E}
|
||||||
|
;; {:type "if" :clauses [{:guards [...] :body [...]} ...]}
|
||||||
|
;; {:type "case" :expr E :clauses [{:pattern P :guards [...] :body [...]} ...]}
|
||||||
|
;; {:type "receive" :clauses [...] :after-ms E-or-nil :after-body [...]}
|
||||||
|
;; {:type "fun" :clauses [...]}
|
||||||
|
;; {:type "block" :exprs [...]}
|
||||||
|
;; {:type "try" :exprs [...] :of-clauses [...] :catch-clauses [...] :after [...]}
|
||||||
|
;; Top-level: {:type "module" :name A :attrs [{:name A :args [...]} ...] :functions [...]}
|
||||||
|
;; {:type "function" :name A :arity N :clauses [{:name :patterns :guards :body}]}
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-is-binop?
|
||||||
|
(fn
|
||||||
|
(tok prec)
|
||||||
|
(let
|
||||||
|
((ty (get tok :type)) (v (get tok :value)))
|
||||||
|
(cond
|
||||||
|
(= prec 0)
|
||||||
|
(and (= ty "op") (= v "="))
|
||||||
|
(= prec 1)
|
||||||
|
(and (= ty "op") (= v "!"))
|
||||||
|
(= prec 2)
|
||||||
|
(or
|
||||||
|
(and (= ty "keyword") (= v "orelse"))
|
||||||
|
(and (= ty "keyword") (= v "or"))
|
||||||
|
(and (= ty "keyword") (= v "xor")))
|
||||||
|
(= prec 3)
|
||||||
|
(or
|
||||||
|
(and (= ty "keyword") (= v "andalso"))
|
||||||
|
(and (= ty "keyword") (= v "and")))
|
||||||
|
(= prec 4)
|
||||||
|
(and
|
||||||
|
(= ty "op")
|
||||||
|
(or
|
||||||
|
(= v "==")
|
||||||
|
(= v "/=")
|
||||||
|
(= v "=:=")
|
||||||
|
(= v "=/=")
|
||||||
|
(= v "<")
|
||||||
|
(= v ">")
|
||||||
|
(= v "=<")
|
||||||
|
(= v ">=")))
|
||||||
|
(= prec 5)
|
||||||
|
(and (= ty "op") (or (= v "++") (= v "--")))
|
||||||
|
(= prec 6)
|
||||||
|
(and (= ty "op") (or (= v "+") (= v "-")))
|
||||||
|
(= prec 7)
|
||||||
|
(or
|
||||||
|
(and (= ty "op") (or (= v "*") (= v "/")))
|
||||||
|
(and
|
||||||
|
(= ty "keyword")
|
||||||
|
(or
|
||||||
|
(= v "div")
|
||||||
|
(= v "rem")
|
||||||
|
(= v "band")
|
||||||
|
(= v "bor")
|
||||||
|
(= v "bxor")
|
||||||
|
(= v "bsl")
|
||||||
|
(= v "bsr"))))
|
||||||
|
:else false))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-any-binop?
|
||||||
|
(fn
|
||||||
|
(tok min-prec)
|
||||||
|
(or
|
||||||
|
(and (>= 0 min-prec) (er-is-binop? tok 0))
|
||||||
|
(and (>= 1 min-prec) (er-is-binop? tok 1))
|
||||||
|
(and (>= 2 min-prec) (er-is-binop? tok 2))
|
||||||
|
(and (>= 3 min-prec) (er-is-binop? tok 3))
|
||||||
|
(and (>= 4 min-prec) (er-is-binop? tok 4))
|
||||||
|
(and (>= 5 min-prec) (er-is-binop? tok 5))
|
||||||
|
(and (>= 6 min-prec) (er-is-binop? tok 6))
|
||||||
|
(and (>= 7 min-prec) (er-is-binop? tok 7)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-slice-list
|
||||||
|
(fn
|
||||||
|
(xs from)
|
||||||
|
(if
|
||||||
|
(>= from (len xs))
|
||||||
|
(list)
|
||||||
|
(let
|
||||||
|
((out (list)))
|
||||||
|
(for-each
|
||||||
|
(fn (i) (append! out (nth xs i)))
|
||||||
|
(range from (len xs)))
|
||||||
|
out))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-build-cons
|
||||||
|
(fn (elems tail) (if (= (len elems) 0) tail {:head (nth elems 0) :tail (er-build-cons (er-slice-list elems 1) tail) :type "cons"})))
|
||||||
230
lib/erlang/tests/parse.sx
Normal file
230
lib/erlang/tests/parse.sx
Normal file
@@ -0,0 +1,230 @@
|
|||||||
|
;; Erlang parser tests
|
||||||
|
|
||||||
|
(define er-parse-test-count 0)
|
||||||
|
(define er-parse-test-pass 0)
|
||||||
|
(define er-parse-test-fails (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
deep=
|
||||||
|
(fn
|
||||||
|
(a b)
|
||||||
|
(cond
|
||||||
|
(and (= (type-of a) "dict") (= (type-of b) "dict"))
|
||||||
|
(let
|
||||||
|
((ka (sort (keys a))) (kb (sort (keys b))))
|
||||||
|
(and (= ka kb) (every? (fn (k) (deep= (get a k) (get b k))) ka)))
|
||||||
|
(and (= (type-of a) "list") (= (type-of b) "list"))
|
||||||
|
(and
|
||||||
|
(= (len a) (len b))
|
||||||
|
(every? (fn (i) (deep= (nth a i) (nth b i))) (range 0 (len a))))
|
||||||
|
:else (= a b))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-test
|
||||||
|
(fn
|
||||||
|
(name actual expected)
|
||||||
|
(set! er-parse-test-count (+ er-parse-test-count 1))
|
||||||
|
(if
|
||||||
|
(deep= actual expected)
|
||||||
|
(set! er-parse-test-pass (+ er-parse-test-pass 1))
|
||||||
|
(append! er-parse-test-fails {:actual actual :expected expected :name name}))))
|
||||||
|
(define pe er-parse-expr)
|
||||||
|
|
||||||
|
;; ── literals ──────────────────────────────────────────────────────
|
||||||
|
(define pm er-parse-module)
|
||||||
|
|
||||||
|
(er-parse-test "int" (pe "42") {:value "42" :type "integer"})
|
||||||
|
|
||||||
|
(er-parse-test "float" (pe "3.14") {:value "3.14" :type "float"})
|
||||||
|
|
||||||
|
(er-parse-test "atom" (pe "foo") {:value "foo" :type "atom"})
|
||||||
|
|
||||||
|
(er-parse-test "quoted atom" (pe "'Hello'") {:value "Hello" :type "atom"})
|
||||||
|
|
||||||
|
(er-parse-test "var" (pe "X") {:type "var" :name "X"})
|
||||||
|
|
||||||
|
(er-parse-test "wildcard" (pe "_") {:type "var" :name "_"})
|
||||||
|
|
||||||
|
(er-parse-test "string" (pe "\"hello\"") {:value "hello" :type "string"})
|
||||||
|
|
||||||
|
;; ── tuples ────────────────────────────────────────────────────────
|
||||||
|
(er-parse-test "nil list" (pe "[]") {:type "nil"})
|
||||||
|
|
||||||
|
(er-parse-test "empty tuple" (pe "{}") {:elements (list) :type "tuple"})
|
||||||
|
|
||||||
|
(er-parse-test "pair" (pe "{ok, 1}") {:elements (list {:value "ok" :type "atom"} {:value "1" :type "integer"}) :type "tuple"})
|
||||||
|
|
||||||
|
;; ── lists ─────────────────────────────────────────────────────────
|
||||||
|
(er-parse-test "triple" (pe "{a, b, c}") {:elements (list {:value "a" :type "atom"} {:value "b" :type "atom"} {:value "c" :type "atom"}) :type "tuple"})
|
||||||
|
|
||||||
|
(er-parse-test "list [1]" (pe "[1]") {:head {:value "1" :type "integer"} :tail {:type "nil"} :type "cons"})
|
||||||
|
|
||||||
|
(er-parse-test "cons [H|T]" (pe "[H|T]") {:head {:type "var" :name "H"} :tail {:type "var" :name "T"} :type "cons"})
|
||||||
|
|
||||||
|
;; ── operators / precedence ────────────────────────────────────────
|
||||||
|
(er-parse-test "list [1,2]" (pe "[1,2]") {:head {:value "1" :type "integer"} :tail {:head {:value "2" :type "integer"} :tail {:type "nil"} :type "cons"} :type "cons"})
|
||||||
|
|
||||||
|
(er-parse-test "add" (pe "1 + 2") {:args (list {:value "1" :type "integer"} {:value "2" :type "integer"}) :type "op" :op "+"})
|
||||||
|
|
||||||
|
(er-parse-test "mul binds tighter" (pe "1 + 2 * 3") {:args (list {:value "1" :type "integer"} {:args (list {:value "2" :type "integer"} {:value "3" :type "integer"}) :type "op" :op "*"}) :type "op" :op "+"})
|
||||||
|
|
||||||
|
(er-parse-test "parens" (pe "(1 + 2) * 3") {:args (list {:args (list {:value "1" :type "integer"} {:value "2" :type "integer"}) :type "op" :op "+"} {:value "3" :type "integer"}) :type "op" :op "*"})
|
||||||
|
|
||||||
|
(er-parse-test "neg unary" (pe "-5") {:arg {:value "5" :type "integer"} :type "unop" :op "-"})
|
||||||
|
|
||||||
|
(er-parse-test "not" (pe "not X") {:arg {:type "var" :name "X"} :type "unop" :op "not"})
|
||||||
|
|
||||||
|
(er-parse-test "match" (pe "X = 42") {:rhs {:value "42" :type "integer"} :type "match" :lhs {:type "var" :name "X"}})
|
||||||
|
|
||||||
|
(er-parse-test "cmp" (pe "X > 0") {:args (list {:type "var" :name "X"} {:value "0" :type "integer"}) :type "op" :op ">"})
|
||||||
|
|
||||||
|
(er-parse-test "eq =:=" (pe "X =:= 1") {:args (list {:type "var" :name "X"} {:value "1" :type "integer"}) :type "op" :op "=:="})
|
||||||
|
|
||||||
|
(er-parse-test "send" (pe "Pid ! hello") {:msg {:value "hello" :type "atom"} :type "send" :to {:type "var" :name "Pid"}})
|
||||||
|
|
||||||
|
(er-parse-test "andalso" (pe "X andalso Y") {:args (list {:type "var" :name "X"} {:type "var" :name "Y"}) :type "op" :op "andalso"})
|
||||||
|
|
||||||
|
(er-parse-test "orelse" (pe "X orelse Y") {:args (list {:type "var" :name "X"} {:type "var" :name "Y"}) :type "op" :op "orelse"})
|
||||||
|
|
||||||
|
(er-parse-test "++" (pe "A ++ B") {:args (list {:type "var" :name "A"} {:type "var" :name "B"}) :type "op" :op "++"})
|
||||||
|
|
||||||
|
(er-parse-test "div" (pe "10 div 3") {:args (list {:value "10" :type "integer"} {:value "3" :type "integer"}) :type "op" :op "div"})
|
||||||
|
|
||||||
|
;; ── calls ─────────────────────────────────────────────────────────
|
||||||
|
(er-parse-test "rem" (pe "10 rem 3") {:args (list {:value "10" :type "integer"} {:value "3" :type "integer"}) :type "op" :op "rem"})
|
||||||
|
|
||||||
|
(er-parse-test "local call 0-arity" (pe "self()") {:args (list) :fun {:value "self" :type "atom"} :type "call"})
|
||||||
|
|
||||||
|
(er-parse-test "local call 2-arg" (pe "foo(1, 2)") {:args (list {:value "1" :type "integer"} {:value "2" :type "integer"}) :fun {:value "foo" :type "atom"} :type "call"})
|
||||||
|
|
||||||
|
;; ── if / case / receive / fun / try ───────────────────────────────
|
||||||
|
(er-parse-test "remote call" (pe "lists:map(F, L)") {:args (list {:type "var" :name "F"} {:type "var" :name "L"}) :fun {:fun {:value "map" :type "atom"} :mod {:value "lists" :type "atom"} :type "remote"} :type "call"})
|
||||||
|
|
||||||
|
(er-parse-test "if-else" (pe "if X > 0 -> pos; true -> neg end") {:clauses (list {:body (list {:value "pos" :type "atom"}) :guards (list (list {:args (list {:type "var" :name "X"} {:value "0" :type "integer"}) :type "op" :op ">"}))} {:body (list {:value "neg" :type "atom"}) :guards (list (list {:value "true" :type "atom"}))}) :type "if"})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"case 2-clause"
|
||||||
|
(pe "case X of 0 -> zero; _ -> nz end")
|
||||||
|
{:expr {:type "var" :name "X"} :clauses (list {:pattern {:value "0" :type "integer"} :body (list {:value "zero" :type "atom"}) :guards (list)} {:pattern {:type "var" :name "_"} :body (list {:value "nz" :type "atom"}) :guards (list)}) :type "case"})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"case with guard"
|
||||||
|
(pe "case X of N when N > 0 -> pos; _ -> other end")
|
||||||
|
{:expr {:type "var" :name "X"} :clauses (list {:pattern {:type "var" :name "N"} :body (list {:value "pos" :type "atom"}) :guards (list (list {:args (list {:type "var" :name "N"} {:value "0" :type "integer"}) :type "op" :op ">"}))} {:pattern {:type "var" :name "_"} :body (list {:value "other" :type "atom"}) :guards (list)}) :type "case"})
|
||||||
|
|
||||||
|
(er-parse-test "receive one clause" (pe "receive X -> X end") {:clauses (list {:pattern {:type "var" :name "X"} :body (list {:type "var" :name "X"}) :guards (list)}) :type "receive" :after-ms nil :after-body (list)})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"receive after"
|
||||||
|
(pe "receive X -> X after 1000 -> timeout end")
|
||||||
|
{:clauses (list {:pattern {:type "var" :name "X"} :body (list {:type "var" :name "X"}) :guards (list)}) :type "receive" :after-ms {:value "1000" :type "integer"} :after-body (list {:value "timeout" :type "atom"})})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"receive just after"
|
||||||
|
(pe "receive after 0 -> ok end")
|
||||||
|
{:clauses (list) :type "receive" :after-ms {:value "0" :type "integer"} :after-body (list {:value "ok" :type "atom"})})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"anonymous fun 1-clause"
|
||||||
|
(pe "fun (X) -> X * 2 end")
|
||||||
|
{:clauses (list {:patterns (list {:type "var" :name "X"}) :body (list {:args (list {:type "var" :name "X"} {:value "2" :type "integer"}) :type "op" :op "*"}) :guards (list) :name nil}) :type "fun"})
|
||||||
|
|
||||||
|
(er-parse-test "begin/end block" (pe "begin 1, 2, 3 end") {:exprs (list {:value "1" :type "integer"} {:value "2" :type "integer"} {:value "3" :type "integer"}) :type "block"})
|
||||||
|
|
||||||
|
(er-parse-test "try/catch" (pe "try foo() catch error:X -> X end") {:exprs (list {:args (list) :fun {:value "foo" :type "atom"} :type "call"}) :catch-clauses (list {:pattern {:type "var" :name "X"} :body (list {:type "var" :name "X"}) :class {:value "error" :type "atom"} :guards (list)}) :type "try" :of-clauses (list) :after (list)})
|
||||||
|
|
||||||
|
;; ── module-level ──────────────────────────────────────────────────
|
||||||
|
(er-parse-test
|
||||||
|
"try catch default class"
|
||||||
|
(pe "try foo() catch X -> X end")
|
||||||
|
{:exprs (list {:args (list) :fun {:value "foo" :type "atom"} :type "call"}) :catch-clauses (list {:pattern {:type "var" :name "X"} :body (list {:type "var" :name "X"}) :class {:value "throw" :type "atom"} :guards (list)}) :type "try" :of-clauses (list) :after (list)})
|
||||||
|
|
||||||
|
(er-parse-test "minimal module" (pm "-module(m).\nfoo(X) -> X.") {:functions (list {:arity 1 :clauses (list {:patterns (list {:type "var" :name "X"}) :body (list {:type "var" :name "X"}) :guards (list) :name "foo"}) :type "function" :name "foo"}) :type "module" :attrs (list) :name "m"})
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"module with export"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\n-export([foo/1]).\nfoo(X) -> X.")))
|
||||||
|
(list
|
||||||
|
(get m :name)
|
||||||
|
(len (get m :attrs))
|
||||||
|
(get (nth (get m :attrs) 0) :name)
|
||||||
|
(len (get m :functions))))
|
||||||
|
(list "m" 1 "export" 1))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"two-clause function"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\nf(0) -> z; f(N) -> n.")))
|
||||||
|
(list (len (get (nth (get m :functions) 0) :clauses))))
|
||||||
|
(list 2))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"multi-arg function"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\nadd(X, Y) -> X + Y.")))
|
||||||
|
(list (get (nth (get m :functions) 0) :arity)))
|
||||||
|
(list 2))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"zero-arity"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\npi() -> 3.14.")))
|
||||||
|
(list (get (nth (get m :functions) 0) :arity)))
|
||||||
|
(list 0))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"function with guard"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\nabs(N) when N < 0 -> -N; abs(N) -> N.")))
|
||||||
|
(list
|
||||||
|
(len (get (nth (get m :functions) 0) :clauses))
|
||||||
|
(len
|
||||||
|
(get (nth (get (nth (get m :functions) 0) :clauses) 0) :guards))))
|
||||||
|
(list 2 1))
|
||||||
|
|
||||||
|
;; ── combined programs ────────────────────────────────────────────
|
||||||
|
(er-parse-test
|
||||||
|
"three-function module"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(m).\na() -> 1.\nb() -> 2.\nc() -> 3.")))
|
||||||
|
(list
|
||||||
|
(len (get m :functions))
|
||||||
|
(get (nth (get m :functions) 0) :name)
|
||||||
|
(get (nth (get m :functions) 1) :name)
|
||||||
|
(get (nth (get m :functions) 2) :name)))
|
||||||
|
(list 3 "a" "b" "c"))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"factorial"
|
||||||
|
(let
|
||||||
|
((m (pm "-module(fact).\n-export([fact/1]).\nfact(0) -> 1;\nfact(N) -> N * fact(N - 1).")))
|
||||||
|
(list
|
||||||
|
(get m :name)
|
||||||
|
(get (nth (get m :functions) 0) :arity)
|
||||||
|
(len (get (nth (get m :functions) 0) :clauses))))
|
||||||
|
(list "fact" 1 2))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"ping-pong snippet"
|
||||||
|
(let
|
||||||
|
((e (pe "receive ping -> Sender ! pong end")))
|
||||||
|
(list (get e :type) (len (get e :clauses))))
|
||||||
|
(list "receive" 1))
|
||||||
|
|
||||||
|
(er-parse-test
|
||||||
|
"case with nested tuple"
|
||||||
|
(let
|
||||||
|
((e (pe "case X of {ok, V} -> V; error -> 0 end")))
|
||||||
|
(list (get e :type) (len (get e :clauses))))
|
||||||
|
(list "case" 2))
|
||||||
|
|
||||||
|
;; ── summary ──────────────────────────────────────────────────────
|
||||||
|
(er-parse-test
|
||||||
|
"deep expression"
|
||||||
|
(let ((e (pe "A + B * C - D / E"))) (get e :op))
|
||||||
|
"-")
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-parse-test-summary
|
||||||
|
(str "parser " er-parse-test-pass "/" er-parse-test-count))
|
||||||
245
lib/erlang/tests/tokenize.sx
Normal file
245
lib/erlang/tests/tokenize.sx
Normal file
@@ -0,0 +1,245 @@
|
|||||||
|
;; Erlang tokenizer tests
|
||||||
|
|
||||||
|
(define er-test-count 0)
|
||||||
|
(define er-test-pass 0)
|
||||||
|
(define er-test-fails (list))
|
||||||
|
|
||||||
|
(define tok-type (fn (t) (get t :type)))
|
||||||
|
(define tok-value (fn (t) (get t :value)))
|
||||||
|
|
||||||
|
(define tok-types (fn (src) (map tok-type (er-tokenize src))))
|
||||||
|
|
||||||
|
(define tok-values (fn (src) (map tok-value (er-tokenize src))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-test
|
||||||
|
(fn
|
||||||
|
(name actual expected)
|
||||||
|
(set! er-test-count (+ er-test-count 1))
|
||||||
|
(if
|
||||||
|
(= actual expected)
|
||||||
|
(set! er-test-pass (+ er-test-pass 1))
|
||||||
|
(append! er-test-fails {:actual actual :expected expected :name name}))))
|
||||||
|
|
||||||
|
;; ── atoms ─────────────────────────────────────────────────────────
|
||||||
|
(er-test "atom: bare" (tok-values "foo") (list "foo" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"atom: snake_case"
|
||||||
|
(tok-values "hello_world")
|
||||||
|
(list "hello_world" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"atom: quoted"
|
||||||
|
(tok-values "'Hello World'")
|
||||||
|
(list "Hello World" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"atom: quoted with special chars"
|
||||||
|
(tok-values "'foo-bar'")
|
||||||
|
(list "foo-bar" nil))
|
||||||
|
|
||||||
|
(er-test "atom: with @" (tok-values "node@host") (list "node@host" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"atom: type is atom"
|
||||||
|
(tok-types "foo bar baz")
|
||||||
|
(list "atom" "atom" "atom" "eof"))
|
||||||
|
|
||||||
|
;; ── variables ─────────────────────────────────────────────────────
|
||||||
|
(er-test "var: uppercase" (tok-values "X") (list "X" nil))
|
||||||
|
|
||||||
|
(er-test "var: camelcase" (tok-values "FooBar") (list "FooBar" nil))
|
||||||
|
|
||||||
|
(er-test "var: underscore" (tok-values "_") (list "_" nil))
|
||||||
|
|
||||||
|
(er-test "var: _prefixed" (tok-values "_ignored") (list "_ignored" nil))
|
||||||
|
|
||||||
|
(er-test "var: type" (tok-types "X Y _") (list "var" "var" "var" "eof"))
|
||||||
|
|
||||||
|
;; ── integers ──────────────────────────────────────────────────────
|
||||||
|
(er-test "integer: zero" (tok-values "0") (list "0" nil))
|
||||||
|
|
||||||
|
(er-test "integer: positive" (tok-values "42") (list "42" nil))
|
||||||
|
|
||||||
|
(er-test "integer: big" (tok-values "12345678") (list "12345678" nil))
|
||||||
|
|
||||||
|
(er-test "integer: hex" (tok-values "16#FF") (list "16#FF" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"integer: type"
|
||||||
|
(tok-types "1 2 3")
|
||||||
|
(list "integer" "integer" "integer" "eof"))
|
||||||
|
|
||||||
|
(er-test "integer: char literal" (tok-types "$a") (list "integer" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"integer: char literal escape"
|
||||||
|
(tok-types "$\\n")
|
||||||
|
(list "integer" "eof"))
|
||||||
|
|
||||||
|
;; ── floats ────────────────────────────────────────────────────────
|
||||||
|
(er-test "float: simple" (tok-values "3.14") (list "3.14" nil))
|
||||||
|
|
||||||
|
(er-test "float: exponent" (tok-values "1.0e10") (list "1.0e10" nil))
|
||||||
|
|
||||||
|
(er-test "float: neg exponent" (tok-values "1.5e-3") (list "1.5e-3" nil))
|
||||||
|
|
||||||
|
(er-test "float: type" (tok-types "3.14") (list "float" "eof"))
|
||||||
|
|
||||||
|
;; ── strings ───────────────────────────────────────────────────────
|
||||||
|
(er-test "string: simple" (tok-values "\"hello\"") (list "hello" nil))
|
||||||
|
|
||||||
|
(er-test "string: empty" (tok-values "\"\"") (list "" nil))
|
||||||
|
|
||||||
|
(er-test "string: escape newline" (tok-values "\"a\\nb\"") (list "a\nb" nil))
|
||||||
|
|
||||||
|
(er-test "string: type" (tok-types "\"hello\"") (list "string" "eof"))
|
||||||
|
|
||||||
|
;; ── keywords ──────────────────────────────────────────────────────
|
||||||
|
(er-test "keyword: case" (tok-types "case") (list "keyword" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"keyword: of end when"
|
||||||
|
(tok-types "of end when")
|
||||||
|
(list "keyword" "keyword" "keyword" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"keyword: receive after"
|
||||||
|
(tok-types "receive after")
|
||||||
|
(list "keyword" "keyword" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"keyword: fun try catch"
|
||||||
|
(tok-types "fun try catch")
|
||||||
|
(list "keyword" "keyword" "keyword" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"keyword: andalso orelse not"
|
||||||
|
(tok-types "andalso orelse not")
|
||||||
|
(list "keyword" "keyword" "keyword" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"keyword: div rem"
|
||||||
|
(tok-types "div rem")
|
||||||
|
(list "keyword" "keyword" "eof"))
|
||||||
|
|
||||||
|
;; ── punct ─────────────────────────────────────────────────────────
|
||||||
|
(er-test "punct: parens" (tok-values "()") (list "(" ")" nil))
|
||||||
|
|
||||||
|
(er-test "punct: braces" (tok-values "{}") (list "{" "}" nil))
|
||||||
|
|
||||||
|
(er-test "punct: brackets" (tok-values "[]") (list "[" "]" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"punct: commas"
|
||||||
|
(tok-types "a,b")
|
||||||
|
(list "atom" "punct" "atom" "eof"))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"punct: semicolon"
|
||||||
|
(tok-types "a;b")
|
||||||
|
(list "atom" "punct" "atom" "eof"))
|
||||||
|
|
||||||
|
(er-test "punct: period" (tok-types "a.") (list "atom" "punct" "eof"))
|
||||||
|
|
||||||
|
(er-test "punct: arrow" (tok-values "->") (list "->" nil))
|
||||||
|
|
||||||
|
(er-test "punct: backarrow" (tok-values "<-") (list "<-" nil))
|
||||||
|
|
||||||
|
(er-test "punct: binary brackets" (tok-values "<<>>") (list "<<" ">>" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"punct: cons bar"
|
||||||
|
(tok-values "[a|b]")
|
||||||
|
(list "[" "a" "|" "b" "]" nil))
|
||||||
|
|
||||||
|
(er-test "punct: double-bar (list comp)" (tok-values "||") (list "||" nil))
|
||||||
|
|
||||||
|
(er-test "punct: double-colon" (tok-values "::") (list "::" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"punct: module-colon"
|
||||||
|
(tok-values "lists:map")
|
||||||
|
(list "lists" ":" "map" nil))
|
||||||
|
|
||||||
|
;; ── operators ─────────────────────────────────────────────────────
|
||||||
|
(er-test
|
||||||
|
"op: plus minus times div"
|
||||||
|
(tok-values "+ - * /")
|
||||||
|
(list "+" "-" "*" "/" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"op: eq/neq"
|
||||||
|
(tok-values "== /= =:= =/=")
|
||||||
|
(list "==" "/=" "=:=" "=/=" nil))
|
||||||
|
|
||||||
|
(er-test "op: compare" (tok-values "< > =< >=") (list "<" ">" "=<" ">=" nil))
|
||||||
|
|
||||||
|
(er-test "op: list ops" (tok-values "++ --") (list "++" "--" nil))
|
||||||
|
|
||||||
|
(er-test "op: send" (tok-values "!") (list "!" nil))
|
||||||
|
|
||||||
|
(er-test "op: match" (tok-values "=") (list "=" nil))
|
||||||
|
|
||||||
|
;; ── comments ──────────────────────────────────────────────────────
|
||||||
|
(er-test
|
||||||
|
"comment: ignored"
|
||||||
|
(tok-values "x % this is a comment\ny")
|
||||||
|
(list "x" "y" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"comment: end-of-file"
|
||||||
|
(tok-values "x % comment to eof")
|
||||||
|
(list "x" nil))
|
||||||
|
|
||||||
|
;; ── combined ──────────────────────────────────────────────────────
|
||||||
|
(er-test
|
||||||
|
"combined: function head"
|
||||||
|
(tok-values "foo(X, Y) -> X + Y.")
|
||||||
|
(list "foo" "(" "X" "," "Y" ")" "->" "X" "+" "Y" "." nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: case expression"
|
||||||
|
(tok-values "case X of 1 -> ok; _ -> err end")
|
||||||
|
(list "case" "X" "of" "1" "->" "ok" ";" "_" "->" "err" "end" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: tuple"
|
||||||
|
(tok-values "{ok, 42}")
|
||||||
|
(list "{" "ok" "," "42" "}" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: list cons"
|
||||||
|
(tok-values "[H|T]")
|
||||||
|
(list "[" "H" "|" "T" "]" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: receive"
|
||||||
|
(tok-values "receive X -> X end")
|
||||||
|
(list "receive" "X" "->" "X" "end" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: guard"
|
||||||
|
(tok-values "when is_integer(X)")
|
||||||
|
(list "when" "is_integer" "(" "X" ")" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: module attr"
|
||||||
|
(tok-values "-module(foo).")
|
||||||
|
(list "-" "module" "(" "foo" ")" "." nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: send"
|
||||||
|
(tok-values "Pid ! {self(), hello}")
|
||||||
|
(list "Pid" "!" "{" "self" "(" ")" "," "hello" "}" nil))
|
||||||
|
|
||||||
|
(er-test
|
||||||
|
"combined: whitespace skip"
|
||||||
|
(tok-values " a \n b \t c ")
|
||||||
|
(list "a" "b" "c" nil))
|
||||||
|
|
||||||
|
;; ── report ────────────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
er-tokenize-test-summary
|
||||||
|
(str "tokenizer " er-test-pass "/" er-test-count))
|
||||||
334
lib/erlang/tokenizer.sx
Normal file
334
lib/erlang/tokenizer.sx
Normal file
@@ -0,0 +1,334 @@
|
|||||||
|
;; Erlang tokenizer — produces token stream from Erlang source
|
||||||
|
;;
|
||||||
|
;; Tokens: {:type T :value V :pos P}
|
||||||
|
;; Types:
|
||||||
|
;; "atom" — foo, 'Quoted Atom'
|
||||||
|
;; "var" — X, Foo, _Bar, _ (wildcard)
|
||||||
|
;; "integer" — 42, 16#FF, $c (char literal)
|
||||||
|
;; "float" — 3.14, 1.0e10
|
||||||
|
;; "string" — "..."
|
||||||
|
;; "keyword" — case of end if when receive after fun try catch
|
||||||
|
;; begin do let module export import define andalso orelse
|
||||||
|
;; not div rem bnot band bor bxor bsl bsr
|
||||||
|
;; "punct" — ( ) { } [ ] , ; . : :: -> <- <= => | ||
|
||||||
|
;; << >>
|
||||||
|
;; "op" — + - * / = == /= =:= =/= < > =< >= ++ -- ! ?
|
||||||
|
;; "eof"
|
||||||
|
|
||||||
|
(define er-make-token (fn (type value pos) {:pos pos :value value :type type}))
|
||||||
|
|
||||||
|
(define er-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-hex-digit?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(or
|
||||||
|
(er-digit? c)
|
||||||
|
(and (>= c "a") (<= c "f"))
|
||||||
|
(and (>= c "A") (<= c "F")))))
|
||||||
|
|
||||||
|
(define er-lower? (fn (c) (and (>= c "a") (<= c "z"))))
|
||||||
|
|
||||||
|
(define er-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
|
||||||
|
|
||||||
|
(define er-letter? (fn (c) (or (er-lower? c) (er-upper? c))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-ident-char?
|
||||||
|
(fn (c) (or (er-letter? c) (er-digit? c) (= c "_") (= c "@"))))
|
||||||
|
|
||||||
|
(define er-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||||
|
|
||||||
|
;; Erlang reserved words — everything else starting lowercase is an atom
|
||||||
|
(define
|
||||||
|
er-keywords
|
||||||
|
(list
|
||||||
|
"after"
|
||||||
|
"and"
|
||||||
|
"andalso"
|
||||||
|
"band"
|
||||||
|
"begin"
|
||||||
|
"bnot"
|
||||||
|
"bor"
|
||||||
|
"bsl"
|
||||||
|
"bsr"
|
||||||
|
"bxor"
|
||||||
|
"case"
|
||||||
|
"catch"
|
||||||
|
"cond"
|
||||||
|
"div"
|
||||||
|
"end"
|
||||||
|
"fun"
|
||||||
|
"if"
|
||||||
|
"let"
|
||||||
|
"not"
|
||||||
|
"of"
|
||||||
|
"or"
|
||||||
|
"orelse"
|
||||||
|
"receive"
|
||||||
|
"rem"
|
||||||
|
"try"
|
||||||
|
"when"
|
||||||
|
"xor"))
|
||||||
|
|
||||||
|
(define er-keyword? (fn (word) (some (fn (k) (= k word)) er-keywords)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-tokenize
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((tokens (list)) (pos 0) (src-len (len src)))
|
||||||
|
(define
|
||||||
|
er-peek
|
||||||
|
(fn
|
||||||
|
(offset)
|
||||||
|
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||||
|
(define er-cur (fn () (er-peek 0)))
|
||||||
|
(define er-advance! (fn (n) (set! pos (+ pos n))))
|
||||||
|
(define
|
||||||
|
skip-ws!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (er-ws? (er-cur)))
|
||||||
|
(er-advance! 1)
|
||||||
|
(skip-ws!))))
|
||||||
|
(define
|
||||||
|
skip-comment!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (not (= (er-cur) "\n")))
|
||||||
|
(er-advance! 1)
|
||||||
|
(skip-comment!))))
|
||||||
|
(define
|
||||||
|
read-ident-chars
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (er-ident-char? (er-cur)))
|
||||||
|
(er-advance! 1)
|
||||||
|
(read-ident-chars start))
|
||||||
|
(slice src start pos)))
|
||||||
|
(define
|
||||||
|
read-integer-digits
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (er-digit? (er-cur)))
|
||||||
|
(er-advance! 1)
|
||||||
|
(read-integer-digits))))
|
||||||
|
(define
|
||||||
|
read-hex-digits
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (er-hex-digit? (er-cur)))
|
||||||
|
(er-advance! 1)
|
||||||
|
(read-hex-digits))))
|
||||||
|
(define
|
||||||
|
read-number
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(read-integer-digits)
|
||||||
|
(cond
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(= (er-cur) "#")
|
||||||
|
(< (+ pos 1) src-len)
|
||||||
|
(er-hex-digit? (er-peek 1)))
|
||||||
|
(do (er-advance! 1) (read-hex-digits) {:value (slice src start pos) :type "integer"})
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(= (er-cur) ".")
|
||||||
|
(< (+ pos 1) src-len)
|
||||||
|
(er-digit? (er-peek 1)))
|
||||||
|
(do
|
||||||
|
(er-advance! 1)
|
||||||
|
(read-integer-digits)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (er-cur) "e") (= (er-cur) "E")))
|
||||||
|
(er-advance! 1)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (er-cur) "+") (= (er-cur) "-")))
|
||||||
|
(er-advance! 1))
|
||||||
|
(read-integer-digits))
|
||||||
|
{:value (slice src start pos) :type "float"})
|
||||||
|
:else {:value (slice src start pos) :type "integer"})))
|
||||||
|
(define
|
||||||
|
read-string
|
||||||
|
(fn
|
||||||
|
(quote-char)
|
||||||
|
(let
|
||||||
|
((chars (list)))
|
||||||
|
(er-advance! 1)
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
(>= pos src-len)
|
||||||
|
nil
|
||||||
|
(= (er-cur) "\\")
|
||||||
|
(do
|
||||||
|
(er-advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (er-cur)))
|
||||||
|
(cond
|
||||||
|
(= ch "n")
|
||||||
|
(append! chars "\n")
|
||||||
|
(= ch "t")
|
||||||
|
(append! chars "\t")
|
||||||
|
(= ch "r")
|
||||||
|
(append! chars "\r")
|
||||||
|
(= ch "\\")
|
||||||
|
(append! chars "\\")
|
||||||
|
(= ch "\"")
|
||||||
|
(append! chars "\"")
|
||||||
|
(= ch "'")
|
||||||
|
(append! chars "'")
|
||||||
|
:else (append! chars ch))
|
||||||
|
(er-advance! 1)))
|
||||||
|
(loop))
|
||||||
|
(= (er-cur) quote-char)
|
||||||
|
(er-advance! 1)
|
||||||
|
:else (do (append! chars (er-cur)) (er-advance! 1) (loop)))))
|
||||||
|
(loop)
|
||||||
|
(join "" chars))))
|
||||||
|
(define
|
||||||
|
er-emit!
|
||||||
|
(fn
|
||||||
|
(type value start)
|
||||||
|
(append! tokens (er-make-token type value start))))
|
||||||
|
(define
|
||||||
|
scan!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(skip-ws!)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (er-cur)) (start pos))
|
||||||
|
(cond
|
||||||
|
(= ch "%")
|
||||||
|
(do (skip-comment!) (scan!))
|
||||||
|
(er-digit? ch)
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((tok (read-number start)))
|
||||||
|
(er-emit! (get tok :type) (get tok :value) start))
|
||||||
|
(scan!))
|
||||||
|
(= ch "$")
|
||||||
|
(do
|
||||||
|
(er-advance! 1)
|
||||||
|
(if
|
||||||
|
(and (< pos src-len) (= (er-cur) "\\"))
|
||||||
|
(do
|
||||||
|
(er-advance! 1)
|
||||||
|
(when (< pos src-len) (er-advance! 1)))
|
||||||
|
(when (< pos src-len) (er-advance! 1)))
|
||||||
|
(er-emit! "integer" (slice src start pos) start)
|
||||||
|
(scan!))
|
||||||
|
(er-lower? ch)
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((word (read-ident-chars start)))
|
||||||
|
(er-emit!
|
||||||
|
(if (er-keyword? word) "keyword" "atom")
|
||||||
|
word
|
||||||
|
start))
|
||||||
|
(scan!))
|
||||||
|
(or (er-upper? ch) (= ch "_"))
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((word (read-ident-chars start)))
|
||||||
|
(er-emit! "var" word start))
|
||||||
|
(scan!))
|
||||||
|
(= ch "'")
|
||||||
|
(do (er-emit! "atom" (read-string "'") start) (scan!))
|
||||||
|
(= ch "\"")
|
||||||
|
(do (er-emit! "string" (read-string "\"") start) (scan!))
|
||||||
|
(and (= ch "<") (= (er-peek 1) "<"))
|
||||||
|
(do (er-emit! "punct" "<<" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch ">") (= (er-peek 1) ">"))
|
||||||
|
(do (er-emit! "punct" ">>" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "-") (= (er-peek 1) ">"))
|
||||||
|
(do (er-emit! "punct" "->" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "<") (= (er-peek 1) "-"))
|
||||||
|
(do (er-emit! "punct" "<-" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "<") (= (er-peek 1) "="))
|
||||||
|
(do (er-emit! "punct" "<=" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "=") (= (er-peek 1) ">"))
|
||||||
|
(do (er-emit! "punct" "=>" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "=") (= (er-peek 1) ":") (= (er-peek 2) "="))
|
||||||
|
(do (er-emit! "op" "=:=" start) (er-advance! 3) (scan!))
|
||||||
|
(and (= ch "=") (= (er-peek 1) "/") (= (er-peek 2) "="))
|
||||||
|
(do (er-emit! "op" "=/=" start) (er-advance! 3) (scan!))
|
||||||
|
(and (= ch "=") (= (er-peek 1) "="))
|
||||||
|
(do (er-emit! "op" "==" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "/") (= (er-peek 1) "="))
|
||||||
|
(do (er-emit! "op" "/=" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "=") (= (er-peek 1) "<"))
|
||||||
|
(do (er-emit! "op" "=<" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch ">") (= (er-peek 1) "="))
|
||||||
|
(do (er-emit! "op" ">=" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "+") (= (er-peek 1) "+"))
|
||||||
|
(do (er-emit! "op" "++" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "-") (= (er-peek 1) "-"))
|
||||||
|
(do (er-emit! "op" "--" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch ":") (= (er-peek 1) ":"))
|
||||||
|
(do (er-emit! "punct" "::" start) (er-advance! 2) (scan!))
|
||||||
|
(and (= ch "|") (= (er-peek 1) "|"))
|
||||||
|
(do (er-emit! "punct" "||" start) (er-advance! 2) (scan!))
|
||||||
|
(= ch "(")
|
||||||
|
(do (er-emit! "punct" "(" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ")")
|
||||||
|
(do (er-emit! "punct" ")" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "{")
|
||||||
|
(do (er-emit! "punct" "{" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "}")
|
||||||
|
(do (er-emit! "punct" "}" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "[")
|
||||||
|
(do (er-emit! "punct" "[" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "]")
|
||||||
|
(do (er-emit! "punct" "]" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ",")
|
||||||
|
(do (er-emit! "punct" "," start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ";")
|
||||||
|
(do (er-emit! "punct" ";" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ".")
|
||||||
|
(do (er-emit! "punct" "." start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ":")
|
||||||
|
(do (er-emit! "punct" ":" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "|")
|
||||||
|
(do (er-emit! "punct" "|" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "+")
|
||||||
|
(do (er-emit! "op" "+" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "-")
|
||||||
|
(do (er-emit! "op" "-" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "*")
|
||||||
|
(do (er-emit! "op" "*" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "/")
|
||||||
|
(do (er-emit! "op" "/" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "=")
|
||||||
|
(do (er-emit! "op" "=" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "<")
|
||||||
|
(do (er-emit! "op" "<" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch ">")
|
||||||
|
(do (er-emit! "op" ">" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "!")
|
||||||
|
(do (er-emit! "op" "!" start) (er-advance! 1) (scan!))
|
||||||
|
(= ch "?")
|
||||||
|
(do (er-emit! "op" "?" start) (er-advance! 1) (scan!))
|
||||||
|
:else (do (er-advance! 1) (scan!)))))))
|
||||||
|
(scan!)
|
||||||
|
(er-emit! "eof" nil pos)
|
||||||
|
tokens)))
|
||||||
274
lib/forth/compiler.sx
Normal file
274
lib/forth/compiler.sx
Normal file
@@ -0,0 +1,274 @@
|
|||||||
|
;; Phase 2 — colon definitions, compile mode, VARIABLE/CONSTANT/VALUE/TO, @/!/+!.
|
||||||
|
;;
|
||||||
|
;; Compile-mode representation:
|
||||||
|
;; A colon-definition body is a list of "ops", each an SX lambda (fn (s) ...).
|
||||||
|
;; : FOO 1 2 + ; -> body = (push-1 push-2 call-plus)
|
||||||
|
;; References to other words are compiled as late-binding thunks so that
|
||||||
|
;; self-reference works and redefinitions take effect for future runs.
|
||||||
|
;;
|
||||||
|
;; State additions used in Phase 2:
|
||||||
|
;; "compiling" : bool — are we inside :..; ?
|
||||||
|
;; "current-def" : dict {:name "..." :body (list)} during compile
|
||||||
|
;; "vars" : dict {"addr-name" -> cell-value} for VARIABLE storage
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-compile-token
|
||||||
|
(fn
|
||||||
|
(state tok)
|
||||||
|
(let
|
||||||
|
((w (forth-lookup state tok)))
|
||||||
|
(if
|
||||||
|
(not (nil? w))
|
||||||
|
(if
|
||||||
|
(get w "immediate?")
|
||||||
|
(forth-execute-word state w)
|
||||||
|
(forth-compile-call state tok))
|
||||||
|
(let
|
||||||
|
((n (forth-parse-number tok (get state "base"))))
|
||||||
|
(if
|
||||||
|
(not (nil? n))
|
||||||
|
(forth-compile-lit state n)
|
||||||
|
(forth-error state (str tok " ?"))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-compile-call
|
||||||
|
(fn
|
||||||
|
(state name)
|
||||||
|
(let
|
||||||
|
((op (fn (s) (let ((w (forth-lookup s name))) (if (nil? w) (forth-error s (str name " ? (compiled)")) (forth-execute-word s w))))))
|
||||||
|
(forth-def-append! state op))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-compile-lit
|
||||||
|
(fn
|
||||||
|
(state n)
|
||||||
|
(let ((op (fn (s) (forth-push s n)))) (forth-def-append! state op))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-def-append!
|
||||||
|
(fn
|
||||||
|
(state op)
|
||||||
|
(let
|
||||||
|
((def (get state "current-def")))
|
||||||
|
(dict-set! def "body" (concat (get def "body") (list op))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-make-colon-body
|
||||||
|
(fn (ops) (fn (s) (for-each (fn (op) (op s)) ops))))
|
||||||
|
|
||||||
|
;; Override forth-interpret-token to branch on compile mode.
|
||||||
|
(define
|
||||||
|
forth-interpret-token
|
||||||
|
(fn
|
||||||
|
(state tok)
|
||||||
|
(if
|
||||||
|
(get state "compiling")
|
||||||
|
(forth-compile-token state tok)
|
||||||
|
(let
|
||||||
|
((w (forth-lookup state tok)))
|
||||||
|
(if
|
||||||
|
(not (nil? w))
|
||||||
|
(forth-execute-word state w)
|
||||||
|
(let
|
||||||
|
((n (forth-parse-number tok (get state "base"))))
|
||||||
|
(if
|
||||||
|
(not (nil? n))
|
||||||
|
(forth-push state n)
|
||||||
|
(forth-error state (str tok " ?")))))))))
|
||||||
|
|
||||||
|
;; Install `:` and `;` plus VARIABLE, CONSTANT, VALUE, TO, @, !, +!, RECURSE.
|
||||||
|
(define
|
||||||
|
forth-install-compiler!
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
":"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((name (forth-next-token! s)))
|
||||||
|
(when (nil? name) (forth-error s ": expects name"))
|
||||||
|
(let
|
||||||
|
((def (dict)))
|
||||||
|
(dict-set! def "name" name)
|
||||||
|
(dict-set! def "body" (list))
|
||||||
|
(dict-set! s "current-def" def)
|
||||||
|
(dict-set! s "compiling" true)))))
|
||||||
|
(forth-def-prim-imm!
|
||||||
|
state
|
||||||
|
";"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((def (get s "current-def")))
|
||||||
|
(when (nil? def) (forth-error s "; outside definition"))
|
||||||
|
(let
|
||||||
|
((ops (get def "body")))
|
||||||
|
(let
|
||||||
|
((body-fn (forth-make-colon-body ops)))
|
||||||
|
(dict-set!
|
||||||
|
(get s "dict")
|
||||||
|
(downcase (get def "name"))
|
||||||
|
(forth-make-word "colon-def" body-fn false))
|
||||||
|
(dict-set! s "current-def" nil)
|
||||||
|
(dict-set! s "compiling" false))))))
|
||||||
|
(forth-def-prim-imm!
|
||||||
|
state
|
||||||
|
"IMMEDIATE"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((def-name (get (get s "current-def") "name"))
|
||||||
|
(target
|
||||||
|
(if
|
||||||
|
(nil? (get s "current-def"))
|
||||||
|
(forth-last-defined s)
|
||||||
|
(get (get s "current-def") "name"))))
|
||||||
|
(let
|
||||||
|
((w (forth-lookup s target)))
|
||||||
|
(when (not (nil? w)) (dict-set! w "immediate?" true))))))
|
||||||
|
(forth-def-prim-imm!
|
||||||
|
state
|
||||||
|
"RECURSE"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(when
|
||||||
|
(not (get s "compiling"))
|
||||||
|
(forth-error s "RECURSE only in definition"))
|
||||||
|
(let
|
||||||
|
((name (get (get s "current-def") "name")))
|
||||||
|
(forth-compile-call s name))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"VARIABLE"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((name (forth-next-token! s)))
|
||||||
|
(when (nil? name) (forth-error s "VARIABLE expects name"))
|
||||||
|
(dict-set! (get s "vars") (downcase name) 0)
|
||||||
|
(forth-def-prim!
|
||||||
|
s
|
||||||
|
name
|
||||||
|
(fn (ss) (forth-push ss (downcase name)))))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"CONSTANT"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||||
|
(when (nil? name) (forth-error s "CONSTANT expects name"))
|
||||||
|
(forth-def-prim! s name (fn (ss) (forth-push ss v))))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"VALUE"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||||
|
(when (nil? name) (forth-error s "VALUE expects name"))
|
||||||
|
(dict-set! (get s "vars") (downcase name) v)
|
||||||
|
(forth-def-prim!
|
||||||
|
s
|
||||||
|
name
|
||||||
|
(fn
|
||||||
|
(ss)
|
||||||
|
(forth-push ss (get (get ss "vars") (downcase name))))))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"TO"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||||
|
(when (nil? name) (forth-error s "TO expects name"))
|
||||||
|
(dict-set! (get s "vars") (downcase name) v))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"@"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((addr (forth-pop s)))
|
||||||
|
(forth-push s (or (get (get s "vars") addr) 0)))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"!"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((addr (forth-pop s)) (v (forth-pop s)))
|
||||||
|
(dict-set! (get s "vars") addr v))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"+!"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((addr (forth-pop s)) (v (forth-pop s)))
|
||||||
|
(let
|
||||||
|
((cur (or (get (get s "vars") addr) 0)))
|
||||||
|
(dict-set! (get s "vars") addr (+ cur v))))))
|
||||||
|
state))
|
||||||
|
|
||||||
|
;; Track the most recently defined word name for IMMEDIATE.
|
||||||
|
(define forth-last-defined (fn (state) (get state "last-defined")))
|
||||||
|
|
||||||
|
;; forth-next-token!: during `:`, VARIABLE, CONSTANT, etc. we need to pull
|
||||||
|
;; the next token from the *input stream* (not the dict/stack). Phase-1
|
||||||
|
;; interpreter fed tokens one at a time via for-each, so a parsing word
|
||||||
|
;; can't reach ahead. We rework `forth-interpret` to keep the remaining
|
||||||
|
;; token list on the state so parsing words can consume from it.
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-next-token!
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((rest (get state "input")))
|
||||||
|
(if
|
||||||
|
(or (nil? rest) (= (len rest) 0))
|
||||||
|
nil
|
||||||
|
(let
|
||||||
|
((tok (first rest)))
|
||||||
|
(dict-set! state "input" (rest-of rest))
|
||||||
|
tok)))))
|
||||||
|
|
||||||
|
(define rest-of (fn (l) (rest l)))
|
||||||
|
|
||||||
|
;; Rewritten forth-interpret: drives a token list stored in state so that
|
||||||
|
;; parsing words like `:`, `VARIABLE`, `CONSTANT`, `TO` can consume the
|
||||||
|
;; following token.
|
||||||
|
(define
|
||||||
|
forth-interpret
|
||||||
|
(fn
|
||||||
|
(state src)
|
||||||
|
(dict-set! state "input" (forth-tokens src))
|
||||||
|
(forth-interpret-loop state)
|
||||||
|
state))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-interpret-loop
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((tok (forth-next-token! state)))
|
||||||
|
(if
|
||||||
|
(nil? tok)
|
||||||
|
state
|
||||||
|
(begin
|
||||||
|
(forth-interpret-token state tok)
|
||||||
|
(forth-interpret-loop state))))))
|
||||||
|
|
||||||
|
;; Re-export forth-boot to include the compiler primitives too.
|
||||||
|
(define
|
||||||
|
forth-boot
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((s (forth-make-state)))
|
||||||
|
(forth-install-primitives! s)
|
||||||
|
(forth-install-compiler! s)
|
||||||
|
s)))
|
||||||
48
lib/forth/interpreter.sx
Normal file
48
lib/forth/interpreter.sx
Normal file
@@ -0,0 +1,48 @@
|
|||||||
|
;; Forth interpreter loop — interpret mode only (Phase 1).
|
||||||
|
;; Reads whitespace-delimited words, looks them up, executes.
|
||||||
|
;; Numbers (parsed via BASE) push onto the data stack.
|
||||||
|
;; Unknown words raise "?".
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-execute-word
|
||||||
|
(fn (state word) (let ((body (get word "body"))) (body state))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-interpret-token
|
||||||
|
(fn
|
||||||
|
(state tok)
|
||||||
|
(let
|
||||||
|
((w (forth-lookup state tok)))
|
||||||
|
(if
|
||||||
|
(not (nil? w))
|
||||||
|
(forth-execute-word state w)
|
||||||
|
(let
|
||||||
|
((n (forth-parse-number tok (get state "base"))))
|
||||||
|
(if
|
||||||
|
(not (nil? n))
|
||||||
|
(forth-push state n)
|
||||||
|
(forth-error state (str tok " ?"))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-interpret
|
||||||
|
(fn
|
||||||
|
(state src)
|
||||||
|
(for-each
|
||||||
|
(fn (tok) (forth-interpret-token state tok))
|
||||||
|
(forth-tokens src))
|
||||||
|
state))
|
||||||
|
|
||||||
|
;; Convenience: build a fresh state with primitives loaded.
|
||||||
|
(define
|
||||||
|
forth-boot
|
||||||
|
(fn () (let ((s (forth-make-state))) (forth-install-primitives! s) s)))
|
||||||
|
|
||||||
|
;; Run source on a fresh state and return (state, output, stack-top-to-bottom).
|
||||||
|
(define
|
||||||
|
forth-run
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((s (forth-boot)))
|
||||||
|
(forth-interpret s src)
|
||||||
|
(list s (get s "output") (reverse (get s "dstack"))))))
|
||||||
104
lib/forth/reader.sx
Normal file
104
lib/forth/reader.sx
Normal file
@@ -0,0 +1,104 @@
|
|||||||
|
;; Forth reader — whitespace-delimited tokens.
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-whitespace?
|
||||||
|
(fn (ch) (or (= ch " ") (or (= ch "\t") (or (= ch "\n") (= ch "\r"))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-tokens-loop
|
||||||
|
(fn
|
||||||
|
(src n i buf out)
|
||||||
|
(if
|
||||||
|
(>= i n)
|
||||||
|
(if (> (len buf) 0) (concat out (list buf)) out)
|
||||||
|
(let
|
||||||
|
((ch (char-at src i)))
|
||||||
|
(if
|
||||||
|
(forth-whitespace? ch)
|
||||||
|
(if
|
||||||
|
(> (len buf) 0)
|
||||||
|
(forth-tokens-loop src n (+ i 1) "" (concat out (list buf)))
|
||||||
|
(forth-tokens-loop src n (+ i 1) buf out))
|
||||||
|
(forth-tokens-loop src n (+ i 1) (str buf ch) out))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-tokens
|
||||||
|
(fn (src) (forth-tokens-loop src (len src) 0 "" (list))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-digit-value
|
||||||
|
(fn
|
||||||
|
(ch base)
|
||||||
|
(let
|
||||||
|
((code (char-code ch)) (cc (char-code (downcase ch))))
|
||||||
|
(let
|
||||||
|
((v (if (and (>= code 48) (<= code 57)) (- code 48) (if (and (>= cc 97) (<= cc 122)) (+ 10 (- cc 97)) -1))))
|
||||||
|
(if (and (>= v 0) (< v base)) v nil)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-parse-digits-loop
|
||||||
|
(fn
|
||||||
|
(src n i base acc)
|
||||||
|
(if
|
||||||
|
(>= i n)
|
||||||
|
acc
|
||||||
|
(let
|
||||||
|
((d (forth-digit-value (char-at src i) base)))
|
||||||
|
(if
|
||||||
|
(nil? d)
|
||||||
|
nil
|
||||||
|
(forth-parse-digits-loop src n (+ i 1) base (+ (* acc base) d)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-parse-digits
|
||||||
|
(fn
|
||||||
|
(src base)
|
||||||
|
(if
|
||||||
|
(= (len src) 0)
|
||||||
|
nil
|
||||||
|
(forth-parse-digits-loop src (len src) 0 base 0))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-strip-prefix
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(if
|
||||||
|
(<= (len s) 1)
|
||||||
|
(list s 0)
|
||||||
|
(let
|
||||||
|
((c (char-at s 0)))
|
||||||
|
(if
|
||||||
|
(= c "$")
|
||||||
|
(list (substring s 1 (len s)) 16)
|
||||||
|
(if
|
||||||
|
(= c "%")
|
||||||
|
(list (substring s 1 (len s)) 2)
|
||||||
|
(if (= c "#") (list (substring s 1 (len s)) 10) (list s 0))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-parse-number
|
||||||
|
(fn
|
||||||
|
(tok base)
|
||||||
|
(let
|
||||||
|
((n (len tok)))
|
||||||
|
(if
|
||||||
|
(= n 0)
|
||||||
|
nil
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(= n 3)
|
||||||
|
(and (= (char-at tok 0) "'") (= (char-at tok 2) "'")))
|
||||||
|
(char-code (char-at tok 1))
|
||||||
|
(let
|
||||||
|
((neg? (and (> n 1) (= (char-at tok 0) "-"))))
|
||||||
|
(let
|
||||||
|
((s1 (if neg? (substring tok 1 n) tok)))
|
||||||
|
(let
|
||||||
|
((pair (forth-strip-prefix s1)))
|
||||||
|
(let
|
||||||
|
((s (first pair)) (b-override (nth pair 1)))
|
||||||
|
(let
|
||||||
|
((b (if (= b-override 0) base b-override)))
|
||||||
|
(let
|
||||||
|
((v (forth-parse-digits s b)))
|
||||||
|
(if (nil? v) nil (if neg? (- 0 v) v)))))))))))))
|
||||||
433
lib/forth/runtime.sx
Normal file
433
lib/forth/runtime.sx
Normal file
@@ -0,0 +1,433 @@
|
|||||||
|
;; Forth runtime — state, stacks, dictionary, output buffer.
|
||||||
|
;; Data stack: mutable SX list, TOS = first.
|
||||||
|
;; Return stack: separate mutable list.
|
||||||
|
;; Dictionary: SX dict {lowercased-name -> word-record}.
|
||||||
|
;; Word record: {"kind" "body" "immediate?"}; kind is "primitive" or "colon-def".
|
||||||
|
;; Output buffer: mutable string appended to by `.`, `EMIT`, `CR`, etc.
|
||||||
|
;; Compile-mode flag: "compiling" on the state.
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-make-state
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((s (dict)))
|
||||||
|
(dict-set! s "dstack" (list))
|
||||||
|
(dict-set! s "rstack" (list))
|
||||||
|
(dict-set! s "dict" (dict))
|
||||||
|
(dict-set! s "output" "")
|
||||||
|
(dict-set! s "compiling" false)
|
||||||
|
(dict-set! s "current-def" nil)
|
||||||
|
(dict-set! s "base" 10)
|
||||||
|
(dict-set! s "vars" (dict))
|
||||||
|
s)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-error
|
||||||
|
(fn (state msg) (dict-set! state "error" msg) (raise msg)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-push
|
||||||
|
(fn (state v) (dict-set! state "dstack" (cons v (get state "dstack")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-pop
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((st (get state "dstack")))
|
||||||
|
(if
|
||||||
|
(= (len st) 0)
|
||||||
|
(forth-error state "stack underflow")
|
||||||
|
(let ((top (first st))) (dict-set! state "dstack" (rest st)) top)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-peek
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((st (get state "dstack")))
|
||||||
|
(if (= (len st) 0) (forth-error state "stack underflow") (first st)))))
|
||||||
|
|
||||||
|
(define forth-depth (fn (state) (len (get state "dstack"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-rpush
|
||||||
|
(fn (state v) (dict-set! state "rstack" (cons v (get state "rstack")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-rpop
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((st (get state "rstack")))
|
||||||
|
(if
|
||||||
|
(= (len st) 0)
|
||||||
|
(forth-error state "return stack underflow")
|
||||||
|
(let ((top (first st))) (dict-set! state "rstack" (rest st)) top)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-rpeek
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((st (get state "rstack")))
|
||||||
|
(if
|
||||||
|
(= (len st) 0)
|
||||||
|
(forth-error state "return stack underflow")
|
||||||
|
(first st)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-emit-str
|
||||||
|
(fn (state s) (dict-set! state "output" (str (get state "output") s))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-make-word
|
||||||
|
(fn
|
||||||
|
(kind body immediate?)
|
||||||
|
(let
|
||||||
|
((w (dict)))
|
||||||
|
(dict-set! w "kind" kind)
|
||||||
|
(dict-set! w "body" body)
|
||||||
|
(dict-set! w "immediate?" immediate?)
|
||||||
|
w)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-def-prim!
|
||||||
|
(fn
|
||||||
|
(state name body)
|
||||||
|
(dict-set!
|
||||||
|
(get state "dict")
|
||||||
|
(downcase name)
|
||||||
|
(forth-make-word "primitive" body false))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-def-prim-imm!
|
||||||
|
(fn
|
||||||
|
(state name body)
|
||||||
|
(dict-set!
|
||||||
|
(get state "dict")
|
||||||
|
(downcase name)
|
||||||
|
(forth-make-word "primitive" body true))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-lookup
|
||||||
|
(fn (state name) (get (get state "dict") (downcase name))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-binop
|
||||||
|
(fn
|
||||||
|
(op)
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((b (forth-pop state)) (a (forth-pop state)))
|
||||||
|
(forth-push state (op a b))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-unop
|
||||||
|
(fn
|
||||||
|
(op)
|
||||||
|
(fn (state) (let ((a (forth-pop state))) (forth-push state (op a))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-cmp
|
||||||
|
(fn
|
||||||
|
(op)
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let
|
||||||
|
((b (forth-pop state)) (a (forth-pop state)))
|
||||||
|
(forth-push state (if (op a b) -1 0))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-cmp0
|
||||||
|
(fn
|
||||||
|
(op)
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(let ((a (forth-pop state))) (forth-push state (if (op a) -1 0))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-trunc
|
||||||
|
(fn (x) (if (< x 0) (- 0 (floor (- 0 x))) (floor x))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-div
|
||||||
|
(fn
|
||||||
|
(a b)
|
||||||
|
(if (= b 0) (raise "division by zero") (forth-trunc (/ a b)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-mod
|
||||||
|
(fn
|
||||||
|
(a b)
|
||||||
|
(if (= b 0) (raise "division by zero") (- a (* b (forth-div a b))))))
|
||||||
|
|
||||||
|
(define forth-bits-width 32)
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-to-unsigned
|
||||||
|
(fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-from-unsigned
|
||||||
|
(fn
|
||||||
|
(n w)
|
||||||
|
(let ((half (pow 2 (- w 1)))) (if (>= n half) (- n (pow 2 w)) n))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-bitwise-step
|
||||||
|
(fn
|
||||||
|
(op ua ub out place i w)
|
||||||
|
(if
|
||||||
|
(>= i w)
|
||||||
|
out
|
||||||
|
(let
|
||||||
|
((da (mod ua 2)) (db (mod ub 2)))
|
||||||
|
(forth-bitwise-step
|
||||||
|
op
|
||||||
|
(floor (/ ua 2))
|
||||||
|
(floor (/ ub 2))
|
||||||
|
(+ out (* place (op da db)))
|
||||||
|
(* place 2)
|
||||||
|
(+ i 1)
|
||||||
|
w)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-bitwise-uu
|
||||||
|
(fn
|
||||||
|
(op)
|
||||||
|
(fn
|
||||||
|
(a b)
|
||||||
|
(let
|
||||||
|
((ua (forth-to-unsigned a forth-bits-width))
|
||||||
|
(ub (forth-to-unsigned b forth-bits-width)))
|
||||||
|
(forth-from-unsigned
|
||||||
|
(forth-bitwise-step op ua ub 0 1 0 forth-bits-width)
|
||||||
|
forth-bits-width)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-bit-and
|
||||||
|
(forth-bitwise-uu (fn (x y) (if (and (= x 1) (= y 1)) 1 0))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-bit-or
|
||||||
|
(forth-bitwise-uu (fn (x y) (if (or (= x 1) (= y 1)) 1 0))))
|
||||||
|
|
||||||
|
(define forth-bit-xor (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))
|
||||||
|
|
||||||
|
(define forth-bit-invert (fn (a) (- 0 (+ a 1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-install-primitives!
|
||||||
|
(fn
|
||||||
|
(state)
|
||||||
|
(forth-def-prim! state "DUP" (fn (s) (forth-push s (forth-peek s))))
|
||||||
|
(forth-def-prim! state "DROP" (fn (s) (forth-pop s)))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"SWAP"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s a))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"OVER"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s a))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"ROT"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s c)
|
||||||
|
(forth-push s a))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"-ROT"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s c)
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"NIP"
|
||||||
|
(fn (s) (let ((b (forth-pop s))) (forth-pop s) (forth-push s b))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"TUCK"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"?DUP"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let ((a (forth-peek s))) (when (not (= a 0)) (forth-push s a)))))
|
||||||
|
(forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"PICK"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((n (forth-pop s)) (st (get s "dstack")))
|
||||||
|
(if
|
||||||
|
(or (< n 0) (>= n (len st)))
|
||||||
|
(forth-error s "PICK out of range")
|
||||||
|
(forth-push s (nth st n))))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"ROLL"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((n (forth-pop s)) (st (get s "dstack")))
|
||||||
|
(if
|
||||||
|
(or (< n 0) (>= n (len st)))
|
||||||
|
(forth-error s "ROLL out of range")
|
||||||
|
(let
|
||||||
|
((taken (nth st n))
|
||||||
|
(before (take st n))
|
||||||
|
(after (drop st (+ n 1))))
|
||||||
|
(dict-set! s "dstack" (concat before after))
|
||||||
|
(forth-push s taken))))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"2DUP"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b))))
|
||||||
|
(forth-def-prim! state "2DROP" (fn (s) (forth-pop s) (forth-pop s)))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"2SWAP"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((d (forth-pop s))
|
||||||
|
(c (forth-pop s))
|
||||||
|
(b (forth-pop s))
|
||||||
|
(a (forth-pop s)))
|
||||||
|
(forth-push s c)
|
||||||
|
(forth-push s d)
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"2OVER"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((d (forth-pop s))
|
||||||
|
(c (forth-pop s))
|
||||||
|
(b (forth-pop s))
|
||||||
|
(a (forth-pop s)))
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b)
|
||||||
|
(forth-push s c)
|
||||||
|
(forth-push s d)
|
||||||
|
(forth-push s a)
|
||||||
|
(forth-push s b))))
|
||||||
|
(forth-def-prim! state "+" (forth-binop (fn (a b) (+ a b))))
|
||||||
|
(forth-def-prim! state "-" (forth-binop (fn (a b) (- a b))))
|
||||||
|
(forth-def-prim! state "*" (forth-binop (fn (a b) (* a b))))
|
||||||
|
(forth-def-prim! state "/" (forth-binop forth-div))
|
||||||
|
(forth-def-prim! state "MOD" (forth-binop forth-mod))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"/MOD"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((b (forth-pop s)) (a (forth-pop s)))
|
||||||
|
(forth-push s (forth-mod a b))
|
||||||
|
(forth-push s (forth-div a b)))))
|
||||||
|
(forth-def-prim! state "NEGATE" (forth-unop (fn (a) (- 0 a))))
|
||||||
|
(forth-def-prim! state "ABS" (forth-unop abs))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"MIN"
|
||||||
|
(forth-binop (fn (a b) (if (< a b) a b))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"MAX"
|
||||||
|
(forth-binop (fn (a b) (if (> a b) a b))))
|
||||||
|
(forth-def-prim! state "1+" (forth-unop (fn (a) (+ a 1))))
|
||||||
|
(forth-def-prim! state "1-" (forth-unop (fn (a) (- a 1))))
|
||||||
|
(forth-def-prim! state "2+" (forth-unop (fn (a) (+ a 2))))
|
||||||
|
(forth-def-prim! state "2-" (forth-unop (fn (a) (- a 2))))
|
||||||
|
(forth-def-prim! state "2*" (forth-unop (fn (a) (* a 2))))
|
||||||
|
(forth-def-prim! state "2/" (forth-unop (fn (a) (floor (/ a 2)))))
|
||||||
|
(forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b))))
|
||||||
|
(forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b)))))
|
||||||
|
(forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b))))
|
||||||
|
(forth-def-prim! state ">" (forth-cmp (fn (a b) (> a b))))
|
||||||
|
(forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b))))
|
||||||
|
(forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b))))
|
||||||
|
(forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0))))
|
||||||
|
(forth-def-prim! state "0<>" (forth-cmp0 (fn (a) (not (= a 0)))))
|
||||||
|
(forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0))))
|
||||||
|
(forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0))))
|
||||||
|
(forth-def-prim! state "AND" (forth-binop forth-bit-and))
|
||||||
|
(forth-def-prim! state "OR" (forth-binop forth-bit-or))
|
||||||
|
(forth-def-prim! state "XOR" (forth-binop forth-bit-xor))
|
||||||
|
(forth-def-prim! state "INVERT" (forth-unop forth-bit-invert))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"."
|
||||||
|
(fn (s) (forth-emit-str s (str (forth-pop s) " "))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
".S"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((st (reverse (get s "dstack"))))
|
||||||
|
(forth-emit-str s "<")
|
||||||
|
(forth-emit-str s (str (len st)))
|
||||||
|
(forth-emit-str s "> ")
|
||||||
|
(for-each (fn (v) (forth-emit-str s (str v " "))) st))))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"EMIT"
|
||||||
|
(fn (s) (forth-emit-str s (code-char (forth-pop s)))))
|
||||||
|
(forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n")))
|
||||||
|
(forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " ")))
|
||||||
|
(forth-def-prim!
|
||||||
|
state
|
||||||
|
"SPACES"
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((n (forth-pop s)))
|
||||||
|
(when
|
||||||
|
(> n 0)
|
||||||
|
(for-each (fn (_) (forth-emit-str s " ")) (range 0 n))))))
|
||||||
|
(forth-def-prim! state "BL" (fn (s) (forth-push s 32)))
|
||||||
|
state))
|
||||||
224
lib/forth/tests/test-phase1.sx
Normal file
224
lib/forth/tests/test-phase1.sx
Normal file
@@ -0,0 +1,224 @@
|
|||||||
|
;; Phase 1 — reader + interpret mode + core words.
|
||||||
|
;; Simple assertion driver: (forth-test label input expected-stack)
|
||||||
|
;; forth-run returns (state, output, stack-bottom-to-top).
|
||||||
|
|
||||||
|
(define forth-tests-passed 0)
|
||||||
|
(define forth-tests-failed 0)
|
||||||
|
(define forth-tests-failures (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-assert
|
||||||
|
(fn
|
||||||
|
(label expected actual)
|
||||||
|
(if
|
||||||
|
(= expected actual)
|
||||||
|
(set! forth-tests-passed (+ forth-tests-passed 1))
|
||||||
|
(begin
|
||||||
|
(set! forth-tests-failed (+ forth-tests-failed 1))
|
||||||
|
(set!
|
||||||
|
forth-tests-failures
|
||||||
|
(concat
|
||||||
|
forth-tests-failures
|
||||||
|
(list
|
||||||
|
(str label ": expected " (str expected) " got " (str actual)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-check-stack
|
||||||
|
(fn
|
||||||
|
(label src expected)
|
||||||
|
(let ((r (forth-run src))) (forth-assert label expected (nth r 2)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-check-output
|
||||||
|
(fn
|
||||||
|
(label src expected)
|
||||||
|
(let ((r (forth-run src))) (forth-assert label expected (nth r 1)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-reader-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-assert
|
||||||
|
"tokens split"
|
||||||
|
(list "1" "2" "+")
|
||||||
|
(forth-tokens " 1 2 + "))
|
||||||
|
(forth-assert "tokens empty" (list) (forth-tokens ""))
|
||||||
|
(forth-assert
|
||||||
|
"tokens tab/newline"
|
||||||
|
(list "a" "b" "c")
|
||||||
|
(forth-tokens "a\tb\nc"))
|
||||||
|
(forth-assert "number decimal" 42 (forth-parse-number "42" 10))
|
||||||
|
(forth-assert "number negative" -7 (forth-parse-number "-7" 10))
|
||||||
|
(forth-assert "number hex prefix" 255 (forth-parse-number "$ff" 10))
|
||||||
|
(forth-assert "number binary prefix" 10 (forth-parse-number "%1010" 10))
|
||||||
|
(forth-assert
|
||||||
|
"number decimal override under hex base"
|
||||||
|
123
|
||||||
|
(forth-parse-number "#123" 16))
|
||||||
|
(forth-assert "number none" nil (forth-parse-number "abc" 10))
|
||||||
|
(forth-assert "number in hex base" 255 (forth-parse-number "ff" 16))
|
||||||
|
(forth-assert
|
||||||
|
"number negative hex prefix"
|
||||||
|
-16
|
||||||
|
(forth-parse-number "-$10" 10))
|
||||||
|
(forth-assert "char literal" 65 (forth-parse-number "'A'" 10))
|
||||||
|
(forth-assert
|
||||||
|
"mixed-case digit in base 10"
|
||||||
|
nil
|
||||||
|
(forth-parse-number "1A" 10))
|
||||||
|
(forth-assert
|
||||||
|
"mixed-case digit in base 16"
|
||||||
|
26
|
||||||
|
(forth-parse-number "1a" 16))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-stack-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "push literal" "42" (list 42))
|
||||||
|
(forth-check-stack "push multiple" "1 2 3" (list 1 2 3))
|
||||||
|
(forth-check-stack "DUP" "7 DUP" (list 7 7))
|
||||||
|
(forth-check-stack "DROP" "1 2 DROP" (list 1))
|
||||||
|
(forth-check-stack "SWAP" "1 2 SWAP" (list 2 1))
|
||||||
|
(forth-check-stack "OVER" "1 2 OVER" (list 1 2 1))
|
||||||
|
(forth-check-stack "ROT" "1 2 3 ROT" (list 2 3 1))
|
||||||
|
(forth-check-stack "-ROT" "1 2 3 -ROT" (list 3 1 2))
|
||||||
|
(forth-check-stack "NIP" "1 2 NIP" (list 2))
|
||||||
|
(forth-check-stack "TUCK" "1 2 TUCK" (list 2 1 2))
|
||||||
|
(forth-check-stack "?DUP non-zero" "5 ?DUP" (list 5 5))
|
||||||
|
(forth-check-stack "?DUP zero" "0 ?DUP" (list 0))
|
||||||
|
(forth-check-stack "DEPTH empty" "DEPTH" (list 0))
|
||||||
|
(forth-check-stack "DEPTH non-empty" "1 2 3 DEPTH" (list 1 2 3 3))
|
||||||
|
(forth-check-stack "PICK 0" "10 20 30 0 PICK" (list 10 20 30 30))
|
||||||
|
(forth-check-stack "PICK 1" "10 20 30 1 PICK" (list 10 20 30 20))
|
||||||
|
(forth-check-stack "PICK 2" "10 20 30 2 PICK" (list 10 20 30 10))
|
||||||
|
(forth-check-stack "ROLL 0 is no-op" "10 20 30 0 ROLL" (list 10 20 30))
|
||||||
|
(forth-check-stack "ROLL 2" "10 20 30 2 ROLL" (list 20 30 10))
|
||||||
|
(forth-check-stack "2DUP" "1 2 2DUP" (list 1 2 1 2))
|
||||||
|
(forth-check-stack "2DROP" "1 2 3 4 2DROP" (list 1 2))
|
||||||
|
(forth-check-stack "2SWAP" "1 2 3 4 2SWAP" (list 3 4 1 2))
|
||||||
|
(forth-check-stack "2OVER" "1 2 3 4 2OVER" (list 1 2 3 4 1 2))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-arith-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "+" "3 4 +" (list 7))
|
||||||
|
(forth-check-stack "-" "10 3 -" (list 7))
|
||||||
|
(forth-check-stack "*" "6 7 *" (list 42))
|
||||||
|
(forth-check-stack "/ positive" "7 2 /" (list 3))
|
||||||
|
(forth-check-stack "/ negative numerator" "-7 2 /" (list -3))
|
||||||
|
(forth-check-stack "/ both negative" "-7 -2 /" (list 3))
|
||||||
|
(forth-check-stack "MOD positive" "7 3 MOD" (list 1))
|
||||||
|
(forth-check-stack "MOD negative" "-7 3 MOD" (list -1))
|
||||||
|
(forth-check-stack "/MOD positive" "7 3 /MOD" (list 1 2))
|
||||||
|
(forth-check-stack "NEGATE" "5 NEGATE" (list -5))
|
||||||
|
(forth-check-stack "ABS negative" "-5 ABS" (list 5))
|
||||||
|
(forth-check-stack "ABS positive" "5 ABS" (list 5))
|
||||||
|
(forth-check-stack "MIN a<b" "3 5 MIN" (list 3))
|
||||||
|
(forth-check-stack "MIN a>b" "5 3 MIN" (list 3))
|
||||||
|
(forth-check-stack "MAX a<b" "3 5 MAX" (list 5))
|
||||||
|
(forth-check-stack "MAX a>b" "5 3 MAX" (list 5))
|
||||||
|
(forth-check-stack "1+" "5 1+" (list 6))
|
||||||
|
(forth-check-stack "1-" "5 1-" (list 4))
|
||||||
|
(forth-check-stack "2+" "5 2+" (list 7))
|
||||||
|
(forth-check-stack "2-" "5 2-" (list 3))
|
||||||
|
(forth-check-stack "2*" "5 2*" (list 10))
|
||||||
|
(forth-check-stack "2/" "7 2/" (list 3))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-cmp-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "= true" "5 5 =" (list -1))
|
||||||
|
(forth-check-stack "= false" "5 6 =" (list 0))
|
||||||
|
(forth-check-stack "<> true" "5 6 <>" (list -1))
|
||||||
|
(forth-check-stack "<> false" "5 5 <>" (list 0))
|
||||||
|
(forth-check-stack "< true" "3 5 <" (list -1))
|
||||||
|
(forth-check-stack "< false" "5 3 <" (list 0))
|
||||||
|
(forth-check-stack "> true" "5 3 >" (list -1))
|
||||||
|
(forth-check-stack "> false" "3 5 >" (list 0))
|
||||||
|
(forth-check-stack "<= equal" "5 5 <=" (list -1))
|
||||||
|
(forth-check-stack "<= less" "3 5 <=" (list -1))
|
||||||
|
(forth-check-stack ">= equal" "5 5 >=" (list -1))
|
||||||
|
(forth-check-stack ">= greater" "5 3 >=" (list -1))
|
||||||
|
(forth-check-stack "0= true" "0 0=" (list -1))
|
||||||
|
(forth-check-stack "0= false" "1 0=" (list 0))
|
||||||
|
(forth-check-stack "0<> true" "1 0<>" (list -1))
|
||||||
|
(forth-check-stack "0<> false" "0 0<>" (list 0))
|
||||||
|
(forth-check-stack "0< true" "-5 0<" (list -1))
|
||||||
|
(forth-check-stack "0< false" "5 0<" (list 0))
|
||||||
|
(forth-check-stack "0> true" "5 0>" (list -1))
|
||||||
|
(forth-check-stack "0> false" "-5 0>" (list 0))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-bitwise-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "AND flags" "-1 0 AND" (list 0))
|
||||||
|
(forth-check-stack "AND flags 2" "-1 -1 AND" (list -1))
|
||||||
|
(forth-check-stack "AND 12 10" "12 10 AND" (list 8))
|
||||||
|
(forth-check-stack "OR flags" "-1 0 OR" (list -1))
|
||||||
|
(forth-check-stack "OR 12 10" "12 10 OR" (list 14))
|
||||||
|
(forth-check-stack "XOR 12 10" "12 10 XOR" (list 6))
|
||||||
|
(forth-check-stack "XOR same" "15 15 XOR" (list 0))
|
||||||
|
(forth-check-stack "INVERT 0" "0 INVERT" (list -1))
|
||||||
|
(forth-check-stack "INVERT 5" "5 INVERT" (list -6))
|
||||||
|
(forth-check-stack "double INVERT" "7 INVERT INVERT" (list 7))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-io-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-output "." "42 ." "42 ")
|
||||||
|
(forth-check-output ". two values" "1 2 . ." "2 1 ")
|
||||||
|
(forth-check-output ".S empty" ".S" "<0> ")
|
||||||
|
(forth-check-output ".S three" "1 2 3 .S" "<3> 1 2 3 ")
|
||||||
|
(forth-check-output "EMIT A" "65 EMIT" "A")
|
||||||
|
(forth-check-output "CR" "CR" "\n")
|
||||||
|
(forth-check-output "SPACE" "SPACE" " ")
|
||||||
|
(forth-check-output "SPACES 3" "3 SPACES" " ")
|
||||||
|
(forth-check-output "SPACES 0" "0 SPACES" "")
|
||||||
|
(forth-check-stack "BL" "BL" (list 32))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-case-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "case-insensitive DUP" "5 dup" (list 5 5))
|
||||||
|
(forth-check-stack "case-insensitive SWAP" "1 2 Swap" (list 2 1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-mixed-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-check-stack "chained arith" "1 2 3 + +" (list 6))
|
||||||
|
(forth-check-stack "(3+4)*2" "3 4 + 2 *" (list 14))
|
||||||
|
(forth-check-stack "max of three" "5 3 MAX 7 MAX" (list 7))
|
||||||
|
(forth-check-stack "abs chain" "-5 ABS 1+" (list 6))
|
||||||
|
(forth-check-stack "swap then add" "5 7 SWAP -" (list 2))
|
||||||
|
(forth-check-stack "hex literal" "$10 $20 +" (list 48))
|
||||||
|
(forth-check-stack "binary literal" "%1010 %0011 +" (list 13))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-run-all-phase1-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(set! forth-tests-passed 0)
|
||||||
|
(set! forth-tests-failed 0)
|
||||||
|
(set! forth-tests-failures (list))
|
||||||
|
(forth-reader-tests)
|
||||||
|
(forth-stack-tests)
|
||||||
|
(forth-arith-tests)
|
||||||
|
(forth-cmp-tests)
|
||||||
|
(forth-bitwise-tests)
|
||||||
|
(forth-io-tests)
|
||||||
|
(forth-case-tests)
|
||||||
|
(forth-mixed-tests)
|
||||||
|
(dict
|
||||||
|
"passed"
|
||||||
|
forth-tests-passed
|
||||||
|
"failed"
|
||||||
|
forth-tests-failed
|
||||||
|
"failures"
|
||||||
|
forth-tests-failures)))
|
||||||
146
lib/forth/tests/test-phase2.sx
Normal file
146
lib/forth/tests/test-phase2.sx
Normal file
@@ -0,0 +1,146 @@
|
|||||||
|
;; Phase 2 — colon definitions + compile mode + variables/values/fetch/store.
|
||||||
|
|
||||||
|
(define forth-p2-passed 0)
|
||||||
|
(define forth-p2-failed 0)
|
||||||
|
(define forth-p2-failures (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-assert
|
||||||
|
(fn
|
||||||
|
(label expected actual)
|
||||||
|
(if
|
||||||
|
(= expected actual)
|
||||||
|
(set! forth-p2-passed (+ forth-p2-passed 1))
|
||||||
|
(begin
|
||||||
|
(set! forth-p2-failed (+ forth-p2-failed 1))
|
||||||
|
(set!
|
||||||
|
forth-p2-failures
|
||||||
|
(concat
|
||||||
|
forth-p2-failures
|
||||||
|
(list
|
||||||
|
(str label ": expected " (str expected) " got " (str actual)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-check-stack
|
||||||
|
(fn
|
||||||
|
(label src expected)
|
||||||
|
(let ((r (forth-run src))) (forth-p2-assert label expected (nth r 2)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-check-output
|
||||||
|
(fn
|
||||||
|
(label src expected)
|
||||||
|
(let ((r (forth-run src))) (forth-p2-assert label expected (nth r 1)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-colon-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-stack "simple colon" ": DOUBLE 2 * ; 7 DOUBLE" (list 14))
|
||||||
|
(forth-p2-check-stack "three-op body" ": ADD3 + + ; 1 2 3 ADD3" (list 6))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"nested call"
|
||||||
|
": SQR DUP * ; : SOS SQR SWAP SQR + ; 3 4 SOS"
|
||||||
|
(list 25))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"deep chain"
|
||||||
|
": D 2 ; : B D ; : A B D * ; A"
|
||||||
|
(list 4))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"colon uses literal"
|
||||||
|
": FOO 1 2 + ; FOO FOO +"
|
||||||
|
(list 6))
|
||||||
|
(forth-p2-check-stack "case-insensitive def" ": BAR 9 ; bar" (list 9))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"redefinition picks newest"
|
||||||
|
": F 1 ; : F 2 ; F"
|
||||||
|
(list 2))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"negative literal in def"
|
||||||
|
": NEG5 -5 ; NEG5"
|
||||||
|
(list -5))
|
||||||
|
(forth-p2-check-stack "hex literal in def" ": X $10 ; X" (list 16))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-var-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-stack "VARIABLE + !, @" "VARIABLE X 42 X ! X @" (list 42))
|
||||||
|
(forth-p2-check-stack "uninitialised @ is 0" "VARIABLE Y Y @" (list 0))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"two variables"
|
||||||
|
"VARIABLE A VARIABLE B 1 A ! 2 B ! A @ B @ +"
|
||||||
|
(list 3))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"+! increments"
|
||||||
|
"VARIABLE X 10 X ! 5 X +! X @"
|
||||||
|
(list 15))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"+! multiple"
|
||||||
|
"VARIABLE X 0 X ! 1 X +! 2 X +! 3 X +! X @"
|
||||||
|
(list 6))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-const-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-stack "CONSTANT" "100 CONSTANT C C" (list 100))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"CONSTANT used twice"
|
||||||
|
"5 CONSTANT FIVE FIVE FIVE *"
|
||||||
|
(list 25))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"CONSTANT in colon"
|
||||||
|
"3 CONSTANT T : TRIPLE T * ; 7 TRIPLE"
|
||||||
|
(list 21))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-value-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-stack "VALUE initial" "50 VALUE V V" (list 50))
|
||||||
|
(forth-p2-check-stack "TO overwrites" "50 VALUE V 99 TO V V" (list 99))
|
||||||
|
(forth-p2-check-stack "TO twice" "1 VALUE V 2 TO V 3 TO V V" (list 3))
|
||||||
|
(forth-p2-check-stack "VALUE in arithmetic" "7 VALUE V V 3 +" (list 10))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-io-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-output
|
||||||
|
"colon prints"
|
||||||
|
": HELLO 72 EMIT 73 EMIT ; HELLO"
|
||||||
|
"HI")
|
||||||
|
(forth-p2-check-output "colon CR" ": LINE 42 . CR ; LINE" "42 \n")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-mode-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(forth-p2-check-stack "empty colon body" ": NOP ; 5 NOP" (list 5))
|
||||||
|
(forth-p2-check-stack
|
||||||
|
"colon using DUP"
|
||||||
|
": TWICE DUP ; 9 TWICE"
|
||||||
|
(list 9 9))
|
||||||
|
(forth-p2-check-stack "IMMEDIATE NOP" ": X ; X" (list))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
forth-p2-run-all
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(set! forth-p2-passed 0)
|
||||||
|
(set! forth-p2-failed 0)
|
||||||
|
(set! forth-p2-failures (list))
|
||||||
|
(forth-p2-colon-tests)
|
||||||
|
(forth-p2-var-tests)
|
||||||
|
(forth-p2-const-tests)
|
||||||
|
(forth-p2-value-tests)
|
||||||
|
(forth-p2-io-tests)
|
||||||
|
(forth-p2-mode-tests)
|
||||||
|
(dict
|
||||||
|
"passed"
|
||||||
|
forth-p2-passed
|
||||||
|
"failed"
|
||||||
|
forth-p2-failed
|
||||||
|
"failures"
|
||||||
|
forth-p2-failures)))
|
||||||
219
lib/graphql-exec.sx
Normal file
219
lib/graphql-exec.sx
Normal file
@@ -0,0 +1,219 @@
|
|||||||
|
|
||||||
|
;; GraphQL executor — walks parsed AST, dispatches via IO suspension
|
||||||
|
;;
|
||||||
|
;; Maps GraphQL operations to the defquery/defaction system:
|
||||||
|
;; query → (perform (list 'io-gql-resolve "gql-query" field-name args))
|
||||||
|
;; mutation → (perform (list 'io-gql-resolve "gql-mutation" field-name args))
|
||||||
|
;;
|
||||||
|
;; Field selection projects results to only requested fields.
|
||||||
|
;; Fragments are resolved by name lookup in the document.
|
||||||
|
;; Variables are substituted from a provided bindings dict.
|
||||||
|
;;
|
||||||
|
;; Usage:
|
||||||
|
;; (gql-execute (gql-parse "{ posts { title } }"))
|
||||||
|
;; (gql-execute (gql-parse "query($id: ID!) { post(id: $id) { title } }") {:id 42})
|
||||||
|
;; (gql-execute ast variables resolver) ;; custom resolver
|
||||||
|
|
||||||
|
;; ── Variable substitution ─────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-substitute-vars
|
||||||
|
(fn
|
||||||
|
(value vars)
|
||||||
|
"Recursively replace (gql-var name) nodes with values from vars dict."
|
||||||
|
(cond
|
||||||
|
((not (list? value)) value)
|
||||||
|
((= (first value) (quote gql-var))
|
||||||
|
(let
|
||||||
|
((name (nth value 1)))
|
||||||
|
(let
|
||||||
|
((kw (make-keyword name)))
|
||||||
|
(if
|
||||||
|
(has-key? vars kw)
|
||||||
|
(get vars kw)
|
||||||
|
(error (str "GraphQL: undefined variable $" name))))))
|
||||||
|
(true (map (fn (child) (gql-substitute-vars child vars)) value)))))
|
||||||
|
|
||||||
|
;; ── Fragment collection ───────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-collect-fragments
|
||||||
|
(fn
|
||||||
|
(doc)
|
||||||
|
"Build a dict of fragment-name → fragment-definition from a gql-doc."
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc def)
|
||||||
|
(if
|
||||||
|
(and (list? def) (= (first def) (quote gql-fragment)))
|
||||||
|
(assoc acc (make-keyword (nth def 1)) def)
|
||||||
|
acc))
|
||||||
|
{}
|
||||||
|
(rest doc))))
|
||||||
|
|
||||||
|
;; ── Field selection (projection) ──────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-project
|
||||||
|
(fn
|
||||||
|
(data selections fragments)
|
||||||
|
"Project a result dict/list down to only the requested fields."
|
||||||
|
(cond
|
||||||
|
((nil? data) nil)
|
||||||
|
((and (list? data) (not (dict? data)))
|
||||||
|
(map (fn (item) (gql-project item selections fragments)) data))
|
||||||
|
((dict? data)
|
||||||
|
(if
|
||||||
|
(= (length selections) 0)
|
||||||
|
data
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc sel)
|
||||||
|
(cond
|
||||||
|
((and (list? sel) (= (first sel) (quote gql-field)))
|
||||||
|
(let
|
||||||
|
((name (nth sel 1))
|
||||||
|
(sub-sels (nth sel 4))
|
||||||
|
(alias (if (> (length sel) 5) (nth sel 5) nil))
|
||||||
|
(out-key (make-keyword (if alias alias name))))
|
||||||
|
(let
|
||||||
|
((field-val (get data (make-keyword name))))
|
||||||
|
(if
|
||||||
|
(> (length sub-sels) 0)
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
out-key
|
||||||
|
(gql-project field-val sub-sels fragments))
|
||||||
|
(assoc acc out-key field-val)))))
|
||||||
|
((and (list? sel) (= (first sel) (quote gql-fragment-spread)))
|
||||||
|
(let
|
||||||
|
((frag-name (nth sel 1))
|
||||||
|
(frag (get fragments (make-keyword frag-name))))
|
||||||
|
(if
|
||||||
|
frag
|
||||||
|
(let
|
||||||
|
((frag-sels (nth frag 4)))
|
||||||
|
(let
|
||||||
|
((projected (gql-project data frag-sels fragments)))
|
||||||
|
(reduce
|
||||||
|
(fn (a k) (assoc a k (get projected k)))
|
||||||
|
acc
|
||||||
|
(keys projected))))
|
||||||
|
acc)))
|
||||||
|
((and (list? sel) (= (first sel) (quote gql-inline-fragment)))
|
||||||
|
(let
|
||||||
|
((sub-sels (nth sel 3)))
|
||||||
|
(let
|
||||||
|
((projected (gql-project data sub-sels fragments)))
|
||||||
|
(reduce
|
||||||
|
(fn (a k) (assoc a k (get projected k)))
|
||||||
|
acc
|
||||||
|
(keys projected)))))
|
||||||
|
(true acc)))
|
||||||
|
{}
|
||||||
|
selections)))
|
||||||
|
(true data))))
|
||||||
|
|
||||||
|
;; ── Default resolver ──────────────────────────────────────────────
|
||||||
|
;; Dispatches root fields via IO suspension to the query/action registry.
|
||||||
|
;; Platform provides io-gql-resolve handler.
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-default-resolve
|
||||||
|
(fn
|
||||||
|
(field-name args op-type)
|
||||||
|
"Default resolver: dispatches via perform to the platform's IO handler."
|
||||||
|
(perform (list (quote io-gql-resolve) op-type field-name args))))
|
||||||
|
|
||||||
|
;; ── Execute a single operation ────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-execute-operation
|
||||||
|
(fn
|
||||||
|
(op vars fragments resolve-fn)
|
||||||
|
"Execute one operation (query/mutation/subscription), return result dict."
|
||||||
|
(let
|
||||||
|
((op-type (first op))
|
||||||
|
(selections (nth op 4))
|
||||||
|
(substituted (gql-substitute-vars selections vars)))
|
||||||
|
(let
|
||||||
|
((result (reduce (fn (acc sel) (cond ((and (list? sel) (= (first sel) (quote gql-field))) (let ((name (nth sel 1)) (args-raw (nth sel 2)) (sub-sels (nth sel 4)) (alias (if (> (length sel) 5) (nth sel 5) nil)) (out-key (make-keyword (if alias alias name)))) (let ((args (map (fn (a) (list (first a) (gql-substitute-vars (nth a 1) vars))) args-raw))) (let ((args-dict (reduce (fn (d a) (assoc d (make-keyword (first a)) (nth a 1))) {} args))) (let ((raw (resolve-fn name args-dict op-type))) (if (> (length sub-sels) 0) (assoc acc out-key (gql-project raw sub-sels fragments)) (assoc acc out-key raw))))))) ((and (list? sel) (= (first sel) (quote gql-fragment-spread))) (let ((frag (get fragments (make-keyword (nth sel 1))))) (if frag (let ((merged (gql-execute-operation (list op-type nil (list) (list) (nth frag 4)) vars fragments resolve-fn))) (reduce (fn (a k) (assoc a k (get merged k))) acc (keys merged))) acc))) (true acc))) {} substituted)))
|
||||||
|
result))))
|
||||||
|
|
||||||
|
;; ── Main entry point ──────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-execute
|
||||||
|
(fn
|
||||||
|
(doc &rest extra-args)
|
||||||
|
"Execute a parsed GraphQL document.\n (gql-execute doc)\n (gql-execute doc variables)\n (gql-execute doc variables resolver-fn)\n Returns {:data result} or {:data result :errors errors}."
|
||||||
|
(let
|
||||||
|
((vars (if (> (length extra-args) 0) (first extra-args) {}))
|
||||||
|
(resolve-fn
|
||||||
|
(if
|
||||||
|
(> (length extra-args) 1)
|
||||||
|
(nth extra-args 1)
|
||||||
|
gql-default-resolve))
|
||||||
|
(fragments (gql-collect-fragments doc))
|
||||||
|
(definitions (rest doc)))
|
||||||
|
(let
|
||||||
|
((ops (filter (fn (d) (and (list? d) (let ((t (first d))) (or (= t (quote gql-query)) (= t (quote gql-mutation)) (= t (quote gql-subscription)))))) definitions)))
|
||||||
|
(if
|
||||||
|
(= (length ops) 0)
|
||||||
|
{:errors (list "No operation found in document") :data nil}
|
||||||
|
(let
|
||||||
|
((result (gql-execute-operation (first ops) vars fragments resolve-fn)))
|
||||||
|
{:data result}))))))
|
||||||
|
|
||||||
|
;; ── Execute with named operation ──────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-execute-named
|
||||||
|
(fn
|
||||||
|
(doc operation-name vars &rest extra-args)
|
||||||
|
"Execute a specific named operation from a multi-operation document."
|
||||||
|
(let
|
||||||
|
((resolve-fn (if (> (length extra-args) 0) (first extra-args) gql-default-resolve))
|
||||||
|
(fragments (gql-collect-fragments doc))
|
||||||
|
(definitions (rest doc)))
|
||||||
|
(let
|
||||||
|
((op (first (filter (fn (d) (and (list? d) (> (length d) 1) (= (nth d 1) operation-name))) definitions))))
|
||||||
|
(if
|
||||||
|
(nil? op)
|
||||||
|
{:errors (list (str "Operation '" operation-name "' not found")) :data nil}
|
||||||
|
(let
|
||||||
|
((result (gql-execute-operation op vars fragments resolve-fn)))
|
||||||
|
{:data result}))))))
|
||||||
|
|
||||||
|
;; ── Introspection helpers ─────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-operation-names
|
||||||
|
(fn
|
||||||
|
(doc)
|
||||||
|
"List all operation names in a document."
|
||||||
|
(filter
|
||||||
|
(fn (x) (not (nil? x)))
|
||||||
|
(map
|
||||||
|
(fn (d) (if (and (list? d) (> (length d) 1)) (nth d 1) nil))
|
||||||
|
(filter
|
||||||
|
(fn
|
||||||
|
(d)
|
||||||
|
(and
|
||||||
|
(list? d)
|
||||||
|
(let
|
||||||
|
((t (first d)))
|
||||||
|
(or
|
||||||
|
(= t (quote gql-query))
|
||||||
|
(= t (quote gql-mutation))
|
||||||
|
(= t (quote gql-subscription))))))
|
||||||
|
(rest doc))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-extract-variables
|
||||||
|
(fn
|
||||||
|
(doc)
|
||||||
|
"Extract variable definitions from the first operation."
|
||||||
|
(let
|
||||||
|
((ops (filter (fn (d) (and (list? d) (let ((t (first d))) (or (= t (quote gql-query)) (= t (quote gql-mutation)) (= t (quote gql-subscription)))))) (rest doc))))
|
||||||
|
(if (> (length ops) 0) (nth (first ops) 2) (list)))))
|
||||||
686
lib/graphql.sx
Normal file
686
lib/graphql.sx
Normal file
@@ -0,0 +1,686 @@
|
|||||||
|
|
||||||
|
;; GraphQL parser — tokenizer + recursive descent → SX AST
|
||||||
|
;;
|
||||||
|
;; Parses the GraphQL query language (queries, mutations, subscriptions,
|
||||||
|
;; fragments, variables, directives) into s-expression AST.
|
||||||
|
;;
|
||||||
|
;; Usage:
|
||||||
|
;; (gql-parse "{ user(id: 1) { name email } }")
|
||||||
|
;;
|
||||||
|
;; AST node types:
|
||||||
|
;; (gql-doc definitions...)
|
||||||
|
;; (gql-query name vars directives selections)
|
||||||
|
;; (gql-mutation name vars directives selections)
|
||||||
|
;; (gql-subscription name vars directives selections)
|
||||||
|
;; (gql-field name args directives selections [alias])
|
||||||
|
;; (gql-fragment name on-type directives selections)
|
||||||
|
;; (gql-fragment-spread name directives)
|
||||||
|
;; (gql-inline-fragment on-type directives selections)
|
||||||
|
;; (gql-var name) — $variableName reference
|
||||||
|
;; (gql-var-def name type default) — variable definition
|
||||||
|
;; (gql-type name) — named type
|
||||||
|
;; (gql-list-type inner) — [Type]
|
||||||
|
;; (gql-non-null inner) — Type!
|
||||||
|
;; (gql-directive name args) — @directive(args)
|
||||||
|
|
||||||
|
;; ── Character helpers (shared) ────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-ws?
|
||||||
|
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r") (= c ","))))
|
||||||
|
(define gql-digit? (fn (c) (and c (>= c "0") (<= c "9"))))
|
||||||
|
(define
|
||||||
|
gql-letter?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(and c (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||||
|
(define gql-name-start? (fn (c) (or (gql-letter? c) (= c "_"))))
|
||||||
|
(define gql-name-char? (fn (c) (or (gql-name-start? c) (gql-digit? c))))
|
||||||
|
|
||||||
|
;; ── Tokenizer ─────────────────────────────────────────────────────
|
||||||
|
;; Returns {:tokens list :pos int} — state-passing style to avoid
|
||||||
|
;; multiple define closures over the same mutable variable.
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-char-at
|
||||||
|
(fn (src len i) (if (< i len) (substring src i (+ i 1)) nil)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-skip-ws
|
||||||
|
(fn
|
||||||
|
(src len pos)
|
||||||
|
"Skip whitespace, commas, and # comments. Returns new pos."
|
||||||
|
(if
|
||||||
|
(>= pos len)
|
||||||
|
pos
|
||||||
|
(let
|
||||||
|
((c (gql-char-at src len pos)))
|
||||||
|
(cond
|
||||||
|
((gql-ws? c) (gql-skip-ws src len (+ pos 1)))
|
||||||
|
((= c "#")
|
||||||
|
(let
|
||||||
|
((eol-pos (gql-skip-to-eol src len (+ pos 1))))
|
||||||
|
(gql-skip-ws src len eol-pos)))
|
||||||
|
(true pos))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-skip-to-eol
|
||||||
|
(fn
|
||||||
|
(src len pos)
|
||||||
|
(if
|
||||||
|
(>= pos len)
|
||||||
|
pos
|
||||||
|
(if
|
||||||
|
(= (gql-char-at src len pos) "\n")
|
||||||
|
pos
|
||||||
|
(gql-skip-to-eol src len (+ pos 1))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-read-name
|
||||||
|
(fn
|
||||||
|
(src len pos)
|
||||||
|
"Read [_A-Za-z][_A-Za-z0-9]*. Returns {:value name :pos new-pos}."
|
||||||
|
(let
|
||||||
|
((start pos))
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
(p)
|
||||||
|
(if
|
||||||
|
(and (< p len) (gql-name-char? (gql-char-at src len p)))
|
||||||
|
(loop (+ p 1))
|
||||||
|
{:pos p :value (substring src start p)})))
|
||||||
|
(loop pos))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-read-number
|
||||||
|
(fn
|
||||||
|
(src len pos)
|
||||||
|
"Read number. Returns {:value num :pos new-pos}."
|
||||||
|
(let
|
||||||
|
((start pos) (p pos))
|
||||||
|
(when (= (gql-char-at src len p) "-") (set! p (+ p 1)))
|
||||||
|
(define
|
||||||
|
dloop
|
||||||
|
(fn
|
||||||
|
(p has-dot)
|
||||||
|
(if
|
||||||
|
(>= p len)
|
||||||
|
{:pos p :value (parse-number (substring src start p))}
|
||||||
|
(let
|
||||||
|
((c (gql-char-at src len p)))
|
||||||
|
(cond
|
||||||
|
((gql-digit? c) (dloop (+ p 1) has-dot))
|
||||||
|
((and (= c ".") (not has-dot)) (dloop (+ p 1) true))
|
||||||
|
((or (= c "e") (= c "E"))
|
||||||
|
(let
|
||||||
|
((p2 (+ p 1)))
|
||||||
|
(when
|
||||||
|
(or
|
||||||
|
(= (gql-char-at src len p2) "+")
|
||||||
|
(= (gql-char-at src len p2) "-"))
|
||||||
|
(set! p2 (+ p2 1)))
|
||||||
|
(dloop p2 has-dot)))
|
||||||
|
(true {:pos p :value (parse-number (substring src start p))}))))))
|
||||||
|
(dloop p false))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-read-string
|
||||||
|
(fn
|
||||||
|
(src len pos)
|
||||||
|
"Read double-quoted string. pos is ON the opening quote. Returns {:value str :pos new-pos}."
|
||||||
|
(let
|
||||||
|
((p (+ pos 1)))
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(< (+ p 1) len)
|
||||||
|
(= (gql-char-at src len p) "\"")
|
||||||
|
(= (gql-char-at src len (+ p 1)) "\""))
|
||||||
|
(let
|
||||||
|
((p2 (+ p 2)))
|
||||||
|
(define
|
||||||
|
bloop
|
||||||
|
(fn
|
||||||
|
(bp)
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(< (+ bp 2) len)
|
||||||
|
(= (gql-char-at src len bp) "\"")
|
||||||
|
(= (gql-char-at src len (+ bp 1)) "\"")
|
||||||
|
(= (gql-char-at src len (+ bp 2)) "\""))
|
||||||
|
{:pos (+ bp 3) :value (substring src p2 bp)}
|
||||||
|
(bloop (+ bp 1)))))
|
||||||
|
(bloop p2))
|
||||||
|
(do
|
||||||
|
(define
|
||||||
|
sloop
|
||||||
|
(fn
|
||||||
|
(sp parts)
|
||||||
|
(if
|
||||||
|
(>= sp len)
|
||||||
|
{:pos sp :value (join "" parts)}
|
||||||
|
(let
|
||||||
|
((c (gql-char-at src len sp)))
|
||||||
|
(cond
|
||||||
|
((= c "\"") {:pos (+ sp 1) :value (join "" parts)})
|
||||||
|
((= c "\\")
|
||||||
|
(let
|
||||||
|
((esc (gql-char-at src len (+ sp 1)))
|
||||||
|
(sp2 (+ sp 2)))
|
||||||
|
(sloop
|
||||||
|
sp2
|
||||||
|
(append
|
||||||
|
parts
|
||||||
|
(list
|
||||||
|
(cond
|
||||||
|
((= esc "n") "\n")
|
||||||
|
((= esc "t") "\t")
|
||||||
|
((= esc "r") "\r")
|
||||||
|
((= esc "\\") "\\")
|
||||||
|
((= esc "\"") "\"")
|
||||||
|
((= esc "/") "/")
|
||||||
|
(true (str "\\" esc))))))))
|
||||||
|
(true (sloop (+ sp 1) (append parts (list c)))))))))
|
||||||
|
(sloop p (list)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-tokenize
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((len (string-length src)))
|
||||||
|
(define
|
||||||
|
tok-loop
|
||||||
|
(fn
|
||||||
|
(pos acc)
|
||||||
|
(let
|
||||||
|
((pos (gql-skip-ws src len pos)))
|
||||||
|
(if
|
||||||
|
(>= pos len)
|
||||||
|
(append acc (list {:pos pos :value nil :type "eof"}))
|
||||||
|
(let
|
||||||
|
((c (gql-char-at src len pos)))
|
||||||
|
(cond
|
||||||
|
((= c "{")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "{" :type "brace-open"}))))
|
||||||
|
((= c "}")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "}" :type "brace-close"}))))
|
||||||
|
((= c "(")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "(" :type "paren-open"}))))
|
||||||
|
((= c ")")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value ")" :type "paren-close"}))))
|
||||||
|
((= c "[")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "[" :type "bracket-open"}))))
|
||||||
|
((= c "]")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "]" :type "bracket-close"}))))
|
||||||
|
((= c ":")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value ":" :type "colon"}))))
|
||||||
|
((= c "!")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "!" :type "bang"}))))
|
||||||
|
((= c "$")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "$" :type "dollar"}))))
|
||||||
|
((= c "@")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "@" :type "at"}))))
|
||||||
|
((= c "=")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "=" :type "equals"}))))
|
||||||
|
((= c "|")
|
||||||
|
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "|" :type "pipe"}))))
|
||||||
|
((and (= c ".") (< (+ pos 2) len) (= (gql-char-at src len (+ pos 1)) ".") (= (gql-char-at src len (+ pos 2)) "."))
|
||||||
|
(tok-loop (+ pos 3) (append acc (list {:pos pos :value "..." :type "spread"}))))
|
||||||
|
((= c "\"")
|
||||||
|
(let
|
||||||
|
((r (gql-read-string src len pos)))
|
||||||
|
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "string"})))))
|
||||||
|
((or (gql-digit? c) (and (= c "-") (< (+ pos 1) len) (gql-digit? (gql-char-at src len (+ pos 1)))))
|
||||||
|
(let
|
||||||
|
((r (gql-read-number src len pos)))
|
||||||
|
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "number"})))))
|
||||||
|
((gql-name-start? c)
|
||||||
|
(let
|
||||||
|
((r (gql-read-name src len pos)))
|
||||||
|
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "name"})))))
|
||||||
|
(true (tok-loop (+ pos 1) acc))))))))
|
||||||
|
(tok-loop 0 (list)))))
|
||||||
|
|
||||||
|
;; ── Parser ────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-parse-tokens
|
||||||
|
(fn
|
||||||
|
(tokens)
|
||||||
|
(let
|
||||||
|
((p 0) (tlen (length tokens)))
|
||||||
|
(define cur (fn () (if (< p tlen) (nth tokens p) {:value nil :type "eof"})))
|
||||||
|
(define cur-type (fn () (get (cur) :type)))
|
||||||
|
(define cur-val (fn () (get (cur) :value)))
|
||||||
|
(define adv! (fn () (set! p (+ p 1))))
|
||||||
|
(define at-end? (fn () (= (cur-type) "eof")))
|
||||||
|
(define
|
||||||
|
expect!
|
||||||
|
(fn
|
||||||
|
(type)
|
||||||
|
(if
|
||||||
|
(= (cur-type) type)
|
||||||
|
(let ((v (cur-val))) (adv!) v)
|
||||||
|
(error
|
||||||
|
(str "GraphQL parse error: expected " type " got " (cur-type))))))
|
||||||
|
(define expect-name! (fn () (expect! "name")))
|
||||||
|
(define
|
||||||
|
parse-value
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((typ (cur-type)) (val (cur-val)))
|
||||||
|
(cond
|
||||||
|
((= typ "dollar")
|
||||||
|
(do (adv!) (list (quote gql-var) (expect-name!))))
|
||||||
|
((= typ "number") (do (adv!) val))
|
||||||
|
((= typ "string") (do (adv!) val))
|
||||||
|
((and (= typ "name") (= val "true")) (do (adv!) true))
|
||||||
|
((and (= typ "name") (= val "false")) (do (adv!) false))
|
||||||
|
((and (= typ "name") (= val "null")) (do (adv!) nil))
|
||||||
|
((= typ "bracket-open") (parse-list-value))
|
||||||
|
((= typ "brace-open") (parse-object-value))
|
||||||
|
((= typ "name") (do (adv!) val))
|
||||||
|
(true
|
||||||
|
(error
|
||||||
|
(str "GraphQL parse error: unexpected " typ " in value")))))))
|
||||||
|
(define
|
||||||
|
parse-list-value
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(do
|
||||||
|
(expect! "bracket-open")
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(or (at-end?) (= (cur-type) "bracket-close"))
|
||||||
|
(do (expect! "bracket-close") acc)
|
||||||
|
(collect (append acc (list (parse-value)))))))
|
||||||
|
(collect (list)))))
|
||||||
|
(define
|
||||||
|
parse-object-value
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(do
|
||||||
|
(expect! "brace-open")
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(or (at-end?) (= (cur-type) "brace-close"))
|
||||||
|
(do (expect! "brace-close") acc)
|
||||||
|
(let
|
||||||
|
((k (expect-name!)))
|
||||||
|
(expect! "colon")
|
||||||
|
(let
|
||||||
|
((v (parse-value)))
|
||||||
|
(collect (assoc acc (make-keyword k) v)))))))
|
||||||
|
(collect {}))))
|
||||||
|
(define
|
||||||
|
parse-arguments
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(if
|
||||||
|
(not (= (cur-type) "paren-open"))
|
||||||
|
(list)
|
||||||
|
(do
|
||||||
|
(adv!)
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(or (at-end?) (= (cur-type) "paren-close"))
|
||||||
|
(do (adv!) acc)
|
||||||
|
(let
|
||||||
|
((name (expect-name!)))
|
||||||
|
(expect! "colon")
|
||||||
|
(let
|
||||||
|
((val (parse-value)))
|
||||||
|
(collect (append acc (list (list name val)))))))))
|
||||||
|
(collect (list))))))
|
||||||
|
(define
|
||||||
|
parse-directives
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(and (= (cur-type) "at") (not (at-end?)))
|
||||||
|
(do
|
||||||
|
(adv!)
|
||||||
|
(let
|
||||||
|
((name (expect-name!)) (args (parse-arguments)))
|
||||||
|
(collect
|
||||||
|
(append
|
||||||
|
acc
|
||||||
|
(list (list (quote gql-directive) name args))))))
|
||||||
|
acc)))
|
||||||
|
(collect (list))))
|
||||||
|
(define
|
||||||
|
parse-type
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((base (cond ((= (cur-type) "bracket-open") (do (adv!) (let ((inner (parse-type))) (expect! "bracket-close") (list (quote gql-list-type) inner)))) (true (list (quote gql-type) (expect-name!))))))
|
||||||
|
(if
|
||||||
|
(= (cur-type) "bang")
|
||||||
|
(do (adv!) (list (quote gql-non-null) base))
|
||||||
|
base))))
|
||||||
|
(define
|
||||||
|
parse-variable-defs
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(if
|
||||||
|
(not (= (cur-type) "paren-open"))
|
||||||
|
(list)
|
||||||
|
(do
|
||||||
|
(adv!)
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(or (at-end?) (= (cur-type) "paren-close"))
|
||||||
|
(do (adv!) acc)
|
||||||
|
(do
|
||||||
|
(expect! "dollar")
|
||||||
|
(let
|
||||||
|
((name (expect-name!)))
|
||||||
|
(expect! "colon")
|
||||||
|
(let
|
||||||
|
((typ (parse-type))
|
||||||
|
(default
|
||||||
|
(if
|
||||||
|
(= (cur-type) "equals")
|
||||||
|
(do (adv!) (parse-value))
|
||||||
|
nil)))
|
||||||
|
(collect
|
||||||
|
(append
|
||||||
|
acc
|
||||||
|
(list
|
||||||
|
(list (quote gql-var-def) name typ default))))))))))
|
||||||
|
(collect (list))))))
|
||||||
|
(define
|
||||||
|
parse-selection-set
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(if
|
||||||
|
(not (= (cur-type) "brace-open"))
|
||||||
|
(list)
|
||||||
|
(do
|
||||||
|
(adv!)
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(or (at-end?) (= (cur-type) "brace-close"))
|
||||||
|
(do (adv!) acc)
|
||||||
|
(collect (append acc (list (parse-selection)))))))
|
||||||
|
(collect (list))))))
|
||||||
|
(define
|
||||||
|
parse-selection
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((= (cur-type) "spread")
|
||||||
|
(do
|
||||||
|
(adv!)
|
||||||
|
(if
|
||||||
|
(and (= (cur-type) "name") (not (= (cur-val) "on")))
|
||||||
|
(let
|
||||||
|
((name (expect-name!)) (dirs (parse-directives)))
|
||||||
|
(list (quote gql-fragment-spread) name dirs))
|
||||||
|
(let
|
||||||
|
((on-type (if (and (= (cur-type) "name") (= (cur-val) "on")) (do (adv!) (expect-name!)) nil))
|
||||||
|
(dirs (parse-directives))
|
||||||
|
(sels (parse-selection-set)))
|
||||||
|
(list (quote gql-inline-fragment) on-type dirs sels)))))
|
||||||
|
(true (parse-field)))))
|
||||||
|
(define
|
||||||
|
parse-field
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((name1 (expect-name!)))
|
||||||
|
(let
|
||||||
|
((actual-name (if (= (cur-type) "colon") (do (adv!) (expect-name!)) nil))
|
||||||
|
(alias (if actual-name name1 nil))
|
||||||
|
(field-name (if actual-name actual-name name1)))
|
||||||
|
(let
|
||||||
|
((args (parse-arguments))
|
||||||
|
(dirs (parse-directives))
|
||||||
|
(sels (parse-selection-set)))
|
||||||
|
(if
|
||||||
|
alias
|
||||||
|
(list (quote gql-field) field-name args dirs sels alias)
|
||||||
|
(list (quote gql-field) field-name args dirs sels)))))))
|
||||||
|
(define
|
||||||
|
parse-operation
|
||||||
|
(fn
|
||||||
|
(op-type)
|
||||||
|
(let
|
||||||
|
((name (if (and (= (cur-type) "name") (not (= (cur-val) "query")) (not (= (cur-val) "mutation")) (not (= (cur-val) "subscription")) (not (= (cur-val) "fragment"))) (expect-name!) nil))
|
||||||
|
(vars (parse-variable-defs))
|
||||||
|
(dirs (parse-directives))
|
||||||
|
(sels (parse-selection-set)))
|
||||||
|
(list op-type name vars dirs sels))))
|
||||||
|
(define
|
||||||
|
parse-fragment-def
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((name (expect-name!)))
|
||||||
|
(when (and (= (cur-type) "name") (= (cur-val) "on")) (adv!))
|
||||||
|
(let
|
||||||
|
((on-type (expect-name!))
|
||||||
|
(dirs (parse-directives))
|
||||||
|
(sels (parse-selection-set)))
|
||||||
|
(list (quote gql-fragment) name on-type dirs sels)))))
|
||||||
|
(define
|
||||||
|
parse-definition
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((typ (cur-type)) (val (cur-val)))
|
||||||
|
(cond
|
||||||
|
((= typ "brace-open")
|
||||||
|
(let
|
||||||
|
((sels (parse-selection-set)))
|
||||||
|
(list (quote gql-query) nil (list) (list) sels)))
|
||||||
|
((and (= typ "name") (= val "query"))
|
||||||
|
(do (adv!) (parse-operation (quote gql-query))))
|
||||||
|
((and (= typ "name") (= val "mutation"))
|
||||||
|
(do (adv!) (parse-operation (quote gql-mutation))))
|
||||||
|
((and (= typ "name") (= val "subscription"))
|
||||||
|
(do (adv!) (parse-operation (quote gql-subscription))))
|
||||||
|
((and (= typ "name") (= val "fragment"))
|
||||||
|
(do (adv!) (parse-fragment-def)))
|
||||||
|
(true
|
||||||
|
(error
|
||||||
|
(str
|
||||||
|
"GraphQL parse error: unexpected "
|
||||||
|
typ
|
||||||
|
" "
|
||||||
|
(if val val ""))))))))
|
||||||
|
(define
|
||||||
|
parse-document
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(define
|
||||||
|
collect
|
||||||
|
(fn
|
||||||
|
(acc)
|
||||||
|
(if
|
||||||
|
(at-end?)
|
||||||
|
(cons (quote gql-doc) acc)
|
||||||
|
(collect (append acc (list (parse-definition)))))))
|
||||||
|
(collect (list))))
|
||||||
|
(parse-document))))
|
||||||
|
|
||||||
|
;; ── Convenience: source → AST ─────────────────────────────────────
|
||||||
|
|
||||||
|
(define gql-parse (fn (source) (gql-parse-tokens (gql-tokenize source))))
|
||||||
|
|
||||||
|
;; ── AST accessors ─────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define gql-node-type (fn (node) (if (list? node) (first node) nil)))
|
||||||
|
(define gql-doc? (fn (node) (= (gql-node-type node) (quote gql-doc))))
|
||||||
|
(define gql-query? (fn (node) (= (gql-node-type node) (quote gql-query))))
|
||||||
|
(define
|
||||||
|
gql-mutation?
|
||||||
|
(fn (node) (= (gql-node-type node) (quote gql-mutation))))
|
||||||
|
(define
|
||||||
|
gql-subscription?
|
||||||
|
(fn (node) (= (gql-node-type node) (quote gql-subscription))))
|
||||||
|
(define gql-field? (fn (node) (= (gql-node-type node) (quote gql-field))))
|
||||||
|
(define
|
||||||
|
gql-fragment?
|
||||||
|
(fn (node) (= (gql-node-type node) (quote gql-fragment))))
|
||||||
|
(define
|
||||||
|
gql-fragment-spread?
|
||||||
|
(fn (node) (= (gql-node-type node) (quote gql-fragment-spread))))
|
||||||
|
(define gql-var? (fn (node) (= (gql-node-type node) (quote gql-var))))
|
||||||
|
|
||||||
|
;; Field accessors: (gql-field name args directives selections [alias])
|
||||||
|
(define gql-field-name (fn (f) (nth f 1)))
|
||||||
|
(define gql-field-args (fn (f) (nth f 2)))
|
||||||
|
(define gql-field-directives (fn (f) (nth f 3)))
|
||||||
|
(define gql-field-selections (fn (f) (nth f 4)))
|
||||||
|
(define gql-field-alias (fn (f) (if (> (length f) 5) (nth f 5) nil)))
|
||||||
|
|
||||||
|
;; Operation accessors: (gql-query/mutation/subscription name vars directives selections)
|
||||||
|
(define gql-op-name (fn (op) (nth op 1)))
|
||||||
|
(define gql-op-vars (fn (op) (nth op 2)))
|
||||||
|
(define gql-op-directives (fn (op) (nth op 3)))
|
||||||
|
(define gql-op-selections (fn (op) (nth op 4)))
|
||||||
|
|
||||||
|
;; Fragment accessors: (gql-fragment name on-type directives selections)
|
||||||
|
(define gql-frag-name (fn (f) (nth f 1)))
|
||||||
|
(define gql-frag-type (fn (f) (nth f 2)))
|
||||||
|
(define gql-frag-directives (fn (f) (nth f 3)))
|
||||||
|
(define gql-frag-selections (fn (f) (nth f 4)))
|
||||||
|
|
||||||
|
;; Document: (gql-doc def1 def2 ...)
|
||||||
|
(define gql-doc-definitions (fn (doc) (rest doc)))
|
||||||
|
|
||||||
|
;; ── Serializer: AST → GraphQL source ─────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
serialize-selection-set
|
||||||
|
(fn (sels) (str "{ " (join " " (map gql-serialize sels)) " }")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
serialize-args
|
||||||
|
(fn
|
||||||
|
(args)
|
||||||
|
(str
|
||||||
|
"("
|
||||||
|
(join
|
||||||
|
", "
|
||||||
|
(map
|
||||||
|
(fn (a) (str (first a) ": " (gql-serialize (nth a 1))))
|
||||||
|
args))
|
||||||
|
")")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
serialize-var-defs
|
||||||
|
(fn
|
||||||
|
(vars)
|
||||||
|
(str
|
||||||
|
"("
|
||||||
|
(join
|
||||||
|
", "
|
||||||
|
(map
|
||||||
|
(fn
|
||||||
|
(v)
|
||||||
|
(let
|
||||||
|
((name (nth v 1))
|
||||||
|
(typ (serialize-type (nth v 2)))
|
||||||
|
(default (nth v 3)))
|
||||||
|
(str
|
||||||
|
"$"
|
||||||
|
name
|
||||||
|
": "
|
||||||
|
typ
|
||||||
|
(if default (str " = " (gql-serialize default)) ""))))
|
||||||
|
vars))
|
||||||
|
")")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
serialize-type
|
||||||
|
(fn
|
||||||
|
(t)
|
||||||
|
(let
|
||||||
|
((typ (first t)))
|
||||||
|
(cond
|
||||||
|
((= typ (quote gql-type)) (nth t 1))
|
||||||
|
((= typ (quote gql-list-type))
|
||||||
|
(str "[" (serialize-type (nth t 1)) "]"))
|
||||||
|
((= typ (quote gql-non-null))
|
||||||
|
(str (serialize-type (nth t 1)) "!"))
|
||||||
|
(true "Unknown")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gql-serialize
|
||||||
|
(fn
|
||||||
|
(node)
|
||||||
|
(cond
|
||||||
|
((not (list? node))
|
||||||
|
(cond
|
||||||
|
((string? node) (str "\"" node "\""))
|
||||||
|
((number? node) (str node))
|
||||||
|
((= node true) "true")
|
||||||
|
((= node false) "false")
|
||||||
|
((nil? node) "null")
|
||||||
|
(true (str node))))
|
||||||
|
(true
|
||||||
|
(let
|
||||||
|
((typ (gql-node-type node)))
|
||||||
|
(cond
|
||||||
|
((= typ (quote gql-doc))
|
||||||
|
(join "\n\n" (map gql-serialize (gql-doc-definitions node))))
|
||||||
|
((or (= typ (quote gql-query)) (= typ (quote gql-mutation)) (= typ (quote gql-subscription)))
|
||||||
|
(let
|
||||||
|
((op-word (cond ((= typ (quote gql-query)) "query") ((= typ (quote gql-mutation)) "mutation") ((= typ (quote gql-subscription)) "subscription")))
|
||||||
|
(name (gql-op-name node))
|
||||||
|
(vars (gql-op-vars node))
|
||||||
|
(sels (gql-op-selections node)))
|
||||||
|
(str
|
||||||
|
op-word
|
||||||
|
(if name (str " " name) "")
|
||||||
|
(if (> (length vars) 0) (serialize-var-defs vars) "")
|
||||||
|
" "
|
||||||
|
(serialize-selection-set sels))))
|
||||||
|
((= typ (quote gql-field))
|
||||||
|
(let
|
||||||
|
((name (gql-field-name node))
|
||||||
|
(alias (gql-field-alias node))
|
||||||
|
(args (gql-field-args node))
|
||||||
|
(sels (gql-field-selections node)))
|
||||||
|
(str
|
||||||
|
(if alias (str alias ": ") "")
|
||||||
|
name
|
||||||
|
(if (> (length args) 0) (serialize-args args) "")
|
||||||
|
(if
|
||||||
|
(> (length sels) 0)
|
||||||
|
(str " " (serialize-selection-set sels))
|
||||||
|
""))))
|
||||||
|
((= typ (quote gql-fragment))
|
||||||
|
(str
|
||||||
|
"fragment "
|
||||||
|
(gql-frag-name node)
|
||||||
|
" on "
|
||||||
|
(gql-frag-type node)
|
||||||
|
" "
|
||||||
|
(serialize-selection-set (gql-frag-selections node))))
|
||||||
|
((= typ (quote gql-fragment-spread)) (str "..." (nth node 1)))
|
||||||
|
((= typ (quote gql-var)) (str "$" (nth node 1)))
|
||||||
|
(true "")))))))
|
||||||
104
lib/haskell/test.sh
Executable file
104
lib/haskell/test.sh
Executable file
@@ -0,0 +1,104 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# Fast Haskell-on-SX test runner — pipes directly to sx_server.exe.
|
||||||
|
# No MCP, no Docker. All tests live in lib/haskell/tests/*.sx and
|
||||||
|
# produce a summary dict at the end of each file.
|
||||||
|
#
|
||||||
|
# Usage:
|
||||||
|
# bash lib/haskell/test.sh # run all tests
|
||||||
|
# bash lib/haskell/test.sh -v # verbose — show each file's pass/fail
|
||||||
|
# bash lib/haskell/test.sh tests/parse.sx # run one file
|
||||||
|
|
||||||
|
set -euo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
# Fall back to the main-repo build if we're in a worktree.
|
||||||
|
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||||
|
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||||
|
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||||
|
else
|
||||||
|
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
fi
|
||||||
|
|
||||||
|
VERBOSE=""
|
||||||
|
FILES=()
|
||||||
|
for arg in "$@"; do
|
||||||
|
case "$arg" in
|
||||||
|
-v|--verbose) VERBOSE=1 ;;
|
||||||
|
*) FILES+=("$arg") ;;
|
||||||
|
esac
|
||||||
|
done
|
||||||
|
|
||||||
|
if [ ${#FILES[@]} -eq 0 ]; then
|
||||||
|
mapfile -t FILES < <(find lib/haskell/tests -maxdepth 2 -name '*.sx' | sort)
|
||||||
|
fi
|
||||||
|
|
||||||
|
TOTAL_PASS=0
|
||||||
|
TOTAL_FAIL=0
|
||||||
|
FAILED_FILES=()
|
||||||
|
|
||||||
|
for FILE in "${FILES[@]}"; do
|
||||||
|
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
|
||||||
|
TMPFILE=$(mktemp)
|
||||||
|
cat > "$TMPFILE" <<EPOCHS
|
||||||
|
(epoch 1)
|
||||||
|
(load "lib/haskell/tokenizer.sx")
|
||||||
|
(epoch 2)
|
||||||
|
(load "$FILE")
|
||||||
|
(epoch 3)
|
||||||
|
(eval "(list hk-test-pass hk-test-fail)")
|
||||||
|
EPOCHS
|
||||||
|
|
||||||
|
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||||
|
rm -f "$TMPFILE"
|
||||||
|
|
||||||
|
# Output format: either "(ok 3 (P F))" on one line (short result) or
|
||||||
|
# "(ok-len 3 N)\n(P F)" where the value appears on the following line.
|
||||||
|
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
|
||||||
|
if [ -z "$LINE" ]; then
|
||||||
|
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||||
|
| sed -E 's/^\(ok 3 //; s/\)$//')
|
||||||
|
fi
|
||||||
|
if [ -z "$LINE" ]; then
|
||||||
|
echo "✗ $FILE: could not extract summary"
|
||||||
|
echo "$OUTPUT" | tail -20
|
||||||
|
TOTAL_FAIL=$((TOTAL_FAIL + 1))
|
||||||
|
FAILED_FILES+=("$FILE")
|
||||||
|
continue
|
||||||
|
fi
|
||||||
|
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||||
|
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||||
|
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||||
|
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||||
|
if [ "$F" -gt 0 ]; then
|
||||||
|
FAILED_FILES+=("$FILE")
|
||||||
|
printf '✗ %-40s %d/%d\n' "$FILE" "$P" "$((P+F))"
|
||||||
|
# Print failure names
|
||||||
|
TMPFILE2=$(mktemp)
|
||||||
|
cat > "$TMPFILE2" <<EPOCHS
|
||||||
|
(epoch 1)
|
||||||
|
(load "lib/haskell/tokenizer.sx")
|
||||||
|
(epoch 2)
|
||||||
|
(load "$FILE")
|
||||||
|
(epoch 3)
|
||||||
|
(eval "(map (fn (f) (get f \"name\")) hk-test-fails)")
|
||||||
|
EPOCHS
|
||||||
|
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
|
||||||
|
rm -f "$TMPFILE2"
|
||||||
|
echo " $FAILS"
|
||||||
|
elif [ "$VERBOSE" = "1" ]; then
|
||||||
|
printf '✓ %-40s %d passed\n' "$FILE" "$P"
|
||||||
|
fi
|
||||||
|
done
|
||||||
|
|
||||||
|
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||||
|
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||||
|
echo "✓ $TOTAL_PASS/$TOTAL haskell-on-sx tests passed"
|
||||||
|
else
|
||||||
|
echo "✗ $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
|
||||||
|
fi
|
||||||
|
|
||||||
|
[ $TOTAL_FAIL -eq 0 ]
|
||||||
251
lib/haskell/tests/parse.sx
Normal file
251
lib/haskell/tests/parse.sx
Normal file
@@ -0,0 +1,251 @@
|
|||||||
|
;; Haskell parser / tokenizer tests.
|
||||||
|
;;
|
||||||
|
;; Lightweight runner: each test checks actual vs expected with
|
||||||
|
;; structural (deep) equality and accumulates pass/fail counters.
|
||||||
|
;; Final value of this file is a summary dict with :pass :fail :fails.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-deep=?
|
||||||
|
(fn
|
||||||
|
(a b)
|
||||||
|
(cond
|
||||||
|
((= a b) true)
|
||||||
|
((and (dict? a) (dict? b))
|
||||||
|
(let
|
||||||
|
((ak (keys a)) (bk (keys b)))
|
||||||
|
(if
|
||||||
|
(not (= (len ak) (len bk)))
|
||||||
|
false
|
||||||
|
(every?
|
||||||
|
(fn
|
||||||
|
(k)
|
||||||
|
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||||
|
ak))))
|
||||||
|
((and (list? a) (list? b))
|
||||||
|
(if
|
||||||
|
(not (= (len a) (len b)))
|
||||||
|
false
|
||||||
|
(let
|
||||||
|
((i 0) (ok true))
|
||||||
|
(define
|
||||||
|
hk-de-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and ok (< i (len a)))
|
||||||
|
(do
|
||||||
|
(when
|
||||||
|
(not (hk-deep=? (nth a i) (nth b i)))
|
||||||
|
(set! ok false))
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(hk-de-loop)))))
|
||||||
|
(hk-de-loop)
|
||||||
|
ok)))
|
||||||
|
(:else false))))
|
||||||
|
|
||||||
|
(define hk-test-pass 0)
|
||||||
|
(define hk-test-fail 0)
|
||||||
|
(define hk-test-fails (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-test
|
||||||
|
(fn
|
||||||
|
(name actual expected)
|
||||||
|
(if
|
||||||
|
(hk-deep=? actual expected)
|
||||||
|
(set! hk-test-pass (+ hk-test-pass 1))
|
||||||
|
(do
|
||||||
|
(set! hk-test-fail (+ hk-test-fail 1))
|
||||||
|
(append! hk-test-fails {:actual actual :expected expected :name name})))))
|
||||||
|
|
||||||
|
;; Convenience: tokenize and drop newline + eof tokens so tests focus
|
||||||
|
;; on meaningful content. Returns list of {:type :value} pairs.
|
||||||
|
(define
|
||||||
|
hk-toks
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(map
|
||||||
|
(fn (tok) {:value (get tok "value") :type (get tok "type")})
|
||||||
|
(filter
|
||||||
|
(fn
|
||||||
|
(tok)
|
||||||
|
(let
|
||||||
|
((ty (get tok "type")))
|
||||||
|
(not (or (= ty "newline") (= ty "eof")))))
|
||||||
|
(hk-tokenize src)))))
|
||||||
|
|
||||||
|
;; ── 1. Identifiers & reserved words ──
|
||||||
|
(hk-test "varid simple" (hk-toks "foo") (list {:value "foo" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"varid with digits and prime"
|
||||||
|
(hk-toks "foo123' bar2")
|
||||||
|
(list {:value "foo123'" :type "varid"} {:value "bar2" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test "conid" (hk-toks "Maybe") (list {:value "Maybe" :type "conid"}))
|
||||||
|
|
||||||
|
(hk-test "reserved: where" (hk-toks "where") (list {:value "where" :type "reserved"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"reserved: case of"
|
||||||
|
(hk-toks "case of")
|
||||||
|
(list {:value "case" :type "reserved"} {:value "of" :type "reserved"}))
|
||||||
|
|
||||||
|
(hk-test "underscore is reserved" (hk-toks "_") (list {:value "_" :type "reserved"}))
|
||||||
|
|
||||||
|
;; ── 2. Qualified names ──
|
||||||
|
(hk-test "qvarid" (hk-toks "Data.Map.lookup") (list {:value "Data.Map.lookup" :type "qvarid"}))
|
||||||
|
|
||||||
|
(hk-test "qconid" (hk-toks "Data.Map") (list {:value "Data.Map" :type "qconid"}))
|
||||||
|
|
||||||
|
(hk-test "qualified operator" (hk-toks "Prelude.+") (list {:value "Prelude.+" :type "varsym"}))
|
||||||
|
|
||||||
|
;; ── 3. Numbers ──
|
||||||
|
(hk-test "integer" (hk-toks "42") (list {:value 42 :type "integer"}))
|
||||||
|
|
||||||
|
(hk-test "hex" (hk-toks "0x2A") (list {:value 42 :type "integer"}))
|
||||||
|
|
||||||
|
(hk-test "octal" (hk-toks "0o17") (list {:value 15 :type "integer"}))
|
||||||
|
|
||||||
|
(hk-test "float" (hk-toks "3.14") (list {:value 3.14 :type "float"}))
|
||||||
|
|
||||||
|
(hk-test "float with exp" (hk-toks "1.5e-3") (list {:value 0.0015 :type "float"}))
|
||||||
|
|
||||||
|
;; ── 4. Strings / chars ──
|
||||||
|
(hk-test "string" (hk-toks "\"hello\"") (list {:value "hello" :type "string"}))
|
||||||
|
|
||||||
|
(hk-test "char" (hk-toks "'a'") (list {:value "a" :type "char"}))
|
||||||
|
|
||||||
|
(hk-test "char escape newline" (hk-toks "'\\n'") (list {:value "\n" :type "char"}))
|
||||||
|
|
||||||
|
(hk-test "string escape" (hk-toks "\"a\\nb\"") (list {:value "a\nb" :type "string"}))
|
||||||
|
|
||||||
|
;; ── 5. Operators ──
|
||||||
|
(hk-test "operator +" (hk-toks "+") (list {:value "+" :type "varsym"}))
|
||||||
|
|
||||||
|
(hk-test "operator >>=" (hk-toks ">>=") (list {:value ">>=" :type "varsym"}))
|
||||||
|
|
||||||
|
(hk-test "consym" (hk-toks ":+:") (list {:value ":+:" :type "consym"}))
|
||||||
|
|
||||||
|
(hk-test "reservedop ->" (hk-toks "->") (list {:value "->" :type "reservedop"}))
|
||||||
|
|
||||||
|
(hk-test "reservedop =>" (hk-toks "=>") (list {:value "=>" :type "reservedop"}))
|
||||||
|
|
||||||
|
(hk-test "reservedop .. (range)" (hk-toks "..") (list {:value ".." :type "reservedop"}))
|
||||||
|
|
||||||
|
(hk-test "reservedop backslash" (hk-toks "\\") (list {:value "\\" :type "reservedop"}))
|
||||||
|
|
||||||
|
;; ── 6. Punctuation ──
|
||||||
|
(hk-test "parens" (hk-toks "( )") (list {:value "(" :type "lparen"} {:value ")" :type "rparen"}))
|
||||||
|
|
||||||
|
(hk-test "brackets" (hk-toks "[]") (list {:value "[" :type "lbracket"} {:value "]" :type "rbracket"}))
|
||||||
|
|
||||||
|
(hk-test "braces" (hk-toks "{}") (list {:value "{" :type "lbrace"} {:value "}" :type "rbrace"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"backtick"
|
||||||
|
(hk-toks "`mod`")
|
||||||
|
(list {:value "`" :type "backtick"} {:value "mod" :type "varid"} {:value "`" :type "backtick"}))
|
||||||
|
|
||||||
|
(hk-test "comma and semi" (hk-toks ",;") (list {:value "," :type "comma"} {:value ";" :type "semi"}))
|
||||||
|
|
||||||
|
;; ── 7. Comments ──
|
||||||
|
(hk-test "line comment stripped" (hk-toks "-- a comment") (list))
|
||||||
|
|
||||||
|
(hk-test "line comment before code" (hk-toks "-- c\nfoo") (list {:value "foo" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"block comment stripped"
|
||||||
|
(hk-toks "{- block -} foo")
|
||||||
|
(list {:value "foo" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"nested block comment"
|
||||||
|
(hk-toks "{- {- nested -} -} x")
|
||||||
|
(list {:value "x" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"-- inside operator is comment in Haskell"
|
||||||
|
(hk-toks "-->")
|
||||||
|
(list {:value "-->" :type "varsym"}))
|
||||||
|
|
||||||
|
;; ── 8. Mixed declarations ──
|
||||||
|
(hk-test
|
||||||
|
"type signature"
|
||||||
|
(hk-toks "main :: IO ()")
|
||||||
|
(list {:value "main" :type "varid"} {:value "::" :type "reservedop"} {:value "IO" :type "conid"} {:value "(" :type "lparen"} {:value ")" :type "rparen"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"data declaration"
|
||||||
|
(hk-toks "data Maybe a = Nothing | Just a")
|
||||||
|
(list
|
||||||
|
{:value "data" :type "reserved"}
|
||||||
|
{:value "Maybe" :type "conid"}
|
||||||
|
{:value "a" :type "varid"}
|
||||||
|
{:value "=" :type "reservedop"}
|
||||||
|
{:value "Nothing" :type "conid"}
|
||||||
|
{:value "|" :type "reservedop"}
|
||||||
|
{:value "Just" :type "conid"}
|
||||||
|
{:value "a" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"lambda"
|
||||||
|
(hk-toks "\\x -> x + 1")
|
||||||
|
(list {:value "\\" :type "reservedop"} {:value "x" :type "varid"} {:value "->" :type "reservedop"} {:value "x" :type "varid"} {:value "+" :type "varsym"} {:value 1 :type "integer"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"let expression"
|
||||||
|
(hk-toks "let x = 1 in x + x")
|
||||||
|
(list
|
||||||
|
{:value "let" :type "reserved"}
|
||||||
|
{:value "x" :type "varid"}
|
||||||
|
{:value "=" :type "reservedop"}
|
||||||
|
{:value 1 :type "integer"}
|
||||||
|
{:value "in" :type "reserved"}
|
||||||
|
{:value "x" :type "varid"}
|
||||||
|
{:value "+" :type "varsym"}
|
||||||
|
{:value "x" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"case expr"
|
||||||
|
(hk-toks "case x of Just y -> y")
|
||||||
|
(list
|
||||||
|
{:value "case" :type "reserved"}
|
||||||
|
{:value "x" :type "varid"}
|
||||||
|
{:value "of" :type "reserved"}
|
||||||
|
{:value "Just" :type "conid"}
|
||||||
|
{:value "y" :type "varid"}
|
||||||
|
{:value "->" :type "reservedop"}
|
||||||
|
{:value "y" :type "varid"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"list literal"
|
||||||
|
(hk-toks "[1, 2, 3]")
|
||||||
|
(list
|
||||||
|
{:value "[" :type "lbracket"}
|
||||||
|
{:value 1 :type "integer"}
|
||||||
|
{:value "," :type "comma"}
|
||||||
|
{:value 2 :type "integer"}
|
||||||
|
{:value "," :type "comma"}
|
||||||
|
{:value 3 :type "integer"}
|
||||||
|
{:value "]" :type "rbracket"}))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"range syntax"
|
||||||
|
(hk-toks "[1..10]")
|
||||||
|
(list {:value "[" :type "lbracket"} {:value 1 :type "integer"} {:value ".." :type "reservedop"} {:value 10 :type "integer"} {:value "]" :type "rbracket"}))
|
||||||
|
|
||||||
|
;; ── 9. Positions ──
|
||||||
|
(hk-test
|
||||||
|
"line/col positions"
|
||||||
|
(let
|
||||||
|
((toks (hk-tokenize "foo\n bar")))
|
||||||
|
(list
|
||||||
|
(get (nth toks 0) "line")
|
||||||
|
(get (nth toks 0) "col")
|
||||||
|
(get (nth toks 2) "line")
|
||||||
|
(get (nth toks 2) "col")))
|
||||||
|
(list 1 1 2 3))
|
||||||
|
|
||||||
|
;; ── Summary — final value of this file ──
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
628
lib/haskell/tokenizer.sx
Normal file
628
lib/haskell/tokenizer.sx
Normal file
@@ -0,0 +1,628 @@
|
|||||||
|
;; Haskell tokenizer — produces a token stream from Haskell 98 source.
|
||||||
|
;;
|
||||||
|
;; Tokens: {:type T :value V :line L :col C}
|
||||||
|
;;
|
||||||
|
;; Types:
|
||||||
|
;; "varid" lowercase ident, e.g. fmap, x, myFunc
|
||||||
|
;; "conid" uppercase ident, e.g. Nothing, Just, Map
|
||||||
|
;; "qvarid" qualified varid, value holds raw "A.B.foo"
|
||||||
|
;; "qconid" qualified conid, e.g. "Data.Map"
|
||||||
|
;; "reserved" reserved word — value is the word
|
||||||
|
;; "varsym" operator symbol, e.g. +, ++, >>=
|
||||||
|
;; "consym" constructor operator (starts with :), e.g. :, :+
|
||||||
|
;; "reservedop" reserved operator ("::", "=", "->", "<-", "=>", "|", "\\", "@", "~", "..")
|
||||||
|
;; "integer" integer literal (number)
|
||||||
|
;; "float" float literal (number)
|
||||||
|
;; "char" char literal (string of length 1)
|
||||||
|
;; "string" string literal
|
||||||
|
;; "lparen" "rparen" "lbracket" "rbracket" "lbrace" "rbrace"
|
||||||
|
;; "vlbrace" "vrbrace" "vsemi" virtual layout tokens (inserted later)
|
||||||
|
;; "comma" "semi" "backtick"
|
||||||
|
;; "newline" a logical line break (used by layout pass; stripped afterwards)
|
||||||
|
;; "eof"
|
||||||
|
;;
|
||||||
|
;; Note: SX `cond`/`when` clauses evaluate ONLY their last expression.
|
||||||
|
;; Multi-expression bodies must be wrapped in (do ...). All helpers use
|
||||||
|
;; the hk- prefix to avoid clashing with SX evaluator special forms.
|
||||||
|
|
||||||
|
;; ── Char-code table ───────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
hk-ord-table
|
||||||
|
(let
|
||||||
|
((t (dict)) (i 0))
|
||||||
|
(define
|
||||||
|
hk-build-table
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(< i 128)
|
||||||
|
(do
|
||||||
|
(dict-set! t (char-from-code i) i)
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(hk-build-table)))))
|
||||||
|
(hk-build-table)
|
||||||
|
t))
|
||||||
|
|
||||||
|
(define hk-ord (fn (c) (or (get hk-ord-table c) 0)))
|
||||||
|
|
||||||
|
;; ── Character predicates ──────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
hk-digit?
|
||||||
|
(fn (c) (and (string? c) (>= (hk-ord c) 48) (<= (hk-ord c) 57))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-hex-digit?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(and
|
||||||
|
(string? c)
|
||||||
|
(or
|
||||||
|
(and (>= (hk-ord c) 48) (<= (hk-ord c) 57))
|
||||||
|
(and (>= (hk-ord c) 97) (<= (hk-ord c) 102))
|
||||||
|
(and (>= (hk-ord c) 65) (<= (hk-ord c) 70))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-octal-digit?
|
||||||
|
(fn (c) (and (string? c) (>= (hk-ord c) 48) (<= (hk-ord c) 55))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-lower?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(and
|
||||||
|
(string? c)
|
||||||
|
(or (and (>= (hk-ord c) 97) (<= (hk-ord c) 122)) (= c "_")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-upper?
|
||||||
|
(fn (c) (and (string? c) (>= (hk-ord c) 65) (<= (hk-ord c) 90))))
|
||||||
|
|
||||||
|
(define hk-alpha? (fn (c) (or (hk-lower? c) (hk-upper? c))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-ident-char?
|
||||||
|
(fn (c) (or (hk-alpha? c) (hk-digit? c) (= c "'"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-symbol-char?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(or
|
||||||
|
(= c "!")
|
||||||
|
(= c "#")
|
||||||
|
(= c "$")
|
||||||
|
(= c "%")
|
||||||
|
(= c "&")
|
||||||
|
(= c "*")
|
||||||
|
(= c "+")
|
||||||
|
(= c ".")
|
||||||
|
(= c "/")
|
||||||
|
(= c "<")
|
||||||
|
(= c "=")
|
||||||
|
(= c ">")
|
||||||
|
(= c "?")
|
||||||
|
(= c "@")
|
||||||
|
(= c "\\")
|
||||||
|
(= c "^")
|
||||||
|
(= c "|")
|
||||||
|
(= c "-")
|
||||||
|
(= c "~")
|
||||||
|
(= c ":"))))
|
||||||
|
|
||||||
|
(define hk-space? (fn (c) (or (= c " ") (= c "\t"))))
|
||||||
|
|
||||||
|
;; ── Hex / oct parser (parse-int is decimal only) ──────────────────
|
||||||
|
(define
|
||||||
|
hk-parse-radix
|
||||||
|
(fn
|
||||||
|
(s radix)
|
||||||
|
(let
|
||||||
|
((n-len (len s)) (idx 0) (acc 0))
|
||||||
|
(define
|
||||||
|
hk-rad-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(< idx n-len)
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((c (substring s idx (+ idx 1))))
|
||||||
|
(cond
|
||||||
|
((and (>= (hk-ord c) 48) (<= (hk-ord c) 57))
|
||||||
|
(set! acc (+ (* acc radix) (- (hk-ord c) 48))))
|
||||||
|
((and (>= (hk-ord c) 97) (<= (hk-ord c) 102))
|
||||||
|
(set! acc (+ (* acc radix) (+ 10 (- (hk-ord c) 97)))))
|
||||||
|
((and (>= (hk-ord c) 65) (<= (hk-ord c) 70))
|
||||||
|
(set! acc (+ (* acc radix) (+ 10 (- (hk-ord c) 65)))))))
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(hk-rad-loop)))))
|
||||||
|
(hk-rad-loop)
|
||||||
|
acc)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-parse-float
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((n-len (len s))
|
||||||
|
(idx 0)
|
||||||
|
(sign 1)
|
||||||
|
(int-part 0)
|
||||||
|
(frac-part 0)
|
||||||
|
(frac-div 1)
|
||||||
|
(exp-sign 1)
|
||||||
|
(exp-val 0)
|
||||||
|
(has-exp false))
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (= (substring s idx (+ idx 1)) "-"))
|
||||||
|
(do (set! sign -1) (set! idx (+ idx 1))))
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (= (substring s idx (+ idx 1)) "+"))
|
||||||
|
(set! idx (+ idx 1)))
|
||||||
|
(define
|
||||||
|
hk-int-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (hk-digit? (substring s idx (+ idx 1))))
|
||||||
|
(do
|
||||||
|
(set!
|
||||||
|
int-part
|
||||||
|
(+ (* int-part 10) (parse-int (substring s idx (+ idx 1)))))
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(hk-int-loop)))))
|
||||||
|
(hk-int-loop)
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (= (substring s idx (+ idx 1)) "."))
|
||||||
|
(do
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(define
|
||||||
|
hk-frac-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (hk-digit? (substring s idx (+ idx 1))))
|
||||||
|
(do
|
||||||
|
(set! frac-div (* frac-div 10))
|
||||||
|
(set!
|
||||||
|
frac-part
|
||||||
|
(+
|
||||||
|
frac-part
|
||||||
|
(/ (parse-int (substring s idx (+ idx 1))) frac-div)))
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(hk-frac-loop)))))
|
||||||
|
(hk-frac-loop)))
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< idx n-len)
|
||||||
|
(let
|
||||||
|
((c (substring s idx (+ idx 1))))
|
||||||
|
(or (= c "e") (= c "E"))))
|
||||||
|
(do
|
||||||
|
(set! has-exp true)
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(cond
|
||||||
|
((and (< idx n-len) (= (substring s idx (+ idx 1)) "-"))
|
||||||
|
(do (set! exp-sign -1) (set! idx (+ idx 1))))
|
||||||
|
((and (< idx n-len) (= (substring s idx (+ idx 1)) "+"))
|
||||||
|
(set! idx (+ idx 1))))
|
||||||
|
(define
|
||||||
|
hk-exp-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< idx n-len) (hk-digit? (substring s idx (+ idx 1))))
|
||||||
|
(do
|
||||||
|
(set!
|
||||||
|
exp-val
|
||||||
|
(+
|
||||||
|
(* exp-val 10)
|
||||||
|
(parse-int (substring s idx (+ idx 1)))))
|
||||||
|
(set! idx (+ idx 1))
|
||||||
|
(hk-exp-loop)))))
|
||||||
|
(hk-exp-loop)))
|
||||||
|
(let
|
||||||
|
((base (* sign (+ int-part frac-part))))
|
||||||
|
(if has-exp (* base (pow 10 (* exp-sign exp-val))) base)))))
|
||||||
|
|
||||||
|
;; ── Reserved words / ops ──────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
hk-reserved-words
|
||||||
|
(list
|
||||||
|
"case"
|
||||||
|
"class"
|
||||||
|
"data"
|
||||||
|
"default"
|
||||||
|
"deriving"
|
||||||
|
"do"
|
||||||
|
"else"
|
||||||
|
"foreign"
|
||||||
|
"if"
|
||||||
|
"import"
|
||||||
|
"in"
|
||||||
|
"infix"
|
||||||
|
"infixl"
|
||||||
|
"infixr"
|
||||||
|
"instance"
|
||||||
|
"let"
|
||||||
|
"module"
|
||||||
|
"newtype"
|
||||||
|
"of"
|
||||||
|
"then"
|
||||||
|
"type"
|
||||||
|
"where"
|
||||||
|
"_"))
|
||||||
|
|
||||||
|
(define hk-reserved? (fn (w) (contains? hk-reserved-words w)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-reserved-ops
|
||||||
|
(list ".." ":" "::" "=" "\\" "|" "<-" "->" "@" "~" "=>"))
|
||||||
|
|
||||||
|
(define hk-reserved-op? (fn (w) (contains? hk-reserved-ops w)))
|
||||||
|
|
||||||
|
;; ── Token constructor ─────────────────────────────────────────────
|
||||||
|
(define hk-make-token (fn (type value line col) {:line line :value value :col col :type type}))
|
||||||
|
|
||||||
|
;; ── Main tokenizer ────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
hk-tokenize
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((tokens (list)) (pos 0) (line 1) (col 1) (src-len (len src)))
|
||||||
|
(define
|
||||||
|
hk-peek
|
||||||
|
(fn
|
||||||
|
(offset)
|
||||||
|
(if
|
||||||
|
(< (+ pos offset) src-len)
|
||||||
|
(substring src (+ pos offset) (+ pos offset 1))
|
||||||
|
nil)))
|
||||||
|
(define hk-cur (fn () (hk-peek 0)))
|
||||||
|
(define
|
||||||
|
hk-advance!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((c (hk-cur)))
|
||||||
|
(set! pos (+ pos 1))
|
||||||
|
(if
|
||||||
|
(= c "\n")
|
||||||
|
(do (set! line (+ line 1)) (set! col 1))
|
||||||
|
(set! col (+ col 1))))))
|
||||||
|
(define
|
||||||
|
hk-advance-n!
|
||||||
|
(fn
|
||||||
|
(n)
|
||||||
|
(when (> n 0) (do (hk-advance!) (hk-advance-n! (- n 1))))))
|
||||||
|
(define
|
||||||
|
hk-push!
|
||||||
|
(fn
|
||||||
|
(type value tok-line tok-col)
|
||||||
|
(append! tokens (hk-make-token type value tok-line tok-col))))
|
||||||
|
(define
|
||||||
|
hk-read-while
|
||||||
|
(fn
|
||||||
|
(pred)
|
||||||
|
(let
|
||||||
|
((start pos))
|
||||||
|
(define
|
||||||
|
hk-rw-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (pred (hk-cur)))
|
||||||
|
(do (hk-advance!) (hk-rw-loop)))))
|
||||||
|
(hk-rw-loop)
|
||||||
|
(substring src start pos))))
|
||||||
|
(define
|
||||||
|
hk-skip-line-comment!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(define
|
||||||
|
hk-slc-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (not (= (hk-cur) "\n")))
|
||||||
|
(do (hk-advance!) (hk-slc-loop)))))
|
||||||
|
(hk-slc-loop)))
|
||||||
|
(define
|
||||||
|
hk-skip-block-comment!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(hk-advance-n! 2)
|
||||||
|
(let
|
||||||
|
((depth 1))
|
||||||
|
(define
|
||||||
|
hk-sbc-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((and (= (hk-cur) "{") (= (hk-peek 1) "-"))
|
||||||
|
(do
|
||||||
|
(hk-advance-n! 2)
|
||||||
|
(set! depth (+ depth 1))
|
||||||
|
(hk-sbc-loop)))
|
||||||
|
((and (= (hk-cur) "-") (= (hk-peek 1) "}"))
|
||||||
|
(do
|
||||||
|
(hk-advance-n! 2)
|
||||||
|
(set! depth (- depth 1))
|
||||||
|
(when (> depth 0) (hk-sbc-loop))))
|
||||||
|
(:else (do (hk-advance!) (hk-sbc-loop))))))
|
||||||
|
(hk-sbc-loop))))
|
||||||
|
(define
|
||||||
|
hk-read-escape
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(hk-advance!)
|
||||||
|
(let
|
||||||
|
((c (hk-cur)))
|
||||||
|
(cond
|
||||||
|
((= c "n") (do (hk-advance!) "\n"))
|
||||||
|
((= c "t") (do (hk-advance!) "\t"))
|
||||||
|
((= c "r") (do (hk-advance!) "\r"))
|
||||||
|
((= c "\\") (do (hk-advance!) "\\"))
|
||||||
|
((= c "'") (do (hk-advance!) "'"))
|
||||||
|
((= c "\"") (do (hk-advance!) "\""))
|
||||||
|
((= c "0") (do (hk-advance!) (char-from-code 0)))
|
||||||
|
((= c "a") (do (hk-advance!) (char-from-code 7)))
|
||||||
|
((= c "b") (do (hk-advance!) (char-from-code 8)))
|
||||||
|
((= c "f") (do (hk-advance!) (char-from-code 12)))
|
||||||
|
((= c "v") (do (hk-advance!) (char-from-code 11)))
|
||||||
|
((hk-digit? c)
|
||||||
|
(let
|
||||||
|
((digits (hk-read-while hk-digit?)))
|
||||||
|
(char-from-code (parse-int digits))))
|
||||||
|
(:else (do (hk-advance!) (str "\\" c)))))))
|
||||||
|
(define
|
||||||
|
hk-read-string
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((parts (list)))
|
||||||
|
(hk-advance!)
|
||||||
|
(define
|
||||||
|
hk-rs-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (hk-cur) "\"") (hk-advance!))
|
||||||
|
((= (hk-cur) "\\")
|
||||||
|
(do (append! parts (hk-read-escape)) (hk-rs-loop)))
|
||||||
|
(:else
|
||||||
|
(do
|
||||||
|
(append! parts (hk-cur))
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-rs-loop))))))
|
||||||
|
(hk-rs-loop)
|
||||||
|
(join "" parts))))
|
||||||
|
(define
|
||||||
|
hk-read-char-lit
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(hk-advance!)
|
||||||
|
(let
|
||||||
|
((c (if (= (hk-cur) "\\") (hk-read-escape) (let ((ch (hk-cur))) (hk-advance!) ch))))
|
||||||
|
(when (= (hk-cur) "'") (hk-advance!))
|
||||||
|
c)))
|
||||||
|
(define
|
||||||
|
hk-read-number
|
||||||
|
(fn
|
||||||
|
(tok-line tok-col)
|
||||||
|
(let
|
||||||
|
((start pos))
|
||||||
|
(cond
|
||||||
|
((and (= (hk-cur) "0") (or (= (hk-peek 1) "x") (= (hk-peek 1) "X")))
|
||||||
|
(do
|
||||||
|
(hk-advance-n! 2)
|
||||||
|
(let
|
||||||
|
((hex-start pos))
|
||||||
|
(hk-read-while hk-hex-digit?)
|
||||||
|
(hk-push!
|
||||||
|
"integer"
|
||||||
|
(hk-parse-radix (substring src hex-start pos) 16)
|
||||||
|
tok-line
|
||||||
|
tok-col))))
|
||||||
|
((and (= (hk-cur) "0") (or (= (hk-peek 1) "o") (= (hk-peek 1) "O")))
|
||||||
|
(do
|
||||||
|
(hk-advance-n! 2)
|
||||||
|
(let
|
||||||
|
((oct-start pos))
|
||||||
|
(hk-read-while hk-octal-digit?)
|
||||||
|
(hk-push!
|
||||||
|
"integer"
|
||||||
|
(hk-parse-radix (substring src oct-start pos) 8)
|
||||||
|
tok-line
|
||||||
|
tok-col))))
|
||||||
|
(:else
|
||||||
|
(do
|
||||||
|
(hk-read-while hk-digit?)
|
||||||
|
(let
|
||||||
|
((is-float false))
|
||||||
|
(when
|
||||||
|
(and (= (hk-cur) ".") (hk-digit? (hk-peek 1)))
|
||||||
|
(do
|
||||||
|
(set! is-float true)
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-read-while hk-digit?)))
|
||||||
|
(when
|
||||||
|
(or (= (hk-cur) "e") (= (hk-cur) "E"))
|
||||||
|
(do
|
||||||
|
(set! is-float true)
|
||||||
|
(hk-advance!)
|
||||||
|
(when
|
||||||
|
(or (= (hk-cur) "+") (= (hk-cur) "-"))
|
||||||
|
(hk-advance!))
|
||||||
|
(hk-read-while hk-digit?)))
|
||||||
|
(let
|
||||||
|
((num-str (substring src start pos)))
|
||||||
|
(if
|
||||||
|
is-float
|
||||||
|
(hk-push!
|
||||||
|
"float"
|
||||||
|
(hk-parse-float num-str)
|
||||||
|
tok-line
|
||||||
|
tok-col)
|
||||||
|
(hk-push!
|
||||||
|
"integer"
|
||||||
|
(parse-int num-str)
|
||||||
|
tok-line
|
||||||
|
tok-col))))))))))
|
||||||
|
(define
|
||||||
|
hk-read-qualified!
|
||||||
|
(fn
|
||||||
|
(tok-line tok-col)
|
||||||
|
(let
|
||||||
|
((parts (list)) (w (hk-read-while hk-ident-char?)))
|
||||||
|
(append! parts w)
|
||||||
|
(let
|
||||||
|
((emitted false))
|
||||||
|
(define
|
||||||
|
hk-rq-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(not emitted)
|
||||||
|
(= (hk-cur) ".")
|
||||||
|
(or
|
||||||
|
(hk-upper? (hk-peek 1))
|
||||||
|
(hk-lower? (hk-peek 1))
|
||||||
|
(hk-symbol-char? (hk-peek 1))))
|
||||||
|
(let
|
||||||
|
((next (hk-peek 1)))
|
||||||
|
(cond
|
||||||
|
((hk-upper? next)
|
||||||
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(append! parts ".")
|
||||||
|
(append! parts (hk-read-while hk-ident-char?))
|
||||||
|
(hk-rq-loop)))
|
||||||
|
((hk-lower? next)
|
||||||
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(set! emitted true)
|
||||||
|
(hk-push!
|
||||||
|
"qvarid"
|
||||||
|
(str
|
||||||
|
(join "" parts)
|
||||||
|
"."
|
||||||
|
(hk-read-while hk-ident-char?))
|
||||||
|
tok-line
|
||||||
|
tok-col)))
|
||||||
|
((hk-symbol-char? next)
|
||||||
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(set! emitted true)
|
||||||
|
(hk-push!
|
||||||
|
"varsym"
|
||||||
|
(str
|
||||||
|
(join "" parts)
|
||||||
|
"."
|
||||||
|
(hk-read-while hk-symbol-char?))
|
||||||
|
tok-line
|
||||||
|
tok-col))))))))
|
||||||
|
(hk-rq-loop)
|
||||||
|
(when
|
||||||
|
(not emitted)
|
||||||
|
(let
|
||||||
|
((full (join "" parts)))
|
||||||
|
(if
|
||||||
|
(string-contains? full ".")
|
||||||
|
(hk-push! "qconid" full tok-line tok-col)
|
||||||
|
(hk-push! "conid" full tok-line tok-col))))))))
|
||||||
|
(define
|
||||||
|
hk-scan!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((hk-space? (hk-cur)) (do (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) "\n")
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((l line) (c col))
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-push! "newline" nil l c))
|
||||||
|
(hk-scan!)))
|
||||||
|
((and (= (hk-cur) "{") (= (hk-peek 1) "-"))
|
||||||
|
(do (hk-skip-block-comment!) (hk-scan!)))
|
||||||
|
((and (= (hk-cur) "-") (= (hk-peek 1) "-") (let ((p2 (hk-peek 2))) (or (nil? p2) (= p2 "\n") (not (hk-symbol-char? p2)))))
|
||||||
|
(do (hk-skip-line-comment!) (hk-scan!)))
|
||||||
|
((= (hk-cur) "\"")
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((l line) (c col))
|
||||||
|
(hk-push! "string" (hk-read-string) l c))
|
||||||
|
(hk-scan!)))
|
||||||
|
((= (hk-cur) "'")
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((l line) (c col))
|
||||||
|
(hk-push! "char" (hk-read-char-lit) l c))
|
||||||
|
(hk-scan!)))
|
||||||
|
((hk-digit? (hk-cur))
|
||||||
|
(do (hk-read-number line col) (hk-scan!)))
|
||||||
|
((hk-lower? (hk-cur))
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((l line) (c col))
|
||||||
|
(let
|
||||||
|
((w (hk-read-while hk-ident-char?)))
|
||||||
|
(if
|
||||||
|
(hk-reserved? w)
|
||||||
|
(hk-push! "reserved" w l c)
|
||||||
|
(hk-push! "varid" w l c))))
|
||||||
|
(hk-scan!)))
|
||||||
|
((hk-upper? (hk-cur))
|
||||||
|
(do
|
||||||
|
(let ((l line) (c col)) (hk-read-qualified! l c))
|
||||||
|
(hk-scan!)))
|
||||||
|
((= (hk-cur) "(")
|
||||||
|
(do (hk-push! "lparen" "(" line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) ")")
|
||||||
|
(do (hk-push! "rparen" ")" line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) "[")
|
||||||
|
(do
|
||||||
|
(hk-push! "lbracket" "[" line col)
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-scan!)))
|
||||||
|
((= (hk-cur) "]")
|
||||||
|
(do
|
||||||
|
(hk-push! "rbracket" "]" line col)
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-scan!)))
|
||||||
|
((= (hk-cur) "{")
|
||||||
|
(do (hk-push! "lbrace" "{" line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) "}")
|
||||||
|
(do (hk-push! "rbrace" "}" line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) ",")
|
||||||
|
(do (hk-push! "comma" "," line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) ";")
|
||||||
|
(do (hk-push! "semi" ";" line col) (hk-advance!) (hk-scan!)))
|
||||||
|
((= (hk-cur) "`")
|
||||||
|
(do
|
||||||
|
(hk-push! "backtick" "`" line col)
|
||||||
|
(hk-advance!)
|
||||||
|
(hk-scan!)))
|
||||||
|
((hk-symbol-char? (hk-cur))
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((l line) (c col))
|
||||||
|
(let
|
||||||
|
((first (hk-cur)))
|
||||||
|
(let
|
||||||
|
((w (hk-read-while hk-symbol-char?)))
|
||||||
|
(cond
|
||||||
|
((hk-reserved-op? w) (hk-push! "reservedop" w l c))
|
||||||
|
((= first ":") (hk-push! "consym" w l c))
|
||||||
|
(:else (hk-push! "varsym" w l c))))))
|
||||||
|
(hk-scan!)))
|
||||||
|
(:else (do (hk-advance!) (hk-scan!))))))
|
||||||
|
(hk-scan!)
|
||||||
|
(hk-push! "eof" nil line col)
|
||||||
|
tokens)))
|
||||||
File diff suppressed because it is too large
Load Diff
38
lib/hyperscript/debug.sx
Normal file
38
lib/hyperscript/debug.sx
Normal file
@@ -0,0 +1,38 @@
|
|||||||
|
;; Hyperscript debug harness — mock DOM for instant testing
|
||||||
|
;;
|
||||||
|
;; Load once into the image, then repeatedly call hs-run.
|
||||||
|
;; All DOM ops are intercepted and logged via the test harness.
|
||||||
|
|
||||||
|
;; ── Mock element ────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
hs-mock-element
|
||||||
|
(fn
|
||||||
|
(tag id classes)
|
||||||
|
(let
|
||||||
|
((cls-set (reduce (fn (d c) (dict-set d c true)) {} classes)))
|
||||||
|
{:children () :_hs-activated true :tag tag :classes cls-set :text "" :id id :attrs {}})))
|
||||||
|
|
||||||
|
;; ── Mock platform ───────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define hs-mock-platform {:hs-wait (fn (ms) nil) :hs-wait-for (fn (target event) nil) :dom-get-attr (fn (el attr) (get (get el "attrs") attr)) :dom-has-class? (fn (el cls) (dict-has? (get el "classes") cls)) :dom-set-text (fn (el text) (dict-set! el "text" text) nil) :hs-settle (fn (el) nil) :dom-add-class (fn (el cls) (dict-set! (get el "classes") cls true) nil) :dom-query (fn (sel) nil) :dom-remove-class (fn (el cls) (dict-delete! (get el "classes") cls) nil) :dom-listen (fn (target event-name handler) (handler {:target target :type event-name})) :dom-set-attr (fn (el attr val) (dict-set! (get el "attrs") attr val) nil) :dom-query-all (fn (sel) ())})
|
||||||
|
|
||||||
|
;; ── Convenience runner ──────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
hs-run
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((me (hs-mock-element "div" "test" ()))
|
||||||
|
(sx (hs-to-sx-from-source src)))
|
||||||
|
(let
|
||||||
|
((handler (eval-expr (list (quote fn) (quote (me)) (list (quote let) (quote ((it nil) (event {:target me :type "click"}))) sx)))))
|
||||||
|
(handler me)
|
||||||
|
me))))
|
||||||
|
|
||||||
|
;; ── Element inspection ──────────────────────────────────────────
|
||||||
|
|
||||||
|
(define hs-classes (fn (el) (keys (get el "classes"))))
|
||||||
|
|
||||||
|
(define hs-has-class? (fn (el cls) (dict-has? (get el "classes") cls)))
|
||||||
1211
lib/hyperscript/htmx.sx
Normal file
1211
lib/hyperscript/htmx.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -10,12 +10,55 @@
|
|||||||
;; Returns a function (fn (me) ...) that can be called with a DOM element.
|
;; Returns a function (fn (me) ...) that can be called with a DOM element.
|
||||||
;; Uses eval-expr-cek to turn the SX data structure into a live closure.
|
;; Uses eval-expr-cek to turn the SX data structure into a live closure.
|
||||||
|
|
||||||
|
(begin
|
||||||
|
(define
|
||||||
|
hs-collect-vars
|
||||||
|
(fn
|
||||||
|
(sx)
|
||||||
|
(define vars (list))
|
||||||
|
(define
|
||||||
|
reserved
|
||||||
|
(list
|
||||||
|
(quote me)
|
||||||
|
(quote it)
|
||||||
|
(quote event)
|
||||||
|
(quote you)
|
||||||
|
(quote yourself)))
|
||||||
|
(define
|
||||||
|
walk
|
||||||
|
(fn
|
||||||
|
(node)
|
||||||
|
(when
|
||||||
|
(list? node)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(> (len node) 1)
|
||||||
|
(= (first node) (quote set!))
|
||||||
|
(symbol? (nth node 1)))
|
||||||
|
(let
|
||||||
|
((name (nth node 1)))
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(not (some (fn (v) (= v name)) vars))
|
||||||
|
(not (some (fn (v) (= v name)) reserved)))
|
||||||
|
(set! vars (cons name vars)))))
|
||||||
|
(for-each walk node))))
|
||||||
|
(walk sx)
|
||||||
|
vars))
|
||||||
(define
|
(define
|
||||||
hs-handler
|
hs-handler
|
||||||
(fn
|
(fn
|
||||||
(src)
|
(src)
|
||||||
(let
|
(let
|
||||||
((sx (hs-to-sx-from-source src)))
|
((sx (hs-to-sx-from-source src)))
|
||||||
|
(let
|
||||||
|
((extra-vars (hs-collect-vars sx)))
|
||||||
|
(do
|
||||||
|
(for-each
|
||||||
|
(fn (v) (eval-expr-cek (list (quote define) v nil)))
|
||||||
|
extra-vars)
|
||||||
|
(let
|
||||||
|
((guarded (list (quote guard) (list (quote _e) (list (quote true) (list (quote if) (list (quote and) (list (quote list?) (quote _e)) (list (quote =) (list (quote first) (quote _e)) "hs-return")) (list (quote nth) (quote _e) 1) (list (quote raise) (quote _e))))) sx)))
|
||||||
(eval-expr-cek
|
(eval-expr-cek
|
||||||
(list
|
(list
|
||||||
(quote fn)
|
(quote fn)
|
||||||
@@ -23,7 +66,7 @@
|
|||||||
(list
|
(list
|
||||||
(quote let)
|
(quote let)
|
||||||
(list (list (quote it) nil) (list (quote event) nil))
|
(list (list (quote it) nil) (list (quote event) nil))
|
||||||
sx))))))
|
guarded))))))))))
|
||||||
|
|
||||||
;; ── Activate a single element ───────────────────────────────────
|
;; ── Activate a single element ───────────────────────────────────
|
||||||
;; Reads the _="..." attribute, compiles, and executes with me=element.
|
;; Reads the _="..." attribute, compiles, and executes with me=element.
|
||||||
@@ -34,10 +77,13 @@
|
|||||||
(fn
|
(fn
|
||||||
(el)
|
(el)
|
||||||
(let
|
(let
|
||||||
((src (dom-get-attr el "_")))
|
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
|
||||||
(when
|
(when
|
||||||
(and src (not (dom-get-data el "hs-active")))
|
(and src (not (= src prev)))
|
||||||
|
(hs-log-event! "hyperscript:init")
|
||||||
|
(dom-set-data el "hs-script" src)
|
||||||
(dom-set-data el "hs-active" true)
|
(dom-set-data el "hs-active" true)
|
||||||
|
(dom-set-attr el "data-hyperscript-powered" "true")
|
||||||
(let ((handler (hs-handler src))) (handler el))))))
|
(let ((handler (hs-handler src))) (handler el))))))
|
||||||
|
|
||||||
;; ── Boot: scan entire document ──────────────────────────────────
|
;; ── Boot: scan entire document ──────────────────────────────────
|
||||||
@@ -45,17 +91,28 @@
|
|||||||
;; compiles their hyperscript, and activates them.
|
;; compiles their hyperscript, and activates them.
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-boot!
|
hs-deactivate!
|
||||||
(fn
|
(fn
|
||||||
()
|
(el)
|
||||||
(let
|
(let
|
||||||
((elements (dom-query-all (dom-body) "[_]")))
|
((unlisteners (or (dom-get-data el "hs-unlisteners") (list))))
|
||||||
(for-each (fn (el) (hs-activate! el)) elements))))
|
(for-each (fn (u) (when u (u))) unlisteners)
|
||||||
|
(dom-set-data el "hs-unlisteners" (list))
|
||||||
|
(dom-set-data el "hs-active" false)
|
||||||
|
(dom-set-data el "hs-script" nil))))
|
||||||
|
|
||||||
;; ── Boot subtree: for dynamic content ───────────────────────────
|
;; ── Boot subtree: for dynamic content ───────────────────────────
|
||||||
;; Called after HTMX swaps or dynamic DOM insertion.
|
;; Called after HTMX swaps or dynamic DOM insertion.
|
||||||
;; Only activates elements within the given root.
|
;; Only activates elements within the given root.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hs-boot!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((elements (dom-query-all (host-get (host-global "document") "body") "[_]")))
|
||||||
|
(for-each (fn (el) (hs-activate! el)) elements))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-boot-subtree!
|
hs-boot-subtree!
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
13
lib/hyperscript/test-closure.sx
Normal file
13
lib/hyperscript/test-closure.sx
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
;; Minimal test: define-inside-let pattern (like hs-parse)
|
||||||
|
(define
|
||||||
|
test-closure-parse
|
||||||
|
(fn
|
||||||
|
(tokens)
|
||||||
|
(let
|
||||||
|
((p 0) (tok-len (len tokens)))
|
||||||
|
(define get-val (fn () (get (nth tokens p) "value")))
|
||||||
|
(define advance! (fn () (set! p (+ p 1))))
|
||||||
|
(let
|
||||||
|
((first-val (get-val)))
|
||||||
|
(advance!)
|
||||||
|
(list "first:" first-val "second:" (get-val) "p:" p)))))
|
||||||
156
lib/hyperscript/test.sh
Normal file
156
lib/hyperscript/test.sh
Normal file
@@ -0,0 +1,156 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# Fast hyperscript test runner — pipes directly to sx_server.exe via epoch protocol.
|
||||||
|
# No MCP, no Docker, no web server. Runs in <2 seconds.
|
||||||
|
#
|
||||||
|
# Usage:
|
||||||
|
# bash lib/hyperscript/test.sh # run all tests
|
||||||
|
# bash lib/hyperscript/test.sh -v # verbose — show actual output
|
||||||
|
|
||||||
|
set -euo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
echo "ERROR: $SX_SERVER not found. Run: cd hosts/ocaml && dune build"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
VERBOSE="${1:-}"
|
||||||
|
PASS=0
|
||||||
|
FAIL=0
|
||||||
|
ERRORS=""
|
||||||
|
TMPFILE=$(mktemp)
|
||||||
|
trap "rm -f $TMPFILE" EXIT
|
||||||
|
|
||||||
|
# ── Write epoch commands to temp file ─────────────────────────────
|
||||||
|
cat > "$TMPFILE" << 'EPOCHS'
|
||||||
|
(epoch 1)
|
||||||
|
(load "lib/r7rs.sx")
|
||||||
|
(epoch 2)
|
||||||
|
(load "lib/hyperscript/tokenizer.sx")
|
||||||
|
(epoch 3)
|
||||||
|
(load "lib/hyperscript/parser.sx")
|
||||||
|
(epoch 4)
|
||||||
|
(load "lib/hyperscript/compiler.sx")
|
||||||
|
(epoch 10)
|
||||||
|
(eval "(hs-compile \"on click add .red to me\")")
|
||||||
|
(epoch 11)
|
||||||
|
(eval "(hs-compile \"on click toggle .active on me\")")
|
||||||
|
(epoch 12)
|
||||||
|
(eval "(hs-compile \"on click add .red to me then remove .blue from me\")")
|
||||||
|
(epoch 13)
|
||||||
|
(eval "(hs-compile \"on click set my innerHTML to 'hello'\")")
|
||||||
|
(epoch 14)
|
||||||
|
(eval "(hs-compile \"on click log me\")")
|
||||||
|
(epoch 15)
|
||||||
|
(eval "(hs-compile \"add .highlight to me\")")
|
||||||
|
(epoch 16)
|
||||||
|
(eval "(hs-compile \"remove .highlight from me\")")
|
||||||
|
(epoch 17)
|
||||||
|
(eval "(hs-compile \"toggle .visible on me\")")
|
||||||
|
(epoch 18)
|
||||||
|
(eval "(hs-compile \"hide me\")")
|
||||||
|
(epoch 19)
|
||||||
|
(eval "(hs-compile \"show me\")")
|
||||||
|
(epoch 20)
|
||||||
|
(eval "(hs-compile \"wait 500ms\")")
|
||||||
|
(epoch 21)
|
||||||
|
(eval "(hs-compile \"wait 2s\")")
|
||||||
|
(epoch 22)
|
||||||
|
(eval "(hs-compile \"set x to 1 + 2\")")
|
||||||
|
(epoch 23)
|
||||||
|
(eval "(hs-compile \"set x to 3 * 4\")")
|
||||||
|
(epoch 24)
|
||||||
|
(eval "(hs-compile \"init add .loaded to me end\")")
|
||||||
|
(epoch 25)
|
||||||
|
(eval "(hs-compile \"set x to 42\")")
|
||||||
|
(epoch 26)
|
||||||
|
(eval "(hs-compile \"put 'hello' into me\")")
|
||||||
|
(epoch 27)
|
||||||
|
(eval "(hs-compile \"increment x\")")
|
||||||
|
(epoch 28)
|
||||||
|
(eval "(hs-compile \"decrement x\")")
|
||||||
|
(epoch 29)
|
||||||
|
(eval "(hs-compile \"on every click log me end\")")
|
||||||
|
(epoch 30)
|
||||||
|
(eval "(hs-compile \"on click from .btn log me end\")")
|
||||||
|
(epoch 40)
|
||||||
|
(eval "(hs-to-sx-from-source \"on click add .red to me\")")
|
||||||
|
(epoch 41)
|
||||||
|
(eval "(hs-to-sx-from-source \"on click toggle .active on me\")")
|
||||||
|
(epoch 42)
|
||||||
|
(eval "(hs-to-sx-from-source \"on click set my innerHTML to 'hello'\")")
|
||||||
|
(epoch 43)
|
||||||
|
(eval "(hs-to-sx-from-source \"on click add .red to me then remove .blue from me\")")
|
||||||
|
EPOCHS
|
||||||
|
|
||||||
|
# ── Run ───────────────────────────────────────────────────────────
|
||||||
|
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
||||||
|
|
||||||
|
# ── Check function ────────────────────────────────────────────────
|
||||||
|
check() {
|
||||||
|
local epoch="$1" desc="$2" expected="$3"
|
||||||
|
local actual
|
||||||
|
actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1)
|
||||||
|
if [ -z "$actual" ]; then
|
||||||
|
actual=$(echo "$OUTPUT" | grep "^(ok $epoch " || true)
|
||||||
|
fi
|
||||||
|
if [ -z "$actual" ]; then
|
||||||
|
actual=$(echo "$OUTPUT" | grep "^(error $epoch " || true)
|
||||||
|
fi
|
||||||
|
if [ -z "$actual" ]; then
|
||||||
|
actual="<no output for epoch $epoch>"
|
||||||
|
fi
|
||||||
|
|
||||||
|
if echo "$actual" | grep -qF "$expected"; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
[ "$VERBOSE" = "-v" ] && echo " ✓ $desc"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS+=" ✗ $desc (epoch $epoch)
|
||||||
|
expected: $expected
|
||||||
|
actual: $actual
|
||||||
|
"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
# ── Parser assertions ─────────────────────────────────────────────
|
||||||
|
check 10 "on click basic" '(on "click" (add-class "red" (me)))'
|
||||||
|
check 11 "on click toggle" '(on "click" (toggle-class "active" (me)))'
|
||||||
|
check 12 "on click chain" '(on "click" (do (add-class "red" (me)) (remove-class "blue" (me))))'
|
||||||
|
check 13 "on click set prop" '(on "click" (set!'
|
||||||
|
check 14 "on click log" '(on "click" (log (me)))'
|
||||||
|
check 15 "add class cmd" '(add-class "highlight" (me))'
|
||||||
|
check 16 "remove class cmd" '(remove-class "highlight" (me))'
|
||||||
|
check 17 "toggle class cmd" '(toggle-class "visible" (me))'
|
||||||
|
check 18 "hide cmd" '(hide (me))'
|
||||||
|
check 19 "show cmd" '(show (me))'
|
||||||
|
check 20 "wait ms" '(wait 500)'
|
||||||
|
check 21 "wait seconds" '(wait 2000)'
|
||||||
|
check 22 "arithmetic add" '+'
|
||||||
|
check 23 "arithmetic mul" '*'
|
||||||
|
check 24 "init feature" '(init'
|
||||||
|
check 25 "set variable" '(set! (ref "x") 42)'
|
||||||
|
check 26 "put into" '(set! (me) "hello")'
|
||||||
|
check 27 "increment" 'increment'
|
||||||
|
check 28 "decrement" 'decrement'
|
||||||
|
check 29 "on every click" '(on'
|
||||||
|
check 30 "on click from" '(on'
|
||||||
|
|
||||||
|
# ── Compiler assertions ───────────────────────────────────────────
|
||||||
|
check 40 "compiled: on click" '(hs-on me "click"'
|
||||||
|
check 41 "compiled: toggle" 'hs-toggle-class!'
|
||||||
|
check 42 "compiled: set prop" 'dom-set-prop'
|
||||||
|
check 43 "compiled: chain" 'dom-remove-class'
|
||||||
|
|
||||||
|
# ── Report ────────────────────────────────────────────────────────
|
||||||
|
TOTAL=$((PASS + FAIL))
|
||||||
|
if [ $FAIL -eq 0 ]; then
|
||||||
|
echo "✓ $PASS/$TOTAL hyperscript tests passed"
|
||||||
|
else
|
||||||
|
echo "✗ $PASS/$TOTAL passed, $FAIL failed:"
|
||||||
|
echo ""
|
||||||
|
echo "$ERRORS"
|
||||||
|
fi
|
||||||
|
|
||||||
|
[ $FAIL -eq 0 ]
|
||||||
@@ -104,6 +104,7 @@
|
|||||||
"detail"
|
"detail"
|
||||||
"sender"
|
"sender"
|
||||||
"index"
|
"index"
|
||||||
|
"indexed"
|
||||||
"increment"
|
"increment"
|
||||||
"decrement"
|
"decrement"
|
||||||
"append"
|
"append"
|
||||||
@@ -116,7 +117,12 @@
|
|||||||
"first"
|
"first"
|
||||||
"last"
|
"last"
|
||||||
"random"
|
"random"
|
||||||
|
"pick"
|
||||||
"empty"
|
"empty"
|
||||||
|
"clear"
|
||||||
|
"swap"
|
||||||
|
"open"
|
||||||
|
"close"
|
||||||
"exists"
|
"exists"
|
||||||
"matches"
|
"matches"
|
||||||
"contains"
|
"contains"
|
||||||
@@ -139,7 +145,49 @@
|
|||||||
"behavior"
|
"behavior"
|
||||||
"called"
|
"called"
|
||||||
"render"
|
"render"
|
||||||
"eval"))
|
"eval"
|
||||||
|
"I"
|
||||||
|
"am"
|
||||||
|
"does"
|
||||||
|
"some"
|
||||||
|
"mod"
|
||||||
|
"equal"
|
||||||
|
"equals"
|
||||||
|
"really"
|
||||||
|
"include"
|
||||||
|
"includes"
|
||||||
|
"contain"
|
||||||
|
"undefined"
|
||||||
|
"exist"
|
||||||
|
"match"
|
||||||
|
"beep"
|
||||||
|
"where"
|
||||||
|
"sorted"
|
||||||
|
"mapped"
|
||||||
|
"split"
|
||||||
|
"joined"
|
||||||
|
"descending"
|
||||||
|
"ascending"
|
||||||
|
"scroll"
|
||||||
|
"select"
|
||||||
|
"reset"
|
||||||
|
"default"
|
||||||
|
"halt"
|
||||||
|
"precedes"
|
||||||
|
"precede"
|
||||||
|
"follow"
|
||||||
|
"follows"
|
||||||
|
"ignoring"
|
||||||
|
"case"
|
||||||
|
"changes"
|
||||||
|
"focus"
|
||||||
|
"blur"
|
||||||
|
"dom"
|
||||||
|
"morph"
|
||||||
|
"using"
|
||||||
|
"giving"
|
||||||
|
"ask"
|
||||||
|
"answer"))
|
||||||
|
|
||||||
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
|
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
|
||||||
|
|
||||||
@@ -207,6 +255,32 @@
|
|||||||
(hs-advance! 1)
|
(hs-advance! 1)
|
||||||
(read-frac))))
|
(read-frac))))
|
||||||
(read-frac))
|
(read-frac))
|
||||||
|
(do
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (hs-cur) "e") (= (hs-cur) "E"))
|
||||||
|
(or
|
||||||
|
(and (< (+ pos 1) src-len) (hs-digit? (hs-peek 1)))
|
||||||
|
(and
|
||||||
|
(< (+ pos 2) src-len)
|
||||||
|
(or (= (hs-peek 1) "+") (= (hs-peek 1) "-"))
|
||||||
|
(hs-digit? (hs-peek 2)))))
|
||||||
|
(hs-advance! 1)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (hs-cur) "+") (= (hs-cur) "-")))
|
||||||
|
(hs-advance! 1))
|
||||||
|
(define
|
||||||
|
read-exp-digits
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||||
|
(hs-advance! 1)
|
||||||
|
(read-exp-digits))))
|
||||||
|
(read-exp-digits))
|
||||||
(let
|
(let
|
||||||
((num-end pos))
|
((num-end pos))
|
||||||
(when
|
(when
|
||||||
@@ -220,7 +294,7 @@
|
|||||||
(= (hs-peek 1) "s"))
|
(= (hs-peek 1) "s"))
|
||||||
(hs-advance! 2)
|
(hs-advance! 2)
|
||||||
(when (= (hs-cur) "s") (hs-advance! 1))))
|
(when (= (hs-cur) "s") (hs-advance! 1))))
|
||||||
(slice src start pos))))
|
(slice src start pos)))))
|
||||||
(define
|
(define
|
||||||
read-string
|
read-string
|
||||||
(fn
|
(fn
|
||||||
@@ -345,12 +419,8 @@
|
|||||||
(or
|
(or
|
||||||
(hs-ident-char? (hs-cur))
|
(hs-ident-char? (hs-cur))
|
||||||
(= (hs-cur) ":")
|
(= (hs-cur) ":")
|
||||||
(= (hs-cur) "\\")
|
|
||||||
(= (hs-cur) "[")
|
(= (hs-cur) "[")
|
||||||
(= (hs-cur) "]")
|
(= (hs-cur) "]")))
|
||||||
(= (hs-cur) "(")
|
|
||||||
(= (hs-cur) ")")))
|
|
||||||
(when (= (hs-cur) "\\") (hs-advance! 1))
|
|
||||||
(hs-advance! 1)
|
(hs-advance! 1)
|
||||||
(read-class-name start))
|
(read-class-name start))
|
||||||
(slice src start pos)))
|
(slice src start pos)))
|
||||||
@@ -369,6 +439,8 @@
|
|||||||
(let
|
(let
|
||||||
((ch (hs-cur)) (start pos))
|
((ch (hs-cur)) (start pos))
|
||||||
(cond
|
(cond
|
||||||
|
(and (= ch "-") (< (+ pos 1) src-len) (= (hs-peek 1) "-"))
|
||||||
|
(do (hs-advance! 2) (skip-comment!) (scan!))
|
||||||
(and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/"))
|
(and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/"))
|
||||||
(do (hs-advance! 2) (skip-comment!) (scan!))
|
(do (hs-advance! 2) (skip-comment!) (scan!))
|
||||||
(and
|
(and
|
||||||
@@ -383,6 +455,8 @@
|
|||||||
(= (hs-peek 1) "*")
|
(= (hs-peek 1) "*")
|
||||||
(= (hs-peek 1) ":")))
|
(= (hs-peek 1) ":")))
|
||||||
(do (hs-emit! "selector" (read-selector) start) (scan!))
|
(do (hs-emit! "selector" (read-selector) start) (scan!))
|
||||||
|
(and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) "."))
|
||||||
|
(do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!))
|
||||||
(and
|
(and
|
||||||
(= ch ".")
|
(= ch ".")
|
||||||
(< (+ pos 1) src-len)
|
(< (+ pos 1) src-len)
|
||||||
@@ -410,6 +484,14 @@
|
|||||||
(hs-advance! 1)
|
(hs-advance! 1)
|
||||||
(hs-emit! "attr" (read-ident pos) start)
|
(hs-emit! "attr" (read-ident pos) start)
|
||||||
(scan!))
|
(scan!))
|
||||||
|
(and
|
||||||
|
(= ch "^")
|
||||||
|
(< (+ pos 1) src-len)
|
||||||
|
(hs-ident-char? (hs-peek 1)))
|
||||||
|
(do
|
||||||
|
(hs-advance! 1)
|
||||||
|
(hs-emit! "hat" (read-ident pos) start)
|
||||||
|
(scan!))
|
||||||
(and
|
(and
|
||||||
(= ch "~")
|
(= ch "~")
|
||||||
(< (+ pos 1) src-len)
|
(< (+ pos 1) src-len)
|
||||||
@@ -464,8 +546,13 @@
|
|||||||
(< (+ pos 1) src-len)
|
(< (+ pos 1) src-len)
|
||||||
(= (hs-peek 1) "="))
|
(= (hs-peek 1) "="))
|
||||||
(do
|
(do
|
||||||
(hs-emit! "op" (str ch "=") start)
|
(if
|
||||||
(hs-advance! 2)
|
(and
|
||||||
|
(or (= ch "=") (= ch "!"))
|
||||||
|
(< (+ pos 2) src-len)
|
||||||
|
(= (hs-peek 2) "="))
|
||||||
|
(do (hs-emit! "op" (str ch "==") start) (hs-advance! 3))
|
||||||
|
(do (hs-emit! "op" (str ch "=") start) (hs-advance! 2)))
|
||||||
(scan!))
|
(scan!))
|
||||||
(and
|
(and
|
||||||
(= ch "'")
|
(= ch "'")
|
||||||
@@ -527,6 +614,12 @@
|
|||||||
(do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!))
|
(do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!))
|
||||||
(= ch ".")
|
(= ch ".")
|
||||||
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
|
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
|
||||||
|
(= ch "\\")
|
||||||
|
(do (hs-emit! "op" "\\" start) (hs-advance! 1) (scan!))
|
||||||
|
(= ch ":")
|
||||||
|
(do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!))
|
||||||
|
(= ch "|")
|
||||||
|
(do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!))
|
||||||
:else (do (hs-advance! 1) (scan!)))))))
|
:else (do (hs-advance! 1) (scan!)))))))
|
||||||
(scan!)
|
(scan!)
|
||||||
(hs-emit! "eof" nil pos)
|
(hs-emit! "eof" nil pos)
|
||||||
|
|||||||
2
lib/js/.gitignore
vendored
Normal file
2
lib/js/.gitignore
vendored
Normal file
@@ -0,0 +1,2 @@
|
|||||||
|
test262-upstream/
|
||||||
|
.harness-cache/
|
||||||
130
lib/js/conformance.sh
Executable file
130
lib/js/conformance.sh
Executable file
@@ -0,0 +1,130 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# Cherry-picked test262 conformance runner for JS-on-SX.
|
||||||
|
# Walks lib/js/test262-slice/**/*.js, evaluates each via js-eval,
|
||||||
|
# and compares against the sibling .expected file (substring match).
|
||||||
|
#
|
||||||
|
# Usage:
|
||||||
|
# bash lib/js/conformance.sh # summary only
|
||||||
|
# bash lib/js/conformance.sh -v # per-test pass/fail
|
||||||
|
|
||||||
|
set -uo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
echo "ERROR: $SX_SERVER not found. Run: cd hosts/ocaml && dune build"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
VERBOSE="${1:-}"
|
||||||
|
SLICE_DIR="lib/js/test262-slice"
|
||||||
|
PASS=0
|
||||||
|
FAIL=0
|
||||||
|
ERRORS=""
|
||||||
|
|
||||||
|
# Find all .js fixtures (sorted for stable output).
|
||||||
|
# Skip README.md and similar.
|
||||||
|
mapfile -t FIXTURES < <(find "$SLICE_DIR" -type f -name '*.js' | sort)
|
||||||
|
|
||||||
|
if [ ${#FIXTURES[@]} -eq 0 ]; then
|
||||||
|
echo "No fixtures found in $SLICE_DIR"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
# Build one big batch script: load everything once, then one epoch per
|
||||||
|
# fixture. Avoids the ~200ms boot cost of starting the server for each
|
||||||
|
# test.
|
||||||
|
|
||||||
|
TMPFILE=$(mktemp)
|
||||||
|
trap "rm -f $TMPFILE" EXIT
|
||||||
|
|
||||||
|
{
|
||||||
|
echo '(epoch 1)'
|
||||||
|
echo '(load "lib/r7rs.sx")'
|
||||||
|
echo '(epoch 2)'
|
||||||
|
echo '(load "lib/js/lexer.sx")'
|
||||||
|
echo '(epoch 3)'
|
||||||
|
echo '(load "lib/js/parser.sx")'
|
||||||
|
echo '(epoch 4)'
|
||||||
|
echo '(load "lib/js/transpile.sx")'
|
||||||
|
echo '(epoch 5)'
|
||||||
|
echo '(load "lib/js/runtime.sx")'
|
||||||
|
|
||||||
|
epoch=100
|
||||||
|
for f in "${FIXTURES[@]}"; do
|
||||||
|
# Read source, strip trailing newline, then escape for *two*
|
||||||
|
# nested SX string literals: the outer epoch `(eval "…")` and
|
||||||
|
# the inner `(js-eval "…")` that it wraps.
|
||||||
|
#
|
||||||
|
# Source char → final stream char
|
||||||
|
# \ → \\\\ (outer: becomes \\ ; inner: becomes \)
|
||||||
|
# " → \\\" (outer: becomes \" ; inner: becomes ")
|
||||||
|
# nl → \\n (SX newline escape, survives both levels)
|
||||||
|
src=$(python3 -c '
|
||||||
|
import sys
|
||||||
|
s = open(sys.argv[1], "r", encoding="utf-8").read().rstrip("\n")
|
||||||
|
# Two nested SX string literals: outer eval wraps inner js-eval.
|
||||||
|
# Escape once for inner (JS source → SX inner string literal):
|
||||||
|
inner = s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n")
|
||||||
|
# Escape the result again for the outer SX string literal:
|
||||||
|
outer = inner.replace("\\", "\\\\").replace("\"", "\\\"")
|
||||||
|
sys.stdout.write(outer)
|
||||||
|
' "$f")
|
||||||
|
echo "(epoch $epoch)"
|
||||||
|
echo "(eval \"(js-eval \\\"$src\\\")\")"
|
||||||
|
epoch=$((epoch + 1))
|
||||||
|
done
|
||||||
|
} > "$TMPFILE"
|
||||||
|
|
||||||
|
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
||||||
|
|
||||||
|
# Iterate fixtures with the same epoch sequence and check each.
|
||||||
|
epoch=100
|
||||||
|
for f in "${FIXTURES[@]}"; do
|
||||||
|
expected=$(cat "${f%.js}.expected" | sed -e 's/[[:space:]]*$//' | head -n 1)
|
||||||
|
name="${f#${SLICE_DIR}/}"
|
||||||
|
name="${name%.js}"
|
||||||
|
|
||||||
|
# Actual output lives on the line after "(ok-len $epoch N)" or on
|
||||||
|
# "(ok $epoch VAL)" for short values. Errors surface as "(error …)".
|
||||||
|
actual=$(echo "$OUTPUT" | awk -v e="$epoch" '
|
||||||
|
$0 ~ ("^\\(ok-len "e" ") { getline; print; exit }
|
||||||
|
$0 ~ ("^\\(ok "e" ") { sub("^\\(ok "e" ", ""); sub(")$", ""); print; exit }
|
||||||
|
$0 ~ ("^\\(error "e" ") { print; exit }
|
||||||
|
')
|
||||||
|
[ -z "$actual" ] && actual="<no output>"
|
||||||
|
|
||||||
|
if echo "$actual" | grep -qF -- "$expected"; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
[ "$VERBOSE" = "-v" ] && echo " ✓ $name"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS+=" ✗ $name
|
||||||
|
expected: $expected
|
||||||
|
actual: $actual
|
||||||
|
"
|
||||||
|
[ "$VERBOSE" = "-v" ] && echo " ✗ $name (expected: $expected, actual: $actual)"
|
||||||
|
fi
|
||||||
|
|
||||||
|
epoch=$((epoch + 1))
|
||||||
|
done
|
||||||
|
|
||||||
|
TOTAL=$((PASS + FAIL))
|
||||||
|
PCT=$(awk "BEGIN{printf \"%.1f\", ($PASS/$TOTAL)*100}")
|
||||||
|
|
||||||
|
echo
|
||||||
|
if [ $FAIL -eq 0 ]; then
|
||||||
|
echo "✓ $PASS/$TOTAL test262-slice tests passed ($PCT%)"
|
||||||
|
else
|
||||||
|
echo "✗ $PASS/$TOTAL passed, $FAIL failed ($PCT%):"
|
||||||
|
[ "$VERBOSE" != "-v" ] && echo "$ERRORS"
|
||||||
|
fi
|
||||||
|
|
||||||
|
# Phase 5 target: ≥50% pass.
|
||||||
|
TARGET=50
|
||||||
|
if (( $(echo "$PCT >= $TARGET" | bc -l 2>/dev/null || python3 -c "print($PCT >= $TARGET)") )); then
|
||||||
|
exit 0
|
||||||
|
else
|
||||||
|
echo "(below target of ${TARGET}%)"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
609
lib/js/lexer.sx
Normal file
609
lib/js/lexer.sx
Normal file
@@ -0,0 +1,609 @@
|
|||||||
|
;; lib/js/lexer.sx — JavaScript source → token stream
|
||||||
|
;;
|
||||||
|
;; Tokens: {:type T :value V :pos P}
|
||||||
|
;; Types:
|
||||||
|
;; "number" — numeric literals (decoded into value as number)
|
||||||
|
;; "string" — string literals (decoded, escape sequences processed)
|
||||||
|
;; "template"— template literal body (no interpolation split yet — deferred)
|
||||||
|
;; "ident" — identifier (not a reserved word)
|
||||||
|
;; "keyword" — reserved word
|
||||||
|
;; "punct" — ( ) [ ] { } , ; : . ...
|
||||||
|
;; "op" — all operator tokens (incl. = == === !== < > etc.)
|
||||||
|
;; "eof" — end of input
|
||||||
|
;;
|
||||||
|
;; NOTE: `cond` clauses take exactly ONE body expression — multi-body
|
||||||
|
;; clauses must wrap their body in `(do ...)`.
|
||||||
|
|
||||||
|
;; ── Token constructor ─────────────────────────────────────────────
|
||||||
|
(define js-make-token (fn (type value pos) {:pos pos :value value :type type}))
|
||||||
|
|
||||||
|
;; ── Character predicates ──────────────────────────────────────────
|
||||||
|
(define js-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
js-hex-digit?
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(or
|
||||||
|
(js-digit? c)
|
||||||
|
(and (>= c "a") (<= c "f"))
|
||||||
|
(and (>= c "A") (<= c "F")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
js-letter?
|
||||||
|
(fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
|
||||||
|
|
||||||
|
(define js-ident-start? (fn (c) (or (js-letter? c) (= c "_") (= c "$"))))
|
||||||
|
|
||||||
|
(define js-ident-char? (fn (c) (or (js-ident-start? c) (js-digit? c))))
|
||||||
|
|
||||||
|
(define js-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||||
|
|
||||||
|
;; ── Reserved words ────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
js-keywords
|
||||||
|
(list
|
||||||
|
"break"
|
||||||
|
"case"
|
||||||
|
"catch"
|
||||||
|
"class"
|
||||||
|
"const"
|
||||||
|
"continue"
|
||||||
|
"debugger"
|
||||||
|
"default"
|
||||||
|
"delete"
|
||||||
|
"do"
|
||||||
|
"else"
|
||||||
|
"export"
|
||||||
|
"extends"
|
||||||
|
"false"
|
||||||
|
"finally"
|
||||||
|
"for"
|
||||||
|
"function"
|
||||||
|
"if"
|
||||||
|
"import"
|
||||||
|
"in"
|
||||||
|
"instanceof"
|
||||||
|
"new"
|
||||||
|
"null"
|
||||||
|
"return"
|
||||||
|
"super"
|
||||||
|
"switch"
|
||||||
|
"this"
|
||||||
|
"throw"
|
||||||
|
"true"
|
||||||
|
"try"
|
||||||
|
"typeof"
|
||||||
|
"undefined"
|
||||||
|
"var"
|
||||||
|
"void"
|
||||||
|
"while"
|
||||||
|
"with"
|
||||||
|
"yield"
|
||||||
|
"let"
|
||||||
|
"static"
|
||||||
|
"async"
|
||||||
|
"await"
|
||||||
|
"of"))
|
||||||
|
|
||||||
|
(define js-keyword? (fn (word) (contains? js-keywords word)))
|
||||||
|
|
||||||
|
;; ── Main tokenizer ────────────────────────────────────────────────
|
||||||
|
(define
|
||||||
|
js-tokenize
|
||||||
|
(fn
|
||||||
|
(src)
|
||||||
|
(let
|
||||||
|
((tokens (list)) (pos 0) (src-len (len src)))
|
||||||
|
(define
|
||||||
|
js-peek
|
||||||
|
(fn
|
||||||
|
(offset)
|
||||||
|
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||||
|
(define cur (fn () (js-peek 0)))
|
||||||
|
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||||
|
(define
|
||||||
|
at?
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((sl (len s)))
|
||||||
|
(and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
|
||||||
|
(define
|
||||||
|
js-emit!
|
||||||
|
(fn
|
||||||
|
(type value start)
|
||||||
|
(append! tokens (js-make-token type value start))))
|
||||||
|
(define
|
||||||
|
skip-line-comment!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (not (= (cur) "\n")))
|
||||||
|
(do (advance! 1) (skip-line-comment!)))))
|
||||||
|
(define
|
||||||
|
skip-block-comment!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((and (= (cur) "*") (< (+ pos 1) src-len) (= (js-peek 1) "/"))
|
||||||
|
(advance! 2))
|
||||||
|
(else (do (advance! 1) (skip-block-comment!))))))
|
||||||
|
(define
|
||||||
|
skip-ws!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((js-ws? (cur)) (do (advance! 1) (skip-ws!)))
|
||||||
|
((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "/"))
|
||||||
|
(do (advance! 2) (skip-line-comment!) (skip-ws!)))
|
||||||
|
((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "*"))
|
||||||
|
(do (advance! 2) (skip-block-comment!) (skip-ws!)))
|
||||||
|
(else nil))))
|
||||||
|
(define
|
||||||
|
read-ident
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(do
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (js-ident-char? (cur)))
|
||||||
|
(do (advance! 1) (read-ident start)))
|
||||||
|
(slice src start pos))))
|
||||||
|
(define
|
||||||
|
read-decimal-digits!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (js-digit? (cur)))
|
||||||
|
(do (advance! 1) (read-decimal-digits!)))))
|
||||||
|
(define
|
||||||
|
read-hex-digits!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (js-hex-digit? (cur)))
|
||||||
|
(do (advance! 1) (read-hex-digits!)))))
|
||||||
|
(define
|
||||||
|
read-exp-part!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (or (= (cur) "e") (= (cur) "E")))
|
||||||
|
(let
|
||||||
|
((p1 (js-peek 1)))
|
||||||
|
(when
|
||||||
|
(or
|
||||||
|
(and (not (= p1 nil)) (js-digit? p1))
|
||||||
|
(and
|
||||||
|
(or (= p1 "+") (= p1 "-"))
|
||||||
|
(< (+ pos 2) src-len)
|
||||||
|
(js-digit? (js-peek 2))))
|
||||||
|
(do
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(or (= (cur) "+") (= (cur) "-")))
|
||||||
|
(advance! 1))
|
||||||
|
(read-decimal-digits!)))))))
|
||||||
|
(define
|
||||||
|
read-number
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(cond
|
||||||
|
((and (= (cur) "0") (< (+ pos 1) src-len) (or (= (js-peek 1) "x") (= (js-peek 1) "X")))
|
||||||
|
(do
|
||||||
|
(advance! 2)
|
||||||
|
(read-hex-digits!)
|
||||||
|
(let
|
||||||
|
((raw (slice src (+ start 2) pos)))
|
||||||
|
(parse-number (str "0x" raw)))))
|
||||||
|
(else
|
||||||
|
(do
|
||||||
|
(read-decimal-digits!)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(< pos src-len)
|
||||||
|
(= (cur) ".")
|
||||||
|
(< (+ pos 1) src-len)
|
||||||
|
(js-digit? (js-peek 1)))
|
||||||
|
(do (advance! 1) (read-decimal-digits!)))
|
||||||
|
(read-exp-part!)
|
||||||
|
(parse-number (slice src start pos)))))))
|
||||||
|
(define
|
||||||
|
read-dot-number
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(do
|
||||||
|
(advance! 1)
|
||||||
|
(read-decimal-digits!)
|
||||||
|
(read-exp-part!)
|
||||||
|
(parse-number (slice src start pos)))))
|
||||||
|
(define
|
||||||
|
read-string
|
||||||
|
(fn
|
||||||
|
(quote-char)
|
||||||
|
(let
|
||||||
|
((chars (list)))
|
||||||
|
(advance! 1)
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (cur) "\\")
|
||||||
|
(do
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (cur)))
|
||||||
|
(do
|
||||||
|
(cond
|
||||||
|
((= ch "n") (append! chars "\n"))
|
||||||
|
((= ch "t") (append! chars "\t"))
|
||||||
|
((= ch "r") (append! chars "\r"))
|
||||||
|
((= ch "\\") (append! chars "\\"))
|
||||||
|
((= ch "'") (append! chars "'"))
|
||||||
|
((= ch "\"") (append! chars "\""))
|
||||||
|
((= ch "`") (append! chars "`"))
|
||||||
|
((= ch "0") (append! chars "\\0"))
|
||||||
|
((= ch "b") (append! chars "\\b"))
|
||||||
|
((= ch "f") (append! chars "\\f"))
|
||||||
|
((= ch "v") (append! chars "\\v"))
|
||||||
|
(else (append! chars ch)))
|
||||||
|
(advance! 1))))
|
||||||
|
(loop)))
|
||||||
|
((= (cur) quote-char) (advance! 1))
|
||||||
|
(else (do (append! chars (cur)) (advance! 1) (loop))))))
|
||||||
|
(loop)
|
||||||
|
(join "" chars))))
|
||||||
|
(define
|
||||||
|
read-template
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((parts (list)) (chars (list)))
|
||||||
|
(advance! 1)
|
||||||
|
(define
|
||||||
|
flush-chars!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(> (len chars) 0)
|
||||||
|
(do
|
||||||
|
(append! parts (list "str" (join "" chars)))
|
||||||
|
(set! chars (list))))))
|
||||||
|
(define
|
||||||
|
read-expr-source!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((buf (list)) (depth 1))
|
||||||
|
(define
|
||||||
|
expr-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((and (= (cur) "}") (= depth 1)) (advance! 1))
|
||||||
|
((= (cur) "}")
|
||||||
|
(do
|
||||||
|
(append! buf (cur))
|
||||||
|
(set! depth (- depth 1))
|
||||||
|
(advance! 1)
|
||||||
|
(expr-loop)))
|
||||||
|
((= (cur) "{")
|
||||||
|
(do
|
||||||
|
(append! buf (cur))
|
||||||
|
(set! depth (+ depth 1))
|
||||||
|
(advance! 1)
|
||||||
|
(expr-loop)))
|
||||||
|
((or (= (cur) "\"") (= (cur) "'"))
|
||||||
|
(let
|
||||||
|
((q (cur)))
|
||||||
|
(do
|
||||||
|
(append! buf q)
|
||||||
|
(advance! 1)
|
||||||
|
(define
|
||||||
|
sloop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (cur) "\\")
|
||||||
|
(do
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(do
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)))
|
||||||
|
(sloop)))
|
||||||
|
((= (cur) q)
|
||||||
|
(do (append! buf (cur)) (advance! 1)))
|
||||||
|
(else
|
||||||
|
(do
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(sloop))))))
|
||||||
|
(sloop)
|
||||||
|
(expr-loop))))
|
||||||
|
(else
|
||||||
|
(do (append! buf (cur)) (advance! 1) (expr-loop))))))
|
||||||
|
(expr-loop)
|
||||||
|
(join "" buf))))
|
||||||
|
(define
|
||||||
|
loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (cur) "`") (advance! 1))
|
||||||
|
((and (= (cur) "$") (< (+ pos 1) src-len) (= (js-peek 1) "{"))
|
||||||
|
(do
|
||||||
|
(flush-chars!)
|
||||||
|
(advance! 2)
|
||||||
|
(let
|
||||||
|
((src (read-expr-source!)))
|
||||||
|
(append! parts (list "expr" src)))
|
||||||
|
(loop)))
|
||||||
|
((= (cur) "\\")
|
||||||
|
(do
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (cur)))
|
||||||
|
(do
|
||||||
|
(cond
|
||||||
|
((= ch "n") (append! chars "\n"))
|
||||||
|
((= ch "t") (append! chars "\t"))
|
||||||
|
((= ch "r") (append! chars "\r"))
|
||||||
|
((= ch "\\") (append! chars "\\"))
|
||||||
|
((= ch "'") (append! chars "'"))
|
||||||
|
((= ch "\"") (append! chars "\""))
|
||||||
|
((= ch "`") (append! chars "`"))
|
||||||
|
((= ch "$") (append! chars "$"))
|
||||||
|
((= ch "0") (append! chars "0"))
|
||||||
|
((= ch "b") (append! chars "b"))
|
||||||
|
((= ch "f") (append! chars "f"))
|
||||||
|
((= ch "v") (append! chars "v"))
|
||||||
|
(else (append! chars ch)))
|
||||||
|
(advance! 1))))
|
||||||
|
(loop)))
|
||||||
|
(else (do (append! chars (cur)) (advance! 1) (loop))))))
|
||||||
|
(loop)
|
||||||
|
(flush-chars!)
|
||||||
|
(if
|
||||||
|
(= (len parts) 0)
|
||||||
|
""
|
||||||
|
(if
|
||||||
|
(and (= (len parts) 1) (= (nth (nth parts 0) 0) "str"))
|
||||||
|
(nth (nth parts 0) 1)
|
||||||
|
parts)))))
|
||||||
|
(define
|
||||||
|
js-regex-context?
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(if
|
||||||
|
(= (len tokens) 0)
|
||||||
|
true
|
||||||
|
(let
|
||||||
|
((tk (nth tokens (- (len tokens) 1))))
|
||||||
|
(let
|
||||||
|
((ty (dict-get tk "type")) (vv (dict-get tk "value")))
|
||||||
|
(cond
|
||||||
|
((= ty "punct")
|
||||||
|
(and (not (= vv ")")) (not (= vv "]"))))
|
||||||
|
((= ty "op") true)
|
||||||
|
((= ty "keyword")
|
||||||
|
(contains?
|
||||||
|
(list
|
||||||
|
"return"
|
||||||
|
"typeof"
|
||||||
|
"in"
|
||||||
|
"of"
|
||||||
|
"throw"
|
||||||
|
"new"
|
||||||
|
"delete"
|
||||||
|
"instanceof"
|
||||||
|
"void"
|
||||||
|
"yield"
|
||||||
|
"await"
|
||||||
|
"case"
|
||||||
|
"do"
|
||||||
|
"else")
|
||||||
|
vv))
|
||||||
|
(else false)))))))
|
||||||
|
(define
|
||||||
|
read-regex
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((buf (list)) (in-class false))
|
||||||
|
(advance! 1)
|
||||||
|
(define
|
||||||
|
body-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(cond
|
||||||
|
((>= pos src-len) nil)
|
||||||
|
((= (cur) "\\")
|
||||||
|
(begin
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(begin (append! buf (cur)) (advance! 1)))
|
||||||
|
(body-loop)))
|
||||||
|
((= (cur) "[")
|
||||||
|
(begin
|
||||||
|
(set! in-class true)
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(body-loop)))
|
||||||
|
((= (cur) "]")
|
||||||
|
(begin
|
||||||
|
(set! in-class false)
|
||||||
|
(append! buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(body-loop)))
|
||||||
|
((and (= (cur) "/") (not in-class)) (advance! 1))
|
||||||
|
(else
|
||||||
|
(begin (append! buf (cur)) (advance! 1) (body-loop))))))
|
||||||
|
(body-loop)
|
||||||
|
(let
|
||||||
|
((flags-buf (list)))
|
||||||
|
(define
|
||||||
|
flags-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(and (< pos src-len) (js-ident-char? (cur)))
|
||||||
|
(begin
|
||||||
|
(append! flags-buf (cur))
|
||||||
|
(advance! 1)
|
||||||
|
(flags-loop)))))
|
||||||
|
(flags-loop)
|
||||||
|
{:pattern (join "" buf) :flags (join "" flags-buf)}))))
|
||||||
|
(define
|
||||||
|
try-op-4!
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(cond
|
||||||
|
((at? ">>>=")
|
||||||
|
(do (js-emit! "op" ">>>=" start) (advance! 4) true))
|
||||||
|
(else false))))
|
||||||
|
(define
|
||||||
|
try-op-3!
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(cond
|
||||||
|
((at? "===")
|
||||||
|
(do (js-emit! "op" "===" start) (advance! 3) true))
|
||||||
|
((at? "!==")
|
||||||
|
(do (js-emit! "op" "!==" start) (advance! 3) true))
|
||||||
|
((at? "**=")
|
||||||
|
(do (js-emit! "op" "**=" start) (advance! 3) true))
|
||||||
|
((at? "<<=")
|
||||||
|
(do (js-emit! "op" "<<=" start) (advance! 3) true))
|
||||||
|
((at? ">>=")
|
||||||
|
(do (js-emit! "op" ">>=" start) (advance! 3) true))
|
||||||
|
((at? ">>>")
|
||||||
|
(do (js-emit! "op" ">>>" start) (advance! 3) true))
|
||||||
|
((at? "&&=")
|
||||||
|
(do (js-emit! "op" "&&=" start) (advance! 3) true))
|
||||||
|
((at? "||=")
|
||||||
|
(do (js-emit! "op" "||=" start) (advance! 3) true))
|
||||||
|
((at? "??=")
|
||||||
|
(do (js-emit! "op" "??=" start) (advance! 3) true))
|
||||||
|
((at? "...")
|
||||||
|
(do (js-emit! "punct" "..." start) (advance! 3) true))
|
||||||
|
(else false))))
|
||||||
|
(define
|
||||||
|
try-op-2!
|
||||||
|
(fn
|
||||||
|
(start)
|
||||||
|
(cond
|
||||||
|
((at? "==") (do (js-emit! "op" "==" start) (advance! 2) true))
|
||||||
|
((at? "!=") (do (js-emit! "op" "!=" start) (advance! 2) true))
|
||||||
|
((at? "<=") (do (js-emit! "op" "<=" start) (advance! 2) true))
|
||||||
|
((at? ">=") (do (js-emit! "op" ">=" start) (advance! 2) true))
|
||||||
|
((at? "&&") (do (js-emit! "op" "&&" start) (advance! 2) true))
|
||||||
|
((at? "||") (do (js-emit! "op" "||" start) (advance! 2) true))
|
||||||
|
((at? "??") (do (js-emit! "op" "??" start) (advance! 2) true))
|
||||||
|
((at? "=>") (do (js-emit! "op" "=>" start) (advance! 2) true))
|
||||||
|
((at? "**") (do (js-emit! "op" "**" start) (advance! 2) true))
|
||||||
|
((at? "<<") (do (js-emit! "op" "<<" start) (advance! 2) true))
|
||||||
|
((at? ">>") (do (js-emit! "op" ">>" start) (advance! 2) true))
|
||||||
|
((at? "++") (do (js-emit! "op" "++" start) (advance! 2) true))
|
||||||
|
((at? "--") (do (js-emit! "op" "--" start) (advance! 2) true))
|
||||||
|
((at? "+=") (do (js-emit! "op" "+=" start) (advance! 2) true))
|
||||||
|
((at? "-=") (do (js-emit! "op" "-=" start) (advance! 2) true))
|
||||||
|
((at? "*=") (do (js-emit! "op" "*=" start) (advance! 2) true))
|
||||||
|
((at? "/=") (do (js-emit! "op" "/=" start) (advance! 2) true))
|
||||||
|
((at? "%=") (do (js-emit! "op" "%=" start) (advance! 2) true))
|
||||||
|
((at? "&=") (do (js-emit! "op" "&=" start) (advance! 2) true))
|
||||||
|
((at? "|=") (do (js-emit! "op" "|=" start) (advance! 2) true))
|
||||||
|
((at? "^=") (do (js-emit! "op" "^=" start) (advance! 2) true))
|
||||||
|
((at? "?.") (do (js-emit! "op" "?." start) (advance! 2) true))
|
||||||
|
(else false))))
|
||||||
|
(define
|
||||||
|
emit-one-op!
|
||||||
|
(fn
|
||||||
|
(ch start)
|
||||||
|
(cond
|
||||||
|
((= ch "(") (do (js-emit! "punct" "(" start) (advance! 1)))
|
||||||
|
((= ch ")") (do (js-emit! "punct" ")" start) (advance! 1)))
|
||||||
|
((= ch "[") (do (js-emit! "punct" "[" start) (advance! 1)))
|
||||||
|
((= ch "]") (do (js-emit! "punct" "]" start) (advance! 1)))
|
||||||
|
((= ch "{") (do (js-emit! "punct" "{" start) (advance! 1)))
|
||||||
|
((= ch "}") (do (js-emit! "punct" "}" start) (advance! 1)))
|
||||||
|
((= ch ",") (do (js-emit! "punct" "," start) (advance! 1)))
|
||||||
|
((= ch ";") (do (js-emit! "punct" ";" start) (advance! 1)))
|
||||||
|
((= ch ":") (do (js-emit! "punct" ":" start) (advance! 1)))
|
||||||
|
((= ch ".") (do (js-emit! "punct" "." start) (advance! 1)))
|
||||||
|
((= ch "?") (do (js-emit! "op" "?" start) (advance! 1)))
|
||||||
|
((= ch "+") (do (js-emit! "op" "+" start) (advance! 1)))
|
||||||
|
((= ch "-") (do (js-emit! "op" "-" start) (advance! 1)))
|
||||||
|
((= ch "*") (do (js-emit! "op" "*" start) (advance! 1)))
|
||||||
|
((= ch "/") (do (js-emit! "op" "/" start) (advance! 1)))
|
||||||
|
((= ch "%") (do (js-emit! "op" "%" start) (advance! 1)))
|
||||||
|
((= ch "=") (do (js-emit! "op" "=" start) (advance! 1)))
|
||||||
|
((= ch "<") (do (js-emit! "op" "<" start) (advance! 1)))
|
||||||
|
((= ch ">") (do (js-emit! "op" ">" start) (advance! 1)))
|
||||||
|
((= ch "!") (do (js-emit! "op" "!" start) (advance! 1)))
|
||||||
|
((= ch "&") (do (js-emit! "op" "&" start) (advance! 1)))
|
||||||
|
((= ch "|") (do (js-emit! "op" "|" start) (advance! 1)))
|
||||||
|
((= ch "^") (do (js-emit! "op" "^" start) (advance! 1)))
|
||||||
|
((= ch "~") (do (js-emit! "op" "~" start) (advance! 1)))
|
||||||
|
(else (advance! 1)))))
|
||||||
|
(define
|
||||||
|
scan!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(do
|
||||||
|
(skip-ws!)
|
||||||
|
(when
|
||||||
|
(< pos src-len)
|
||||||
|
(let
|
||||||
|
((ch (cur)) (start pos))
|
||||||
|
(cond
|
||||||
|
((or (= ch "\"") (= ch "'"))
|
||||||
|
(do (js-emit! "string" (read-string ch) start) (scan!)))
|
||||||
|
((= ch "`")
|
||||||
|
(do (js-emit! "template" (read-template) start) (scan!)))
|
||||||
|
((js-digit? ch)
|
||||||
|
(do
|
||||||
|
(js-emit! "number" (read-number start) start)
|
||||||
|
(scan!)))
|
||||||
|
((and (= ch ".") (< (+ pos 1) src-len) (js-digit? (js-peek 1)))
|
||||||
|
(do
|
||||||
|
(js-emit! "number" (read-dot-number start) start)
|
||||||
|
(scan!)))
|
||||||
|
((js-ident-start? ch)
|
||||||
|
(do
|
||||||
|
(let
|
||||||
|
((word (read-ident start)))
|
||||||
|
(js-emit!
|
||||||
|
(if (js-keyword? word) "keyword" "ident")
|
||||||
|
word
|
||||||
|
start))
|
||||||
|
(scan!)))
|
||||||
|
((and (= ch "/") (js-regex-context?))
|
||||||
|
(let
|
||||||
|
((rx (read-regex)))
|
||||||
|
(js-emit! "regex" rx start)
|
||||||
|
(scan!)))
|
||||||
|
((try-op-4! start) (scan!))
|
||||||
|
((try-op-3! start) (scan!))
|
||||||
|
((try-op-2! start) (scan!))
|
||||||
|
(else (do (emit-one-op! ch start) (scan!)))))))))
|
||||||
|
(scan!)
|
||||||
|
(js-emit! "eof" nil pos)
|
||||||
|
tokens)))
|
||||||
1430
lib/js/parser.sx
Normal file
1430
lib/js/parser.sx
Normal file
File diff suppressed because it is too large
Load Diff
3856
lib/js/runtime.sx
Normal file
3856
lib/js/runtime.sx
Normal file
File diff suppressed because it is too large
Load Diff
2054
lib/js/test.sh
Executable file
2054
lib/js/test.sh
Executable file
File diff suppressed because it is too large
Load Diff
1268
lib/js/test262-runner.py
Normal file
1268
lib/js/test262-runner.py
Normal file
File diff suppressed because it is too large
Load Diff
313
lib/js/test262-scoreboard-wide.json
Normal file
313
lib/js/test262-scoreboard-wide.json
Normal file
@@ -0,0 +1,313 @@
|
|||||||
|
{
|
||||||
|
"totals": {
|
||||||
|
"pass": 259,
|
||||||
|
"fail": 4768,
|
||||||
|
"skip": 2534,
|
||||||
|
"timeout": 327,
|
||||||
|
"total": 7888,
|
||||||
|
"runnable": 5354,
|
||||||
|
"pass_rate": 4.8
|
||||||
|
},
|
||||||
|
"categories": [
|
||||||
|
{
|
||||||
|
"category": "built-ins/Array",
|
||||||
|
"total": 3081,
|
||||||
|
"pass": 58,
|
||||||
|
"fail": 2524,
|
||||||
|
"skip": 351,
|
||||||
|
"timeout": 148,
|
||||||
|
"pass_rate": 2.1,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
785
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: {:length 3 :0 41 :1 42 :2 43} (kont=5 frames)\"",
|
||||||
|
455
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Unhandled exception: \\\\\\",
|
||||||
|
420
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
284
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
148
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/ArrayBuffer",
|
||||||
|
"total": 196,
|
||||||
|
"pass": 0,
|
||||||
|
"fail": 0,
|
||||||
|
"skip": 196,
|
||||||
|
"timeout": 0,
|
||||||
|
"pass_rate": 0.0,
|
||||||
|
"top_failures": []
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/ArrayIteratorPrototype",
|
||||||
|
"total": 27,
|
||||||
|
"pass": 0,
|
||||||
|
"fail": 0,
|
||||||
|
"skip": 27,
|
||||||
|
"timeout": 0,
|
||||||
|
"pass_rate": 0.0,
|
||||||
|
"top_failures": []
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/Math",
|
||||||
|
"total": 327,
|
||||||
|
"pass": 65,
|
||||||
|
"fail": 211,
|
||||||
|
"skip": 39,
|
||||||
|
"timeout": 12,
|
||||||
|
"pass_rate": 22.6,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
87
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
80
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
31
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
12
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:isArray <js-array-is-array(v)> :of <js-array",
|
||||||
|
11
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/Number",
|
||||||
|
"total": 340,
|
||||||
|
"pass": 9,
|
||||||
|
"fail": 252,
|
||||||
|
"skip": 57,
|
||||||
|
"timeout": 22,
|
||||||
|
"pass_rate": 3.2,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
72
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:isFinite <js-number-is-finite(v)> :MAX_SAFE_",
|
||||||
|
56
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
49
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: expected ident after .\\",
|
||||||
|
38
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
22
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/String",
|
||||||
|
"total": 1223,
|
||||||
|
"pass": 73,
|
||||||
|
"fail": 847,
|
||||||
|
"skip": 192,
|
||||||
|
"timeout": 111,
|
||||||
|
"pass_rate": 7.1,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: \\\\\\",
|
||||||
|
152
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest",
|
||||||
|
133
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
124
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
117
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: \\\"js-undefined\\\" (kont=10 frames)\"",
|
||||||
|
117
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/StringIteratorPrototype",
|
||||||
|
"total": 7,
|
||||||
|
"pass": 0,
|
||||||
|
"fail": 0,
|
||||||
|
"skip": 7,
|
||||||
|
"timeout": 0,
|
||||||
|
"pass_rate": 0.0,
|
||||||
|
"top_failures": []
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "language/expressions",
|
||||||
|
"total": 95,
|
||||||
|
"pass": 14,
|
||||||
|
"fail": 36,
|
||||||
|
"skip": 29,
|
||||||
|
"timeout": 16,
|
||||||
|
"pass_rate": 21.2,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
16
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
14
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
12
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest",
|
||||||
|
3
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:entries <js-object-entries(o)> :values <js-o",
|
||||||
|
2
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "language/statements",
|
||||||
|
"total": 2592,
|
||||||
|
"pass": 40,
|
||||||
|
"fail": 898,
|
||||||
|
"skip": 1636,
|
||||||
|
"timeout": 18,
|
||||||
|
"pass_rate": 4.2,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"SyntaxError (parse/unsupported syntax)",
|
||||||
|
387
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: expected ident in arr pattern\\",
|
||||||
|
112
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: \\\"ud801\\\" (kont=6 frames)\"",
|
||||||
|
49
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"negative: expected SyntaxError, got: \"Unhandled exception: \\\"expected ident in arr pattern\\\"\"",
|
||||||
|
36
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
33
|
||||||
|
]
|
||||||
|
]
|
||||||
|
}
|
||||||
|
],
|
||||||
|
"top_failure_modes": [
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
1056
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
514
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: {:length 3 :0 41 :1 42 :2 43} (kont=5 frames)\"",
|
||||||
|
455
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"SyntaxError (parse/unsupported syntax)",
|
||||||
|
454
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Unhandled exception: \\\\\\",
|
||||||
|
438
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
327
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
322
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: \\\\\\",
|
||||||
|
160
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest",
|
||||||
|
147
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Unexpected token: punct ','\\",
|
||||||
|
125
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: \\\"js-undefined\\\" (kont=10 frames)\"",
|
||||||
|
117
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: expected ident in arr pattern\\",
|
||||||
|
112
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: js-transpile-unop: unsupported op: delete\\",
|
||||||
|
104
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:isFinite <js-number-is-finite(v)> :MAX_SAFE_",
|
||||||
|
74
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:sameValue <lambda(actual, expected, message)",
|
||||||
|
63
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Other: \"Not callable: \\\"ud801\\\" (kont=6 frames)\"",
|
||||||
|
49
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:isArray <js-array-is-array(v)> :of <js-array",
|
||||||
|
46
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: expected ident after .\\",
|
||||||
|
45
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Unexpected token: op '++'\\",
|
||||||
|
39
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"negative: expected SyntaxError, got: \"Unhandled exception: \\\"expected ident in arr pattern\\\"\"",
|
||||||
|
36
|
||||||
|
]
|
||||||
|
],
|
||||||
|
"pinned_commit": "d5e73fc8d2c663554fb72e2380a8c2bc1a318a33",
|
||||||
|
"elapsed_seconds": 9007.6
|
||||||
|
}
|
||||||
90
lib/js/test262-scoreboard-wide.md
Normal file
90
lib/js/test262-scoreboard-wide.md
Normal file
@@ -0,0 +1,90 @@
|
|||||||
|
# test262 scoreboard
|
||||||
|
|
||||||
|
Pinned commit: `d5e73fc8d2c663554fb72e2380a8c2bc1a318a33`
|
||||||
|
Wall time: 9007.6s
|
||||||
|
|
||||||
|
**Total:** 259/5354 runnable passed (4.8%). Raw: pass=259 fail=4768 skip=2534 timeout=327 total=7888.
|
||||||
|
|
||||||
|
## Top failure modes
|
||||||
|
|
||||||
|
- **1056x** ReferenceError (undefined symbol)
|
||||||
|
- **514x** TypeError: not a function
|
||||||
|
- **455x** Other: "Not callable: {:length 3 :0 41 :1 42 :2 43} (kont=5 frames)"
|
||||||
|
- **454x** SyntaxError (parse/unsupported syntax)
|
||||||
|
- **438x** Unhandled: Unhandled exception: \\\
|
||||||
|
- **327x** Timeout
|
||||||
|
- **322x** Test262Error (assertion failed)
|
||||||
|
- **160x** Unhandled: Not callable: \\\
|
||||||
|
- **147x** Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest
|
||||||
|
- **125x** Unhandled: Unexpected token: punct ','\
|
||||||
|
- **117x** Other: "Not callable: \"js-undefined\" (kont=10 frames)"
|
||||||
|
- **112x** Unhandled: expected ident in arr pattern\
|
||||||
|
- **104x** Unhandled: js-transpile-unop: unsupported op: delete\
|
||||||
|
- **74x** Unhandled: Not callable: {:isFinite <js-number-is-finite(v)> :MAX_SAFE_
|
||||||
|
- **63x** Unhandled: Not callable: {:sameValue <lambda(actual, expected, message)
|
||||||
|
- **49x** Other: "Not callable: \"ud801\" (kont=6 frames)"
|
||||||
|
- **46x** Unhandled: Not callable: {:isArray <js-array-is-array(v)> :of <js-array
|
||||||
|
- **45x** Unhandled: expected ident after .\
|
||||||
|
- **39x** Unhandled: Unexpected token: op '++'\
|
||||||
|
- **36x** negative: expected SyntaxError, got: "Unhandled exception: \"expected ident in arr pattern\""
|
||||||
|
|
||||||
|
## Categories (worst pass-rate first, min 10 runnable)
|
||||||
|
|
||||||
|
| Category | Pass | Fail | Skip | Timeout | Total | Pass % |
|
||||||
|
|---|---:|---:|---:|---:|---:|---:|
|
||||||
|
| built-ins/Array | 58 | 2524 | 351 | 148 | 3081 | 2.1% |
|
||||||
|
| built-ins/Number | 9 | 252 | 57 | 22 | 340 | 3.2% |
|
||||||
|
| language/statements | 40 | 898 | 1636 | 18 | 2592 | 4.2% |
|
||||||
|
| built-ins/String | 73 | 847 | 192 | 111 | 1223 | 7.1% |
|
||||||
|
| language/expressions | 14 | 36 | 29 | 16 | 95 | 21.2% |
|
||||||
|
| built-ins/Math | 65 | 211 | 39 | 12 | 327 | 22.6% |
|
||||||
|
|
||||||
|
## Per-category top failures (min 10 runnable, worst first)
|
||||||
|
|
||||||
|
### built-ins/Array (58/2730 — 2.1%)
|
||||||
|
|
||||||
|
- **785x** ReferenceError (undefined symbol)
|
||||||
|
- **455x** Other: "Not callable: {:length 3 :0 41 :1 42 :2 43} (kont=5 frames)"
|
||||||
|
- **420x** Unhandled: Unhandled exception: \\\
|
||||||
|
- **284x** TypeError: not a function
|
||||||
|
- **148x** Timeout
|
||||||
|
|
||||||
|
### built-ins/Number (9/283 — 3.2%)
|
||||||
|
|
||||||
|
- **72x** TypeError: not a function
|
||||||
|
- **56x** Unhandled: Not callable: {:isFinite <js-number-is-finite(v)> :MAX_SAFE_
|
||||||
|
- **49x** ReferenceError (undefined symbol)
|
||||||
|
- **38x** Unhandled: expected ident after .\
|
||||||
|
- **22x** Timeout
|
||||||
|
|
||||||
|
### language/statements (40/956 — 4.2%)
|
||||||
|
|
||||||
|
- **387x** SyntaxError (parse/unsupported syntax)
|
||||||
|
- **112x** Unhandled: expected ident in arr pattern\
|
||||||
|
- **49x** Other: "Not callable: \"ud801\" (kont=6 frames)"
|
||||||
|
- **36x** negative: expected SyntaxError, got: "Unhandled exception: \"expected ident in arr pattern\""
|
||||||
|
- **33x** ReferenceError (undefined symbol)
|
||||||
|
|
||||||
|
### built-ins/String (73/1031 — 7.1%)
|
||||||
|
|
||||||
|
- **152x** Unhandled: Not callable: \\\
|
||||||
|
- **133x** Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest
|
||||||
|
- **124x** Test262Error (assertion failed)
|
||||||
|
- **117x** TypeError: not a function
|
||||||
|
- **117x** Other: "Not callable: \"js-undefined\" (kont=10 frames)"
|
||||||
|
|
||||||
|
### language/expressions (14/66 — 21.2%)
|
||||||
|
|
||||||
|
- **16x** Timeout
|
||||||
|
- **14x** ReferenceError (undefined symbol)
|
||||||
|
- **12x** Test262Error (assertion failed)
|
||||||
|
- **3x** Unhandled: Not callable: {:fromCharCode <js-string-from-char-code(&rest
|
||||||
|
- **2x** Unhandled: Not callable: {:entries <js-object-entries(o)> :values <js-o
|
||||||
|
|
||||||
|
### built-ins/Math (65/288 — 22.6%)
|
||||||
|
|
||||||
|
- **87x** ReferenceError (undefined symbol)
|
||||||
|
- **80x** Test262Error (assertion failed)
|
||||||
|
- **31x** TypeError: not a function
|
||||||
|
- **12x** Timeout
|
||||||
|
- **11x** Unhandled: Not callable: {:isArray <js-array-is-array(v)> :of <js-array
|
||||||
137
lib/js/test262-scoreboard.json
Normal file
137
lib/js/test262-scoreboard.json
Normal file
@@ -0,0 +1,137 @@
|
|||||||
|
{
|
||||||
|
"totals": {
|
||||||
|
"pass": 162,
|
||||||
|
"fail": 128,
|
||||||
|
"skip": 1597,
|
||||||
|
"timeout": 10,
|
||||||
|
"total": 1897,
|
||||||
|
"runnable": 300,
|
||||||
|
"pass_rate": 54.0
|
||||||
|
},
|
||||||
|
"categories": [
|
||||||
|
{
|
||||||
|
"category": "built-ins/Math",
|
||||||
|
"total": 327,
|
||||||
|
"pass": 43,
|
||||||
|
"fail": 56,
|
||||||
|
"skip": 227,
|
||||||
|
"timeout": 1,
|
||||||
|
"pass_rate": 43.0,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
36
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
20
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
1
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/Number",
|
||||||
|
"total": 340,
|
||||||
|
"pass": 77,
|
||||||
|
"fail": 19,
|
||||||
|
"skip": 240,
|
||||||
|
"timeout": 4,
|
||||||
|
"pass_rate": 77.0,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
19
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
4
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/String",
|
||||||
|
"total": 1223,
|
||||||
|
"pass": 42,
|
||||||
|
"fail": 53,
|
||||||
|
"skip": 1123,
|
||||||
|
"timeout": 5,
|
||||||
|
"pass_rate": 42.0,
|
||||||
|
"top_failures": [
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
44
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
5
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
2
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
|
||||||
|
2
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: \\\\\\",
|
||||||
|
2
|
||||||
|
]
|
||||||
|
]
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"category": "built-ins/StringIteratorPrototype",
|
||||||
|
"total": 7,
|
||||||
|
"pass": 0,
|
||||||
|
"fail": 0,
|
||||||
|
"skip": 7,
|
||||||
|
"timeout": 0,
|
||||||
|
"pass_rate": 0.0,
|
||||||
|
"top_failures": []
|
||||||
|
}
|
||||||
|
],
|
||||||
|
"top_failure_modes": [
|
||||||
|
[
|
||||||
|
"Test262Error (assertion failed)",
|
||||||
|
83
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"TypeError: not a function",
|
||||||
|
36
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Timeout",
|
||||||
|
10
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"ReferenceError (undefined symbol)",
|
||||||
|
2
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
|
||||||
|
2
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: \\\\\\",
|
||||||
|
2
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"SyntaxError (parse/unsupported syntax)",
|
||||||
|
1
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn",
|
||||||
|
1
|
||||||
|
],
|
||||||
|
[
|
||||||
|
"Unhandled: js-transpile-binop: unsupported op: >>>\\",
|
||||||
|
1
|
||||||
|
]
|
||||||
|
],
|
||||||
|
"pinned_commit": "d5e73fc8d2c663554fb72e2380a8c2bc1a318a33",
|
||||||
|
"elapsed_seconds": 274.5,
|
||||||
|
"workers": 1
|
||||||
|
}
|
||||||
47
lib/js/test262-scoreboard.md
Normal file
47
lib/js/test262-scoreboard.md
Normal file
@@ -0,0 +1,47 @@
|
|||||||
|
# test262 scoreboard
|
||||||
|
|
||||||
|
Pinned commit: `d5e73fc8d2c663554fb72e2380a8c2bc1a318a33`
|
||||||
|
Wall time: 274.5s
|
||||||
|
|
||||||
|
**Total:** 162/300 runnable passed (54.0%). Raw: pass=162 fail=128 skip=1597 timeout=10 total=1897.
|
||||||
|
|
||||||
|
## Top failure modes
|
||||||
|
|
||||||
|
- **83x** Test262Error (assertion failed)
|
||||||
|
- **36x** TypeError: not a function
|
||||||
|
- **10x** Timeout
|
||||||
|
- **2x** ReferenceError (undefined symbol)
|
||||||
|
- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
|
||||||
|
- **2x** Unhandled: Not callable: \\\
|
||||||
|
- **1x** SyntaxError (parse/unsupported syntax)
|
||||||
|
- **1x** Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn
|
||||||
|
- **1x** Unhandled: js-transpile-binop: unsupported op: >>>\
|
||||||
|
|
||||||
|
## Categories (worst pass-rate first, min 10 runnable)
|
||||||
|
|
||||||
|
| Category | Pass | Fail | Skip | Timeout | Total | Pass % |
|
||||||
|
|---|---:|---:|---:|---:|---:|---:|
|
||||||
|
| built-ins/String | 42 | 53 | 1123 | 5 | 1223 | 42.0% |
|
||||||
|
| built-ins/Math | 43 | 56 | 227 | 1 | 327 | 43.0% |
|
||||||
|
| built-ins/Number | 77 | 19 | 240 | 4 | 340 | 77.0% |
|
||||||
|
|
||||||
|
## Per-category top failures (min 10 runnable, worst first)
|
||||||
|
|
||||||
|
### built-ins/String (42/100 — 42.0%)
|
||||||
|
|
||||||
|
- **44x** Test262Error (assertion failed)
|
||||||
|
- **5x** Timeout
|
||||||
|
- **2x** ReferenceError (undefined symbol)
|
||||||
|
- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
|
||||||
|
- **2x** Unhandled: Not callable: \\\
|
||||||
|
|
||||||
|
### built-ins/Math (43/100 — 43.0%)
|
||||||
|
|
||||||
|
- **36x** TypeError: not a function
|
||||||
|
- **20x** Test262Error (assertion failed)
|
||||||
|
- **1x** Timeout
|
||||||
|
|
||||||
|
### built-ins/Number (77/100 — 77.0%)
|
||||||
|
|
||||||
|
- **19x** Test262Error (assertion failed)
|
||||||
|
- **4x** Timeout
|
||||||
31
lib/js/test262-slice/README.md
Normal file
31
lib/js/test262-slice/README.md
Normal file
@@ -0,0 +1,31 @@
|
|||||||
|
# JS-on-SX cherry-picked conformance slice
|
||||||
|
|
||||||
|
A hand-picked slice inspired by test262 expression tests. Each test is one
|
||||||
|
JS expression in a `.js` file, paired with an `.expected` file containing
|
||||||
|
the SX-printed result that `js-eval` should produce.
|
||||||
|
|
||||||
|
Run via:
|
||||||
|
|
||||||
|
bash lib/js/conformance.sh
|
||||||
|
|
||||||
|
The slice intentionally avoids anything not yet implemented (statements,
|
||||||
|
`var`/`let`, `function`, regex, template strings, prototypes, `new`,
|
||||||
|
`this`, classes, async). Those land in later phases.
|
||||||
|
|
||||||
|
## Expected value format
|
||||||
|
|
||||||
|
`js-eval` returns SX values. The epoch protocol prints them thus:
|
||||||
|
|
||||||
|
| JS value | Expected file contents |
|
||||||
|
|------------------|-----------------------|
|
||||||
|
| `42` | `42` |
|
||||||
|
| `3.14` | `3.14` |
|
||||||
|
| `true` / `false` | `true` / `false` |
|
||||||
|
| `"hi"` | `"hi"` |
|
||||||
|
| `null` | `nil` |
|
||||||
|
| `undefined` | `"js-undefined"` |
|
||||||
|
| `[1,2,3]` | `(1 2 3)` |
|
||||||
|
| `{}` | `{}` |
|
||||||
|
|
||||||
|
The runner does a substring match — the `.expected` file can contain just
|
||||||
|
the distinguishing part of the result.
|
||||||
1
lib/js/test262-slice/arithmetic/add.expected
Normal file
1
lib/js/test262-slice/arithmetic/add.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
3
|
||||||
1
lib/js/test262-slice/arithmetic/add.js
Normal file
1
lib/js/test262-slice/arithmetic/add.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1 + 2
|
||||||
1
lib/js/test262-slice/arithmetic/big_expr.expected
Normal file
1
lib/js/test262-slice/arithmetic/big_expr.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
5
|
||||||
1
lib/js/test262-slice/arithmetic/big_expr.js
Normal file
1
lib/js/test262-slice/arithmetic/big_expr.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1 + 2 * 3 - 4 / 2
|
||||||
1
lib/js/test262-slice/arithmetic/bitnot.expected
Normal file
1
lib/js/test262-slice/arithmetic/bitnot.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
-6
|
||||||
1
lib/js/test262-slice/arithmetic/bitnot.js
Normal file
1
lib/js/test262-slice/arithmetic/bitnot.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
~5
|
||||||
1
lib/js/test262-slice/arithmetic/chained.expected
Normal file
1
lib/js/test262-slice/arithmetic/chained.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
10
|
||||||
1
lib/js/test262-slice/arithmetic/chained.js
Normal file
1
lib/js/test262-slice/arithmetic/chained.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1 + 2 + 3 + 4
|
||||||
1
lib/js/test262-slice/arithmetic/div.expected
Normal file
1
lib/js/test262-slice/arithmetic/div.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
3
|
||||||
1
lib/js/test262-slice/arithmetic/div.js
Normal file
1
lib/js/test262-slice/arithmetic/div.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
12 / 4
|
||||||
1
lib/js/test262-slice/arithmetic/mixed_concat.expected
Normal file
1
lib/js/test262-slice/arithmetic/mixed_concat.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
"12"
|
||||||
1
lib/js/test262-slice/arithmetic/mixed_concat.js
Normal file
1
lib/js/test262-slice/arithmetic/mixed_concat.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1 + "2"
|
||||||
1
lib/js/test262-slice/arithmetic/mod.expected
Normal file
1
lib/js/test262-slice/arithmetic/mod.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1
|
||||||
1
lib/js/test262-slice/arithmetic/mod.js
Normal file
1
lib/js/test262-slice/arithmetic/mod.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
10 % 3
|
||||||
1
lib/js/test262-slice/arithmetic/neg.expected
Normal file
1
lib/js/test262-slice/arithmetic/neg.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
-5
|
||||||
1
lib/js/test262-slice/arithmetic/neg.js
Normal file
1
lib/js/test262-slice/arithmetic/neg.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
-5
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
9
|
||||||
1
lib/js/test262-slice/arithmetic/paren_precedence.js
Normal file
1
lib/js/test262-slice/arithmetic/paren_precedence.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
(1 + 2) * 3
|
||||||
1
lib/js/test262-slice/arithmetic/pos.expected
Normal file
1
lib/js/test262-slice/arithmetic/pos.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
5
|
||||||
1
lib/js/test262-slice/arithmetic/pos.js
Normal file
1
lib/js/test262-slice/arithmetic/pos.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
+5
|
||||||
1
lib/js/test262-slice/arithmetic/pow.expected
Normal file
1
lib/js/test262-slice/arithmetic/pow.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1024
|
||||||
1
lib/js/test262-slice/arithmetic/pow.js
Normal file
1
lib/js/test262-slice/arithmetic/pow.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
2 ** 10
|
||||||
1
lib/js/test262-slice/arithmetic/pow_right_assoc.expected
Normal file
1
lib/js/test262-slice/arithmetic/pow_right_assoc.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
512
|
||||||
1
lib/js/test262-slice/arithmetic/pow_right_assoc.js
Normal file
1
lib/js/test262-slice/arithmetic/pow_right_assoc.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
2 ** 3 ** 2
|
||||||
1
lib/js/test262-slice/arithmetic/precedence.expected
Normal file
1
lib/js/test262-slice/arithmetic/precedence.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
7
|
||||||
1
lib/js/test262-slice/arithmetic/precedence.js
Normal file
1
lib/js/test262-slice/arithmetic/precedence.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
1 + 2 * 3
|
||||||
1
lib/js/test262-slice/arithmetic/string_concat.expected
Normal file
1
lib/js/test262-slice/arithmetic/string_concat.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
"ab"
|
||||||
1
lib/js/test262-slice/arithmetic/string_concat.js
Normal file
1
lib/js/test262-slice/arithmetic/string_concat.js
Normal file
@@ -0,0 +1 @@
|
|||||||
|
"a" + "b"
|
||||||
1
lib/js/test262-slice/arithmetic/sub.expected
Normal file
1
lib/js/test262-slice/arithmetic/sub.expected
Normal file
@@ -0,0 +1 @@
|
|||||||
|
6
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user