├── .gitignore ├── .gitmodules ├── example ├── hello-wasi.porth ├── Template │ ├── README.md │ ├── main.porth │ └── Makefile ├── hello-wasm.porth ├── snake-example.porth └── tictactoe.porth ├── std ├── wasi.porth ├── rand.porth ├── wasm-core.porth ├── wasm4.porth └── wasm-std.porth ├── LICENCE ├── .github └── workflows │ ├── Release.yml │ └── CI.yml ├── modules ├── 4std.porth └── 4orth-compilation.porth ├── README.md └── 4orth.porth /.gitignore: -------------------------------------------------------------------------------- 1 | * 2 | !LICENCE 3 | !/**/ 4 | !*.* 5 | !Makefile 6 | *.asm 7 | *.wat 8 | *.wasm 9 | .vscode/* -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "porth"] 2 | path = porth 3 | url = https://gitlab.com/tsoding/porth.git 4 | -------------------------------------------------------------------------------- /example/hello-wasi.porth: -------------------------------------------------------------------------------- 1 | include "wasi.porth" 2 | 3 | proc main in 4 | "Hello World!\n" puts 5 | end -------------------------------------------------------------------------------- /std/wasi.porth: -------------------------------------------------------------------------------- 1 | include "wasm-core.porth" 2 | 3 | export main "_start" 4 | 5 | import module "wasi_unstable" 6 | import proc fd_write ptr int ptr int -- ptr in end 7 | 8 | const ciovec.buff sizeof(u32) offset end 9 | const ciovec.buf_len sizeof(u32) offset end 10 | const sizeof(ciovec) reset end 11 | 12 | proc puts int ptr in 13 | memory ciovec sizeof(ciovec) end 14 | memory written sizeof(u32) end 15 | ciovec !ptr 16 | ciovec sizeof(u32) ptr+ !int 17 | written 1 ciovec 1 fd_write 18 | drop 19 | end -------------------------------------------------------------------------------- /example/Template/README.md: -------------------------------------------------------------------------------- 1 | # hello-world 2 | 3 | A game written in Porth for the [WASM-4](https://wasm4.org) fantasy console. 4 | 5 | ## Building 6 | 7 | Build the cart by running: 8 | 9 | ```shell 10 | make 11 | ``` 12 | 13 | Then run it with: 14 | 15 | ```shell 16 | w4 run build/cart.wasm 17 | ``` 18 | 19 | For more info about setting up WASM-4, see the [quickstart guide](https://wasm4.org/docs/getting-started/setup?code-lang=wat#quickstart). 20 | 21 | ## Links 22 | 23 | - [Documentation](https://wasm4.org/docs): Learn more about WASM-4. 24 | - [Snake Tutorial](https://wasm4.org/docs/tutorials/snake/goal): Learn how to build a complete game 25 | with a step-by-step tutorial. 26 | - [GitHub](https://github.com/aduros/wasm4): Submit an issue or PR. Contributions are welcome! 27 | -------------------------------------------------------------------------------- /std/rand.porth: -------------------------------------------------------------------------------- 1 | // Inlined WASM code for a Pseudo random number generator. 2 | wasm 3 | "\n(global $random-state (mut i32) (i32.const 69420))" 4 | proc rand int -- int in 5 | " (local i32)" 6 | " global.get $random-state" 7 | " local.tee 0 local.get 0" 8 | " i32.const 13 i32.shl" 9 | " i32.xor local.tee 0" 10 | " local.get 0 i32.const 17" 11 | " i32.shr_u i32.xor" 12 | " local.tee 0 local.get 0" 13 | " i32.const 5 i32.shl" 14 | " i32.xor local.tee 0" 15 | " global.set $random-state" 16 | " local.get 0 i32.const 8" 17 | " i32.shr_u f32.convert_i32_u" 18 | " f32.const 0x1p-24 f32.mul" 19 | " call $pop f32.convert_i32_u" 20 | " f32.mul i32.trunc_f32_u" 21 | " call $push" 22 | end 23 | end -------------------------------------------------------------------------------- /example/Template/main.porth: -------------------------------------------------------------------------------- 1 | include "wasm4.porth" 2 | 3 | const smiley "\\c3\\81\\24\\24\\00\\24\\99\\c3"c end 4 | 5 | const hello "Hello from Porth!"c end 6 | const blink "Press X to blink"c end 7 | 8 | proc main in end 9 | 10 | proc update in 11 | memory $gamepad sizeof(u8) end 12 | 13 | // DRAW_COLORS = 2 14 | 2 $DRAW_COLORS !16 15 | 16 | // text("Hello from Wat!", 10, 10); 17 | 10 10 hello text 18 | 19 | // u8 gamepad = $GAMEPAD1; 20 | $GAMEPAD1 @8 $gamepad !8 21 | 22 | // if (gamepad & BUTTON_1) { 23 | // $DRAW_COLORS = 4; 24 | // } 25 | $gamepad @8 $BUTTON_1 and cast(bool) if 26 | 4 $DRAW_COLORS !16 27 | end 28 | 29 | // blit(smiley, 76, 76, 8, 8, $BLIT_1BPP); 30 | $BLIT_1BPP 8 8 76 76 smiley blit 31 | 32 | // text("Press X to blink", 16, 90); 33 | 90 16 blink text 34 | end 35 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Luna Amora 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /example/hello-wasm.porth: -------------------------------------------------------------------------------- 1 | include "wasm4.porth" 2 | include "rand.porth" 3 | 4 | memory frame-count sizeof(int) end 5 | memory prev-state sizeof(u8) end 6 | 7 | memory string sizeof(ptr) end 8 | const str1 "Hello Wasm!"c end 9 | const str2 "Hello Porth!"c end 10 | 11 | memory coord sizeof(int) 2 * end 12 | inline proc get-coord -- int int in coord @int coord 32 ptr+ @int end 13 | inline proc set-coord int int in coord !int coord 32 ptr+ !int end 14 | 15 | inline proc @gamepad -- int in $GAMEPAD1 @8 end 16 | inline proc ++ ptr in inc32 end 17 | 18 | proc rnd-coord in 19 | frame-count @int rand 65 % 5 + 20 | frame-count @int rand 135 % 5 + 21 | set-coord 22 | end 23 | 24 | proc main in 25 | 0x000000 $PALETTE0 !int 26 | str1 string !ptr 27 | rnd-coord 28 | end 29 | 30 | proc check-keys in 31 | @gamepad dup dup 32 | prev-state @8 xor and swap 33 | prev-state !8 34 | 35 | 0 != if 36 | 2 rand 1 = if str1 else str2 end string !ptr 37 | 0xffffff rand $PALETTE2 !int 38 | rnd-coord 39 | end 40 | end 41 | 42 | proc update in frame-count ++ 43 | frame-count @int 5 % 0 = if 44 | check-keys 45 | end 46 | 47 | get-coord string @ptr text 48 | 150 5 "Press a wasm-4 key!"c text 49 | end -------------------------------------------------------------------------------- /example/Template/Makefile: -------------------------------------------------------------------------------- 1 | ifndef WABT_PATH 2 | $(error Download Wabt (https://github.com/WebAssembly/wabt) and set $$WABT_PATH) 3 | endif 4 | 5 | 4ORTH = 4orth 6 | 4ORTH_PATH = $(shell command -v $(4ORTH)) 7 | 8 | ifeq (, $(4ORTH_PATH)) 9 | $(error Download 4orth (https://github.com/LunaAmora/4orth) and add it to $$PATH) 10 | endif 11 | 12 | 4ORTH_ARGS = com -s 13 | 14 | ifndef _4ORTH 15 | 4ORTH_STD = $(shell dirname -- "$(4ORTH_PATH)")/std 16 | 4ORTH_ARGS := -I $(4ORTH_STD) $(4ORTH_ARGS) 17 | endif 18 | 19 | ifeq ($(b), 1) 20 | 4ORTH_ARGS := $(4ORTH_ARGS) -b 21 | endif 22 | 23 | ifeq ($(r), 1) 24 | 4ORTH_ARGS := $(4ORTH_ARGS) -r 25 | endif 26 | 27 | # Optional dependency from binaryen for smaller builds 28 | WASM_OPT = wasm-opt 29 | 30 | ifneq ($(DEBUG), 1) 31 | ifeq (, $(shell command -v $(WASM_OPT))) 32 | $(info Tip: $(WASM_OPT) was not found. Install it from binaryen for smaller builds!) 33 | else 34 | 4ORTH_ARGS := $(4ORTH_ARGS) -opt 35 | endif 36 | endif 37 | 38 | ifeq ($(OS), Windows_NT) 39 | $(error 4orth compiler only supports Linux) 40 | else 41 | MKDIR_BUILD = mkdir -p build 42 | RMDIR = rm -rf 43 | endif 44 | 45 | all: build/cart.wasm 46 | 47 | # Build cart.wasm from main.porth and run wasm-opt 48 | .PHONY: build/cart.wasm 49 | build/cart.wasm: main.porth 50 | @$(MKDIR_BUILD) 51 | $(4ORTH) $(4ORTH_ARGS) -o $@ $< 52 | 53 | .PHONY: clean 54 | clean: 55 | $(RMDIR) build 56 | -------------------------------------------------------------------------------- /.github/workflows/Release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | tags: 6 | - '*' 7 | 8 | workflow_dispatch: 9 | 10 | jobs: 11 | release: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: dawidd6/action-download-artifact@v2 15 | with: 16 | workflow: CI.yml 17 | workflow_conclusion: success 18 | name: 4orth 19 | 20 | - name: Get Latest Release 21 | id: latest_version 22 | uses: abatilo/release-info-action@v1.3.0 23 | with: 24 | owner: LunaAmora 25 | repo: 4orth 26 | 27 | - name: Get Current Tag 28 | id: get_version 29 | uses: olegtarasov/get-tag@v2.1 30 | 31 | - name: Build release if tag is new 32 | if: ${{ steps.get_version.outputs.tag != steps.latest_version.outputs.latest_tag }} 33 | env: 34 | TAG: ${{ steps.get_version.outputs.tag }} 35 | run: | 36 | zip -r "4oth-${TAG}-linux".zip . 37 | 38 | - name: Publish release if tag is new 39 | if: ${{ steps.get_version.outputs.tag != steps.latest_version.outputs.latest_tag }} 40 | uses: "marvinpinto/action-automatic-releases@latest" 41 | with: 42 | repo_token: "${{ secrets.GITHUB_TOKEN }}" 43 | automatic_release_tag: "${{ steps.get_version.outputs.tag }}" 44 | prerelease: true 45 | files: | 46 | *.zip 47 | -------------------------------------------------------------------------------- /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ main ] 6 | paths: 7 | - '**/*.porth' 8 | - '!example/Template/**' 9 | pull_request: 10 | branches: [ main ] 11 | 12 | workflow_dispatch: 13 | 14 | jobs: 15 | build: 16 | runs-on: ubuntu-latest 17 | steps: 18 | - name: Checkout repository 19 | uses: actions/checkout@v3 20 | 21 | - name: Setup env 22 | run: | 23 | sudo apt-get update 24 | sudo apt-get install wabt binaryen fasm 25 | 26 | - name: Download WASM4 27 | uses: robinraju/release-downloader@v1.3 28 | with: 29 | latest: true 30 | repository: aduros/wasm4 31 | fileName: w4-linux.zip 32 | 33 | - name: Unzip WASM4 34 | run: | 35 | unzip w4-linux.zip 36 | rm -f w4-linux.zip 37 | 38 | - name: Cache porth 39 | id: cache-porth 40 | uses: actions/cache@v3 41 | with: 42 | path: | 43 | porth/porth 44 | porth/std 45 | key: ${{ runner.os }}-porth-submodule 46 | 47 | - name: Bootstrap Porth 48 | if: steps.cache-porth.outputs.cache-hit != 'true' 49 | run: | 50 | git submodule update --init --recursive 51 | cd porth 52 | fasm -m 524288 ./bootstrap/porth-linux-x86_64.fasm 53 | chmod +x ./bootstrap/porth-linux-x86_64 54 | ./bootstrap/porth-linux-x86_64 com ./porth.porth 55 | ./porth com ./porth.porth 56 | 57 | - name: Compile 4orth 58 | run: ./porth/porth -I ./porth/std com 4orth.porth 59 | 60 | - name: Test selfcompilation 61 | run: ./4orth -porth com 4orth.porth 62 | 63 | - name: Test Compilation 64 | run: ./4orth -I ./porth/std com -b -opt -wat ./example/snake-example.porth 65 | 66 | - name: Persist build 67 | uses: actions/upload-artifact@v3 68 | with: 69 | name: 4orth 70 | path: | 71 | 4orth 72 | std/ 73 | 74 | - name: Test html Bundle 75 | run: ./w4 bundle ./example/snake-example.wasm --title "Snake Game" --html index.html 76 | 77 | - name: Persit Html 78 | uses: actions/upload-artifact@v3 79 | with: 80 | name: index 81 | path: index.html 82 | 83 | deploy-page: 84 | runs-on: ubuntu-latest 85 | needs: [build] 86 | steps: 87 | - uses: actions/checkout@v3 88 | - uses: actions/download-artifact@v3 89 | with: 90 | name: index 91 | 92 | - name: Makedir 93 | run: mkdir pages && mv index.html pages 94 | 95 | - name: Deploy to gh-pages 96 | uses: JamesIves/github-pages-deploy-action@v4.2.5 97 | with: 98 | branch: gh-pages 99 | folder: pages 100 | -------------------------------------------------------------------------------- /std/wasm-core.porth: -------------------------------------------------------------------------------- 1 | // Core fundamental definitions of Porth, but lowered to u32 size. 2 | 3 | const NULL 0 cast(ptr) end 4 | 5 | const true 1 cast(bool) end 6 | const false 0 cast(bool) end 7 | 8 | const sizeof(u32) 4 end 9 | const sizeof(u16) 2 end 10 | const sizeof(u8) 1 end 11 | 12 | const sizeof(ptr) sizeof(u32) end 13 | const sizeof(bool) sizeof(u32) end 14 | const sizeof(int) sizeof(u32) end 15 | const sizeof(addr) sizeof(u32) end 16 | 17 | inline proc @ptr ptr -- ptr in @32 cast(ptr) end 18 | inline proc @@ptr ptr -- ptr in @ptr @ptr end 19 | inline proc @bool ptr -- bool in @32 cast(bool) end 20 | inline proc @int ptr -- int in @32 end 21 | inline proc @addr ptr -- addr in @int cast(addr) end 22 | 23 | inline proc !bool bool ptr in !32 end 24 | inline proc !ptr ptr ptr in !32 end 25 | inline proc !int int ptr in !32 end 26 | inline proc !addr addr ptr in !32 end 27 | 28 | inline proc ptr+ ptr int -- ptr in 29 | swap cast(int) 30 | swap cast(int) 31 | + 32 | cast(ptr) 33 | end 34 | 35 | inline proc ptr- ptr int -- ptr in 36 | swap cast(int) 37 | swap cast(int) 38 | - 39 | cast(ptr) 40 | end 41 | 42 | inline proc ptr!= ptr ptr -- bool in 43 | swap cast(int) 44 | swap cast(int) 45 | != 46 | end 47 | 48 | inline proc ptr= ptr ptr -- bool in 49 | swap cast(int) 50 | swap cast(int) 51 | = 52 | end 53 | 54 | inline proc ptr< ptr ptr -- bool in 55 | swap cast(int) 56 | swap cast(int) 57 | < 58 | end 59 | 60 | inline proc +ptr int ptr -- ptr in 61 | cast(int) + cast(ptr) 62 | end 63 | 64 | inline proc ptr-diff ptr ptr -- int in 65 | swap cast(int) 66 | swap cast(int) 67 | - 68 | end 69 | 70 | inline proc / int int -- int in divmod drop end 71 | inline proc % int int -- int in divmod swap drop end 72 | inline proc mod int int -- int in % end 73 | inline proc div int int -- int in / end 74 | inline proc imod int int -- int in idivmod swap drop end 75 | inline proc idiv int int -- int in idivmod drop end 76 | inline proc emod int int -- int in 77 | let a b in 78 | a 79 | b imod 80 | b + 81 | b imod 82 | end 83 | end 84 | 85 | inline proc lnot bool -- bool in 86 | cast(int) 1 swap - cast(bool) 87 | end 88 | 89 | inline proc land bool bool -- bool in 90 | swap cast(int) 91 | swap cast(int) 92 | and 93 | cast(bool) 94 | end 95 | 96 | inline proc lor bool bool -- bool in 97 | swap cast(int) 98 | swap cast(int) 99 | or 100 | cast(bool) 101 | end 102 | 103 | inline proc inc32-by ptr int in over @32 + swap !32 end 104 | inline proc inc32 ptr in dup @32 1 + swap !32 end 105 | inline proc dec32 ptr in dup @32 1 - swap !32 end 106 | inline proc inc8 ptr in dup @8 1 + swap !8 end 107 | inline proc dec8 ptr in dup @8 1 - swap !8 end 108 | 109 | inline proc neg int -- int in not 1 + end 110 | 111 | inline proc ?null ptr -- bool in NULL ptr= end 112 | 113 | inline proc toggle ptr in dup @bool lnot swap !32 end 114 | 115 | inline proc xor int int -- int in 116 | wasm int int -- int in 117 | " call $pop" 118 | " call $pop" 119 | " i32.xor" 120 | " call $push" 121 | end 122 | end -------------------------------------------------------------------------------- /modules/4std.porth: -------------------------------------------------------------------------------- 1 | include "std.porth" 2 | 3 | inline proc inc-Str int ptr -- int ptr in 1 ptr+ swap 1 - swap end 4 | 5 | inline proc dec64-by ptr int in over @64 swap - swap !64 end 6 | 7 | inline proc str-chop-left-by ptr int in 8 | over Str.count over dec64-by 9 | swap Str.data swap inc64-by 10 | end 11 | 12 | proc @hex int -- int ptr in 13 | memory hex-char sizeof(ptr) end 14 | tmp-end hex-char !ptr 15 | memory hexdigits sizeof(Str) end 16 | "ABCDEF0" hexdigits !Str 17 | 18 | let n in 19 | while 20 | hexdigits @Str.count 0 > if 21 | n hexdigits @Str.data @8 = if 22 | 1 23 | hexdigits !Str.count 24 | hexdigits @Str 25 | tmp-append drop false 26 | else true end 27 | else false end 28 | do 29 | hexdigits str-chop-one-left 30 | end 31 | end 32 | 33 | tmp-end hex-char @ptr ptr-diff 34 | hex-char @ptr 35 | end 36 | 37 | proc rec-hex int in 38 | memory hexdigits sizeof(Str) end 39 | "0123456789ABCDEF" hexdigits !Str 40 | 16 let v h in 41 | v h divmod swap 42 | v h >= if rec-hex else drop end 43 | 0 44 | while 45 | over over != dup if 46 | hexdigits str-chop-one-left 47 | else 48 | 1 49 | hexdigits !Str.count 50 | hexdigits @Str 51 | tmp-append drop 52 | end 53 | do 1 + end 54 | drop drop 55 | end 56 | end 57 | 58 | proc char-to-hex int -- int ptr in 59 | memory hex-str sizeof(ptr) end 60 | tmp-end hex-str !ptr 61 | 62 | dup 0 = if drop 63 | "00" tmp-append drop 64 | else 65 | rec-hex 66 | end 67 | 68 | tmp-end hex-str @ptr ptr-diff 69 | hex-str @ptr 70 | end 71 | 72 | proc hex-digit int -- int bool in 73 | let d in 74 | d '0' >= d '9' <= land if d '0' - true else 75 | d 'a' >= d 'f' <= land if* d 'a' - 10 + true else 76 | d 'A' >= d 'F' <= land if* d 'A' - 10 + true else 77 | 0 false end 78 | end 79 | end 80 | 81 | proc try-parse-hex 82 | int ptr 83 | -- 84 | int bool 85 | in 86 | let n s in 87 | 2 s "0x" streq 88 | dup if 89 | n 2 - 90 | s 2 ptr+ 91 | else n s end 92 | end 93 | let n s in 94 | lnot n 0 <= lor if 0 false else 95 | 0 n s while over 0 > do 96 | let a n s in 97 | s @8 hex-digit 98 | lnot if 99 | drop a 0 * 100 | n n - 101 | NULL 102 | else 103 | a 16 * + 104 | n 1 - 105 | s 1 ptr+ 106 | end 107 | end 108 | end 109 | let ans _ pt in 110 | ans pt NULL ptr!= 111 | end 112 | end 113 | end 114 | end 115 | 116 | proc append-std 117 | int ptr 118 | -- 119 | int ptr 120 | in 121 | memory path sizeof(ptr) end 122 | tmp-end path !ptr 123 | 124 | tmp-append drop 125 | "/std" tmp-append drop 126 | 127 | tmp-end path @ptr ptr-diff 128 | path @ptr 129 | end 130 | 131 | proc bputhexchar int ptr in 132 | let bfd in 133 | dup 134 | '0' > over 135 | '9' <= land if 136 | '0' - bfd bputu else 137 | @hex bfd bputs end 138 | end 139 | end 140 | 141 | proc bputhexint int ptr in 142 | let bfd in 143 | char-to-hex 144 | over 1 > if 145 | dup @8 146 | bfd bputhexchar 147 | inc-Str 148 | else 149 | "0" 150 | bfd bputs 151 | end 152 | @8 153 | bfd bputhexchar 154 | drop 155 | end 156 | end 157 | 158 | proc bputschar 159 | int 160 | ptr 161 | in 162 | 1 163 | let s bfd n in 164 | bfd Bfd.size ptr+ 165 | bfd Bfd.fd ptr+ @int 166 | bfd Bfd.buff ptr+ @ptr 167 | let psize fd buff in 168 | psize @int n + BFD_CAP > if bfd bflush end 169 | psize @int n + BFD_CAP > if 170 | // n s fd fputs 171 | else 172 | s buff psize @int ptr+ !8 173 | psize inc64 174 | end 175 | end 176 | end 177 | end 178 | 179 | proc unscape-char int ptr in 180 | let n bfd in 181 | n '\n' = if 182 | "\\n" bfd bputs 183 | else n '\"' = if* 184 | "\\\"" bfd bputs 185 | else 186 | n bfd bputschar 187 | end 188 | end 189 | end 190 | 191 | proc bputwatstr 192 | int ptr 193 | ptr 194 | in 195 | memory str sizeof(Str) end 196 | let bfd in 197 | str !Str 198 | "\"" bfd bputs 199 | while str @Str.count 0 > do 200 | str @Str.data @8 bfd unscape-char 201 | str str-chop-one-left 202 | end 203 | "\"" bfd bputs 204 | end 205 | end 206 | 207 | proc check-getenv-error ptr -- bool in 208 | cstr-to-str "not-valid-env-test-case" getenv cstr-to-str streq lnot 209 | end 210 | 211 | inline proc getenv-check int ptr -- ptr bool in 212 | getenv dup check-getenv-error 213 | end -------------------------------------------------------------------------------- /std/wasm4.porth: -------------------------------------------------------------------------------- 1 | // 2 | // WASM-4: https://wasm4.org/docs 3 | 4 | include "wasm-core.porth" 5 | 6 | export main "start" 7 | export update "update" 8 | 9 | // ┌───────────────────────────────────────────────────────────────────────────┐ 10 | // │ │ 11 | // │ Drawing Functions │ 12 | // │ │ 13 | // └───────────────────────────────────────────────────────────────────────────┘ 14 | // Copies pixels to the framebuffer. 15 | import proc blit int int int int int ptr in end 16 | 17 | // Copies a subregion within a larger sprite atlas to the framebuffer. 18 | import proc blitSub int int int int int int int int ptr in end 19 | 20 | // Draws a line between two points. 21 | import proc line int int int int in end 22 | 23 | // Draws a horizontal line. 24 | import proc hline int int int in end 25 | 26 | // Draws a vertical line. 27 | import proc vline int int int in end 28 | 29 | // Draws an oval (or circle). 30 | import proc oval int int int int in end 31 | 32 | // Draws a rectangle. 33 | import proc rect int int int int in end 34 | 35 | // Draws text using the built-in system font. 36 | import proc text int int ptr in end 37 | import proc textUtf8 int int int ptr in end 38 | import proc textUtf16 int int int ptr in end 39 | 40 | // ┌───────────────────────────────────────────────────────────────────────────┐ 41 | // │ │ 42 | // │ Sound Functions │ 43 | // │ │ 44 | // └───────────────────────────────────────────────────────────────────────────┘ 45 | // Plays a sound tone. 46 | import proc tone int int int int in end 47 | 48 | // ┌───────────────────────────────────────────────────────────────────────────┐ 49 | // │ │ 50 | // │ Storage Functions │ 51 | // │ │ 52 | // └───────────────────────────────────────────────────────────────────────────┘ 53 | // Reads up to `size` bytes from persistent storage into the pointer `dest`. 54 | import proc diskr int ptr in end 55 | 56 | // Writes up to `size` bytes from the pointer `src` into persistent storage. 57 | import proc diskw int ptr in end 58 | 59 | // Prints a message to the debug console. 60 | import proc trace ptr in end 61 | import proc traceUtf8 int ptr in end 62 | import proc traceUtf16 int ptr in end 63 | 64 | // ┌───────────────────────────────────────────────────────────────────────────┐ 65 | // │ │ 66 | // │ Memory Addresses │ 67 | // │ │ 68 | // └───────────────────────────────────────────────────────────────────────────┘ 69 | 70 | const $MEM_BEGIN 4 offset cast(ptr) end // unused 4 bytes 71 | const $PALETTE0 4 offset cast(ptr) end 72 | const $PALETTE1 4 offset cast(ptr) end 73 | const $PALETTE2 4 offset cast(ptr) end 74 | const $PALETTE3 4 offset cast(ptr) end 75 | const $DRAW_COLORS 2 offset cast(ptr) end 76 | const $GAMEPAD1 1 offset cast(ptr) end 77 | const $GAMEPAD2 1 offset cast(ptr) end 78 | const $GAMEPAD3 1 offset cast(ptr) end 79 | const $GAMEPAD4 1 offset cast(ptr) end 80 | const $MOUSE_X 2 offset cast(ptr) end 81 | const $MOUSE_Y 2 offset cast(ptr) end 82 | const $MOUSE_BUTTONS 1 offset cast(ptr) end 83 | const $SYSTEM_FLAGS 1 offset cast(ptr) end 84 | const $NETPLAY 1 offset cast(ptr) end 85 | const $RESERVED 127 offset cast(ptr) end // Reserved bytes for future use 86 | const $FRAMEBUFFER 6400 offset cast(ptr) end 87 | const $PORTH_MEM 54880 offset cast(ptr) end // Start of Porth global mem and return stack 88 | const $PORTH_STACK 4096 offset cast(ptr) end // Reserved memory for Porth data stack 89 | const $PROGRAM_END reset cast(ptr) end // End of program memory 90 | 91 | const $SYSTEM_PRESERVE_FRAMEBUFFER 1 end 92 | const $SYSTEM_HIDE_GAMEPAD_OVERLAY 2 end 93 | 94 | const $BUTTON_1 1 end 95 | const $BUTTON_2 2 end // bits 2 and 3 are skipped 96 | const $BUTTON_LEFT 16 end 97 | const $BUTTON_RIGHT 32 end 98 | const $BUTTON_UP 64 end 99 | const $BUTTON_DOWN 128 end 100 | 101 | const $MOUSE_LEFT 1 end 102 | const $MOUSE_RIGHT 2 end 103 | const $MOUSE_MIDDLE 4 end 104 | 105 | const $BLIT_1BPP 0 end 106 | const $BLIT_2BPP 1 end 107 | const $BLIT_FLIP_X 2 end 108 | const $BLIT_FLIP_Y 4 end 109 | const $BLIT_ROTATE 8 end 110 | 111 | const $TONE_PULSE1 0 end 112 | const $TONE_PULSE2 1 end 113 | const $TONE_TRIANGLE 2 end 114 | const $TONE_NOISE 3 end 115 | const $TONE_MODE1 0 end 116 | const $TONE_MODE2 4 end 117 | const $TONE_MODE3 8 end 118 | const $TONE_MODE4 12 end 119 | 120 | // Alias for traceUtf8 121 | inline proc puts int ptr in traceUtf8 end -------------------------------------------------------------------------------- /std/wasm-std.porth: -------------------------------------------------------------------------------- 1 | include "wasm-core.porth" 2 | 3 | proc cstrlen ptr -- int in 4 | dup 5 | while dup @8 0 != do 1 ptr+ end 6 | swap ptr-diff 7 | end 8 | 9 | proc cstreq ptr ptr -- bool in 10 | while 11 | peek s1 s2 in 12 | s1 @8 0 != s2 @8 0 != land if 13 | s1 @8 s2 @8 = 14 | else false end 15 | end 16 | do 17 | let s1 s2 in 18 | s1 1 ptr+ 19 | s2 1 ptr+ 20 | end 21 | end 22 | 23 | let s1 s2 in 24 | s1 @8 0 = 25 | s2 @8 0 = 26 | land 27 | end 28 | end 29 | 30 | inline proc cstr-to-str ptr -- int ptr in dup cstrlen swap end 31 | 32 | const offsetof(Str.count) sizeof(u32) offset end 33 | const offsetof(Str.data) sizeof(ptr) offset end 34 | const sizeof(Str) reset end 35 | 36 | inline proc Str.count ptr -- ptr in offsetof(Str.count) ptr+ end 37 | inline proc Str.data ptr -- ptr in offsetof(Str.data) ptr+ end 38 | inline proc @Str.count ptr -- int in Str.count @32 end 39 | inline proc @Str.data ptr -- ptr in Str.data @32 cast(ptr) end 40 | inline proc !Str.count int ptr in Str.count !32 end 41 | inline proc !Str.data ptr ptr in Str.data !32 end 42 | 43 | inline proc @Str ptr -- int ptr in 44 | let s in 45 | s @Str.count 46 | s @Str.data 47 | end 48 | end 49 | 50 | inline proc !Str int ptr ptr in 51 | let n s p in 52 | n p !Str.count 53 | s p !Str.data 54 | end 55 | end 56 | 57 | inline proc str-null -- int ptr in 0 NULL end 58 | 59 | inline proc str-chop-one-left ptr in 60 | dup Str.count dec32 61 | Str.data inc32 62 | end 63 | 64 | inline proc str-chop-one-right ptr in 65 | Str.count dec32 66 | end 67 | 68 | proc ?space int -- bool in 69 | let x in 70 | x ' ' = 71 | x '\n' = lor 72 | x '\r' = lor 73 | end 74 | end 75 | 76 | proc str-chop-by-predicate 77 | addr // predicate 78 | ptr // dst 79 | ptr // src 80 | in 81 | memory predicate sizeof(addr) end 82 | rot predicate !addr 83 | over over @Str.data swap !Str.data 84 | over 0 swap !Str.count 85 | while 86 | dup @Str.count 0 > if 87 | dup @Str.data @8 predicate @addr call-like ?space lnot 88 | else false end 89 | do 90 | dup str-chop-one-left 91 | swap dup Str.count inc32 swap 92 | end 93 | dup @Str.count 0 > if 94 | dup str-chop-one-left 95 | end 96 | drop drop 97 | end 98 | 99 | proc streq 100 | int ptr 101 | int ptr 102 | -- 103 | bool 104 | in 105 | let n s1 m s2 in 106 | n m = if 107 | n s1 s2 108 | while 109 | peek n s1 s2 in 110 | n 0 > if 111 | s1 @8 s2 @8 = 112 | else false end 113 | end 114 | do 115 | let n s1 s2 in 116 | n 1 - 117 | s1 1 ptr+ 118 | s2 1 ptr+ 119 | end 120 | end 121 | 122 | let n _ _ in n 0 <= end 123 | else false end 124 | end 125 | end 126 | 127 | proc str-trim-left ptr in // input -- 128 | while 129 | dup @Str.count 0 > if 130 | dup @Str.data @8 ?space 131 | else false end 132 | do 133 | dup str-chop-one-left 134 | end 135 | drop 136 | end 137 | 138 | inline proc ?str-empty ptr -- bool in 139 | offsetof(Str.count) ptr+ 140 | @32 141 | 0 = 142 | end 143 | 144 | const PUTU_BUFFER_CAP 32 end 145 | proc putu 146 | int // number 147 | in 148 | memory buffer PUTU_BUFFER_CAP end 149 | dup 0 = if 150 | "0" puts 151 | else 152 | buffer PUTU_BUFFER_CAP ptr+ 153 | while over 0 != do 154 | 1 ptr- dup rot 155 | 10 divmod 156 | rot swap '0' + swap !8 swap 157 | end 158 | 159 | dup 160 | buffer PUTU_BUFFER_CAP ptr+ swap ptr-diff swap puts 161 | end 162 | drop 163 | end 164 | 165 | proc puti 166 | int // number 167 | in 168 | let number in 169 | number 0 < if 170 | "-" puts 171 | number not 1 + 172 | else 173 | number 174 | end 175 | putu 176 | end 177 | end 178 | 179 | proc memcpy 180 | int // size 181 | ptr // src 182 | ptr // dst 183 | -- 184 | ptr // dst 185 | in 186 | memory src sizeof(ptr) end 187 | memory dst sizeof(ptr) end 188 | memory result sizeof(ptr) end 189 | dst !32 190 | src !32 191 | dst @ptr swap // result 192 | while dup 0 > do 193 | src @ptr @8 194 | dst @ptr !8 195 | src inc32 196 | dst inc32 197 | 1 - 198 | end drop 199 | end 200 | 201 | proc memset 202 | int // size 203 | int // byte 204 | ptr // data 205 | -- 206 | ptr // data 207 | in 208 | memory data sizeof(ptr) end 209 | data !32 210 | memory byte sizeof(u32) end 211 | byte !32 212 | data @ptr swap 213 | while dup 0 > do 214 | byte @32 data @ptr !8 215 | data inc32 216 | 1 - 217 | end 218 | drop 219 | end 220 | 221 | /// Appends an item to a fixed size array 222 | /// returns `true` when succeeds, `false` when overflow 223 | proc append-item 224 | int // item size 225 | ptr // item 226 | int // array capacity 227 | ptr // array 228 | ptr // array count 229 | -- 230 | int // index of the appended item 231 | bool // true - appended, false - not enough space 232 | in 233 | memory count sizeof(ptr) end 234 | count !ptr 235 | memory array sizeof(ptr) end 236 | array !ptr 237 | 238 | count @ptr @int > if 239 | over 240 | count @ptr @int * 241 | array @ptr +ptr 242 | memcpy drop 243 | 244 | count @ptr @int 245 | count @ptr inc32 246 | 247 | true 248 | else 249 | drop drop 250 | 0 false 251 | end 252 | end -------------------------------------------------------------------------------- /example/snake-example.porth: -------------------------------------------------------------------------------- 1 | include "wasm4.porth" 2 | include "rand.porth" 3 | 4 | // Game state 5 | memory frame-count sizeof(int) end 6 | memory prev-state sizeof(u8) end 7 | 8 | // Game consts 9 | const sizeof(coord) sizeof(int) 2 * end 10 | const sizeof(cell) 8 end 11 | const sizeof(grid) 20 end 12 | const delta_time 5 end 13 | const SNAKE_CAP 32 end 14 | 15 | // Helper pointer offsets 16 | inline proc x+ ptr -- ptr in end 17 | inline proc y+ ptr -- ptr in sizeof(int) ptr+ end 18 | inline proc !x int ptr in !int end 19 | inline proc !y int ptr in y+ !int end 20 | inline proc @x ptr -- int in @int end 21 | inline proc @y ptr -- int in y+ @int end 22 | 23 | inline proc snake-incBy ptr int -- ptr in sizeof(coord) * ptr+ end 24 | inline proc snake++ ptr -- ptr in 1 snake-incBy end 25 | 26 | // Snake values 27 | const snake.length sizeof(int) offset end 28 | const snake.dir sizeof(coord) offset end 29 | const snake.body sizeof(coord) SNAKE_CAP * offset end 30 | const sizeof(snake) reset end 31 | 32 | memory snake sizeof(snake) end 33 | 34 | // Snake values setters and getters 35 | inline proc @snake-length -- int in snake snake.length ptr+ @int end 36 | inline proc !snake-length int in snake snake.length ptr+ !int end 37 | inline proc length++ in @snake-length 1 + !snake-length end 38 | 39 | inline proc snake-head -- ptr in snake snake.body ptr+ end 40 | inline proc snake-tail -- ptr in snake-head @snake-length sizeof(coord) * ptr+ end 41 | 42 | inline proc snake-dir -- ptr in snake snake.dir ptr+ end 43 | inline proc !snake-dir int int in snake-dir !y snake-dir !x end 44 | 45 | inline proc ?movingx -- bool in snake-dir @x 0 != end 46 | inline proc ?movingy -- bool in snake-dir @y 0 != end 47 | 48 | // Fruit values 49 | memory fruit sizeof(coord) end 50 | 51 | const fruit-sprite "\\00\\a0\\02\\00\\0e\\f0\\36\\5c\\d6\\57\\d5\\57\\35\\5c\\0f\\f0"c end 52 | const fruit-flags $BLIT_2BPP end 53 | const fruit-height 8 end 54 | const fruit-width 8 end 55 | 56 | // Helper inline procs 57 | inline proc rnd-coord -- int int in 20 rand 20 rand end 58 | inline proc ptr> ptr ptr -- bool in swap ptr< end 59 | 60 | // Wasm4 memory getters and setters 61 | inline proc !PALETTE int int in 4 % 4 * $PALETTE0 +ptr !int end 62 | inline proc !COLORS int in $DRAW_COLORS !16 end 63 | inline proc @GAMEPAD -- int in $GAMEPAD1 @8 end 64 | 65 | // Initialize fruit in a random position 66 | inline proc new-fruit in 67 | rnd-coord 68 | fruit !x 69 | fruit !y 70 | end 71 | 72 | // Initialize snake body and direction 73 | inline proc snake-init in 74 | 1 0 !snake-dir 75 | 3 !snake-length 76 | 77 | @snake-length snake-head 78 | while over 0 > do 79 | let xPos snake* in 80 | xPos snake* !x 81 | 10 snake* !y 82 | xPos 1 - 83 | snake* snake++ 84 | end 85 | end drop drop 86 | end 87 | 88 | proc init in 89 | snake-init 90 | new-fruit 91 | end 92 | 93 | proc main in 94 | // Color palette setting 95 | 0x151640 0 !PALETTE 96 | 0x3f6d9e 1 !PALETTE 97 | 0xf783b0 2 !PALETTE 98 | 0xe6f2ef 3 !PALETTE 99 | 100 | init 101 | end 102 | 103 | // Change snake direction based on input xdir and ydir. 104 | // If value is 1 it's positive, otherwise it's negative 105 | proc input-dir int int in 106 | let x y in 107 | y 0 != ?movingx land 108 | x 0 != ?movingy land lor if 109 | x y !snake-dir 110 | end 111 | end 112 | end 113 | 114 | // Compare current pressed keys with keys pressed in the last checked frame and calls input-dir 115 | proc check-keys in 116 | @GAMEPAD 117 | let keys in 118 | keys prev-state @8 xor keys and 119 | keys prev-state !8 120 | peek pressed in 0 != if 121 | pressed $BUTTON_LEFT and 0 != if -1 0 122 | else 123 | pressed $BUTTON_RIGHT and 0 != if* 1 0 124 | else 125 | pressed $BUTTON_DOWN and 0 != if* 0 1 126 | else 127 | pressed $BUTTON_UP and 0 != if* 0 -1 128 | else 0 0 end input-dir 129 | end end 130 | end 131 | end 132 | 133 | // Return the wrapped snake position around the screen given its position and direction 134 | proc clamp-wrap int int -- int in 135 | + sizeof(grid) 1 - 136 | let next border in 137 | next 0 < if 138 | border 139 | else next border > if* 140 | 0 141 | else next end 142 | end 143 | end 144 | 145 | // Update every part of the snake body to its new position 146 | proc snake-update in 147 | snake-head @x 148 | snake-head @y 149 | snake-head 150 | while snake++ dup snake-tail ptr< do 151 | let x y snake* in 152 | snake* @x 153 | snake* @y 154 | y snake* !y 155 | x snake* !x 156 | snake* 157 | end 158 | end drop drop drop 159 | 160 | ?movingx if 161 | snake-head @x snake-dir @x 162 | clamp-wrap 163 | snake-head !x 164 | else ?movingy if* 165 | snake-head @y snake-dir @y 166 | clamp-wrap 167 | snake-head !y 168 | end 169 | end 170 | 171 | // Check if the snake head is colliding with the fruit. 172 | // Incrementing the snake and generating a new fruit if true. 173 | proc check-fruit in 174 | snake-head @x fruit @x = 175 | snake-head @y fruit @y = land if 176 | length++ 177 | new-fruit 178 | end 179 | end 180 | 181 | proc check-death -- bool in 182 | false snake-head 3 snake-incBy 183 | while over lnot over snake-tail ptr< land do 184 | let isDead snake* in 185 | snake* @x snake-head @x = 186 | snake* @y snake-head @y = land 187 | snake* snake++ 188 | end 189 | end drop 190 | end 191 | 192 | // Draw a 8 x 8 rectangle in a given coord 193 | proc draw-rect int int in 194 | let x y in 195 | sizeof(cell) dup 196 | y sizeof(cell) * 197 | x sizeof(cell) * 198 | rect 199 | end 200 | end 201 | 202 | // Draws all parts of the snake 203 | proc snake-draw in 204 | 0x0004 !COLORS 205 | 206 | snake-head @x 207 | snake-head @y 208 | draw-rect 209 | 210 | 0x0043 !COLORS 211 | 212 | snake-tail snake-head 213 | while snake++ over over ptr> do 214 | peek snake* in 215 | snake* @x 216 | snake* @y draw-rect 217 | end 218 | end drop drop 219 | end 220 | 221 | // Draws the fruit sprite 222 | proc fruit-draw in 223 | 0x4320 !COLORS 224 | fruit-flags 225 | fruit-height 226 | fruit-width 227 | fruit @y sizeof(cell) * 228 | fruit @x sizeof(cell) * 229 | fruit-sprite 230 | blit 231 | end 232 | 233 | // Gameloop 234 | proc update in 235 | frame-count inc32 236 | 237 | // Only do checks and updates every `delta_time` frames 238 | frame-count @int delta_time % 0 = if 239 | check-keys 240 | check-fruit 241 | snake-update 242 | 243 | check-death if 244 | init 245 | end 246 | end 247 | 248 | fruit-draw 249 | snake-draw 250 | end -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | GitHub Workflow Status 3 | GitHub release (latest by date including pre-releases) 4 | GitHub all releases 5 | GitHub 6 |

7 | 8 | # 4orth 9 | 10 | 4orth is a [Porth](https://gitlab.com/tsoding/porth) compiler with [WASM](https://webassembly.org/), [WASI](https://wasi.dev/) and [WASM-4](https://wasm4.org/) targets. 11 | 12 | Most of the code in this repository was written by [Tsoding](https://github.com/rexim) and other contributors to the original Porth compiler. 4orth was created as an alternative compiler for WASM, and reuses a lot of its codebase. 13 | 14 | ## Quick Start 15 | 16 | You can download the latest [release](https://github.com/LunaAmora/4orth/releases) or [bootstrap](https://github.com/LunaAmora/4orth#bootstrapping) it yourself. 17 | 18 | ### Bootstrapping 19 | 20 | Since Porth is self-hosted you will need to bootstrap it first. Follow Porth [bootstrapping](https://gitlab.com/tsoding/porth#bootstrapping) instructions on how to do that. (4orth includes the original porth compiler with the -porth option, so you can use the 4orth executable instead to bootstrap/update itself) 21 | 22 | Secondly you will need to install: 23 | 24 | - [WABT](https://github.com/WebAssembly/wabt) 25 | - [Binaryen](https://github.com/WebAssembly/binaryen) (optional, for optimized .wasm files) 26 | 27 | ```console 28 | $ ./porth/porth com 4orth.porth 29 | 30 | $ ./4orth -porth com 4orth.porth 31 | ``` 32 | 33 | Then, you are ready to compile and run your Porth programs using the runtime of your choice: 34 | 35 | - [WASM-4](https://wasm4.org/) 36 | - [WASMTIME](https://wasmtime.dev/) 37 | - [WASMER](https://wasmer.io/) 38 | - Or load the `.wasm` file yourself with [Javascript](https://developer.mozilla.org/en-US/docs/WebAssembly/Loading_and_running). 39 | 40 | ### Compilation 41 | 42 | Compilation generates [WAT](https://developer.mozilla.org/en-US/docs/WebAssembly/Understanding_the_text_format) and converts it to a [WebAssembly Binary Format](https://webassembly.github.io/spec/core/binary/index.html) `.wasm` file with [WABT](https://developer.mozilla.org/en-US/docs/WebAssembly/Text_format_to_wasm). So make sure you have it available in your `$PATH`. 43 | 44 | ```console 45 | $ ./4orth com main.porth 46 | $ w4 run main.wasm 47 | 48 | $ ./4orth com -wasm main.porth 49 | $ wasmtime main.wasm 50 | ``` 51 | 52 | With Wasm-4, you can use the subcommands `-b` and `-r` to bundle and run after the compilation. (As porth only supports Linux, `-b` creates a Linux executable. For other options, check `w4 bundle --help` or [Wasm-4](https://wasm4.org/docs/guides/distribution) distribution docs) 53 | 54 | ```console 55 | ./4orth com -b -r main.porth 56 | ``` 57 | 58 | Tip: Add `_4ORTH` environment variable to automatically have the std libraries available in 4orth include path. 59 | 60 | ### Running options and subcommands 61 | 62 | ```console 63 | $ ./4orth [OPTIONS] 64 | 65 | OPTIONS: 66 | -porth Use the original porth compiler and CLI instead of 4orth 67 | -unsafe Disable type checking 68 | -I Add to the include paths list 69 | SUBCOMMANDS: 70 | com [OPTIONS] Compile the program 71 | -r Run the program after successful compilation 72 | -b Bundles the program to a linux executable. (If with -r, executes the bundle) 73 | -opt Optimize the program with wasm-opt 74 | -wat Transforms the stripped program back from the final `.wasm` to `.wat` 75 | -wasm Target WASM instead of Wasm-4 (doesn't support -b or -r) 76 | -s Silent mode. Don't print any info about compilation phases 77 | -o File to write the result to 78 | help Print this help to stdout and exit with 0 code 79 | ``` 80 | 81 | ### Status 82 | 83 | 4orth currently only supports 32 bit integers. 84 | 85 | ## Changes 86 | 87 | 4orth implements some temporary features not available in Porth to facilitate Wasm integration: 88 | 89 | - Hexadecimal numbers (as `0x` format on numbers, and as `\\` plus 2 digits on strings) 90 | - Null terminated string support in const evaluation (evaluates to a pointer to the string) 91 | 92 | ### Importing and exporting procs 93 | 94 | 4orth introduces two new keywords allowing Porth to interact with the WASM module system: 95 | 96 | - Import 97 | 98 | ```porth 99 | import proc trace ptr in end 100 | ``` 101 | 102 | This adds the ability to call the Wasm-4 `trace` function via the defined proc contract. Imported procs must have an empty body. 103 | (Porth's `print` intrinsic calls this imported proc, you can use either of them to log to the console) 104 | 105 | - Export 106 | 107 | ```porth 108 | export main "start" 109 | export update "update" 110 | ``` 111 | 112 | This exports the desired procs to be called by Wasm-4 or other Wasm runtimes. 113 | 114 | ### Inline WASM code 115 | 116 | 4orth allows you to inline WASM code into your program by using the `wasm` keyword. Any string inside the code block will be inlined in the compiled program. 117 | 118 | ```porth 119 | wasm 120 | "\n;; Inlined global rng seed for a Pseudo random number generator." 121 | "(global $random-state (mut i32) (i32.const 69420))" 122 | end 123 | ``` 124 | 125 | When inside a procedure, inline WASM blocks have to define a contract to be used in type checking. 126 | 127 | ```porth 128 | inline proc xor int int -- int in 129 | wasm int int -- int in 130 | " call $pop" 131 | " call $pop" 132 | " i32.xor" 133 | " call $push" 134 | end 135 | end 136 | ``` 137 | 138 | This implements a `xor` procedure utilizing the WASM `i32.xor` instruction. (This proc is available at [wasm-core.porth](./std/wasm-core.porth)) 139 | 140 | ### Importing modules (for raw WASM and WASI) 141 | 142 | The default module imported by 4orth is `dev`. You can include other modules in your program by using the `import` keyword followed by `module` and the module name. 143 | 144 | ```porth 145 | import module "my_module" 146 | ``` 147 | 148 | This line changes the current module context to `my_module`. Every imported proc defined after this line will use this context until a new module is imported. 149 | 150 | ## Others 151 | 152 | All available [functions](https://wasm4.org/docs/reference/functions), constants and the [memory map](https://wasm4.org/docs/reference/memory) from Wasm-4 are in the [wasm4.porth](./std/wasm4.porth) library. 153 | 154 | The [wasi.porth](./std/wasi.porth) library contains a minimal WASI setup and a imported proc that prints to stdout. 155 | 156 | Huge thanks to [Tsoding](https://github.com/rexim) for all the educational content and for (being in the process of) creating such a fun language to experiment with.\ 157 | And Thanks [Aduros](https://github.com/aduros) for the fantastic fantasy console [Wasm-4](https://wasm4.org/). 158 | 159 | The two projects just seemed so compatible to me that I had to try a way to play with both at the same time! 160 | -------------------------------------------------------------------------------- /example/tictactoe.porth: -------------------------------------------------------------------------------- 1 | include "wasm4.porth" 2 | 3 | memory gamepad-state sizeof(u8) end 4 | memory frame-count sizeof(int) end 5 | memory player sizeof(bool) end 6 | memory gamepad sizeof(ptr) end 7 | 8 | const WINDOW_SIZE 160 end 9 | const FONT_CENTER 4 end 10 | const DELTA_TIME 2 end 11 | const CHARS " XO"c end 12 | 13 | const CELL_SIZE 14 end 14 | const CELL_BORDER 1 end 15 | const CELL_BOUNDS CELL_SIZE CELL_BORDER - end 16 | const CELL_FONT_CENTER CELL_BOUNDS 2 divmod drop 1 + FONT_CENTER - end 17 | 18 | const COLL 3 end 19 | const ROWS 3 end 20 | 21 | const BORDER_SIZE 4 end 22 | const BORDER_WIDTH_OFFSET BORDER_SIZE COLL 1 - * end 23 | const BORDER_HEIGHT_OFFSET BORDER_SIZE ROWS 1 - * end 24 | 25 | const BOARD_WIDTH CELL_SIZE COLL * end 26 | const BOARD_HEIGHT CELL_SIZE ROWS * end 27 | 28 | const GRID_WIDTH BOARD_WIDTH COLL * BORDER_WIDTH_OFFSET + end 29 | const GRID_HEIGHT BOARD_HEIGHT ROWS * BORDER_HEIGHT_OFFSET + end 30 | 31 | const GRID_OFFSET.X WINDOW_SIZE GRID_WIDTH - 2 divmod drop end 32 | const GRID_OFFSET.Y WINDOW_SIZE GRID_HEIGHT - 2 divmod drop end 33 | 34 | const BOARD_CELLS COLL ROWS * end 35 | const GRID_CELLS BOARD_CELLS BOARD_CELLS * end 36 | 37 | const cell.value sizeof(int) offset end 38 | const cell.coord sizeof(int) 2 * offset end 39 | const sizeof(cell) reset end 40 | 41 | const board.cells BOARD_CELLS sizeof(cell) * offset end 42 | const board.status sizeof(int) offset end 43 | const sizeof(board) reset end 44 | 45 | const sizeof(grid) BOARD_CELLS sizeof(board) * end 46 | 47 | memory grid sizeof(grid) end 48 | memory highlighted sizeof(ptr) end 49 | memory current-board sizeof(ptr) end 50 | 51 | inline proc coord(i) int -- int int in COLL divmod swap end 52 | inline proc index(x,y) int int -- int in COLL * + end 53 | 54 | inline proc board(i) int -- ptr in sizeof(board) * grid +ptr end 55 | inline proc board(x,y) int int -- ptr in index(x,y) board(i) end 56 | 57 | inline proc @board.cell(i) ptr int -- ptr in sizeof(cell) * ptr+ end 58 | inline proc @board.cell(x,y) ptr int int -- ptr in index(x,y) @board.cell(i) end 59 | 60 | proc cell(x,y) int int -- ptr in 61 | let x y in 62 | x COLL divmod 63 | y ROWS divmod 64 | let xBoard xRest yBoard yRest in 65 | xBoard yBoard board(x,y) 66 | yRest xRest @board.cell(x,y) 67 | end 68 | end 69 | end 70 | 71 | inline proc cell(i) int -- ptr in COLL COLL * divmod swap cell(x,y) end 72 | 73 | inline proc @board.index ptr -- int in cast(int) grid cast(int) - sizeof(board) / end 74 | inline proc @board.coord ptr -- int int in @board.index coord(i) end 75 | inline proc @board ptr -- ptr in @board.index board(i) end 76 | 77 | inline proc !coord int int ptr in 78 | cell.coord ptr+ swap over 79 | sizeof(int) ptr+ 80 | !int !int 81 | end 82 | 83 | inline proc @coord ptr -- int int in 84 | cell.coord ptr+ dup @int swap 85 | sizeof(int) ptr+ @int 86 | end 87 | 88 | inline proc @index ptr -- int in @coord index(x,y) end 89 | inline proc @inboardCoord ptr -- int int in @coord ROWS % swap COLL % swap end 90 | inline proc @drawOffset ptr -- int int in @inboardCoord swap CELL_SIZE * swap CELL_SIZE * end 91 | inline proc @nextBoard ptr -- ptr in @inboardCoord index(x,y) board(i) end 92 | 93 | inline proc !PALETTE int int in 4 % 4 * $PALETTE0 +ptr !int end 94 | inline proc !COLORS int in $DRAW_COLORS !16 end 95 | inline proc @GAMEPAD -- int in gamepad @ptr @8 end 96 | 97 | inline proc frame-count++ in frame-count @int 1 + frame-count !int end 98 | inline proc reset-control-state in 0 gamepad-state !8 end 99 | 100 | proc player-toggle in 101 | player dup @bool if 102 | $GAMEPAD2 103 | else 104 | $GAMEPAD1 105 | end 106 | gamepad !ptr 107 | toggle 108 | end 109 | 110 | proc create-grid in 111 | 0 while dup GRID_CELLS < do peek n in 112 | n COLL COLL * 113 | divmod swap 114 | n cell(i) 115 | !coord 1 + 116 | end end drop 117 | end 118 | 119 | proc reset-highlight in 120 | current-board @ptr ?null if 121 | BOARD_CELLS 2 / board(i) 122 | else 123 | current-board @ptr 124 | end 125 | BOARD_CELLS 2 % 1 = if 126 | BOARD_CELLS 2 / 127 | else 0 end 128 | @board.cell(i) 129 | highlighted !ptr 130 | end 131 | 132 | proc main in 133 | 0x28000e 0 !PALETTE 134 | 0x641010 1 !PALETTE 135 | 0x734940 2 !PALETTE 136 | 0xbba075 3 !PALETTE 137 | 138 | player-toggle 139 | create-grid 140 | reset-highlight 141 | end 142 | 143 | proc update-current-board in 144 | highlighted @ptr @nextBoard dup 145 | board.status ptr+ @int 0 = if 146 | current-board !ptr 147 | else drop 148 | NULL current-board !ptr 149 | end 150 | reset-highlight 151 | end 152 | 153 | proc place-and-update in 154 | highlighted @ptr ?null lnot 155 | highlighted @ptr @int 0 = land if 156 | // current-board @ptr dup ?null swap 157 | // highlighted @ptr @board ptr= lor if 158 | player @bool cast(int) 1 + 159 | highlighted @ptr !int 160 | update-current-board 161 | player-toggle 162 | // end 163 | end 164 | end 165 | 166 | proc clamp-wrap int int int -- int in 167 | rot + swap 1 - 168 | let next border in 169 | next 0 < if 170 | border 171 | else next border > if* 172 | 0 173 | else next end 174 | end 175 | end 176 | 177 | proc input-dir int int in 178 | highlighted @ptr ?null if drop drop 179 | reset-highlight 180 | else 181 | let xDir yDir in 182 | yDir 0 != if 183 | highlighted @ptr @coord 184 | ROWS ROWS * yDir clamp-wrap 185 | cell(x,y) highlighted !ptr 186 | else xDir 0 != if* 187 | highlighted @ptr @coord swap 188 | COLL COLL * xDir clamp-wrap swap 189 | cell(x,y) highlighted !ptr 190 | end 191 | end 192 | end 193 | end 194 | 195 | proc update-state int ptr -- int in 196 | let keys prev-state in 197 | keys prev-state @8 xor keys and 198 | keys prev-state !8 199 | end 200 | end 201 | 202 | proc check-keys in 203 | @GAMEPAD gamepad-state update-state 204 | peek pressed in 0 != if 205 | pressed $BUTTON_1 and cast(bool) 206 | pressed $BUTTON_2 and cast(bool) lor if 207 | place-and-update 208 | end pressed $BUTTON_LEFT and cast(bool) if -1 0 209 | else pressed $BUTTON_RIGHT and cast(bool) if* 1 0 210 | else pressed $BUTTON_DOWN and cast(bool) if* 0 1 211 | else pressed $BUTTON_UP and cast(bool) if* 0 -1 212 | else 0 0 end 213 | input-dir 214 | end end 215 | end 216 | 217 | proc draw-current-board in 218 | current-board @ptr ?null lnot if 219 | 0x0004 !COLORS 220 | BOARD_HEIGHT BORDER_SIZE + CELL_BORDER - 221 | BOARD_WIDTH BORDER_SIZE + CELL_BORDER - 222 | current-board @ptr 223 | @board.coord swap 224 | GRID_OFFSET.Y rot BORDER_SIZE BOARD_HEIGHT + * + BORDER_SIZE 2 / - 225 | GRID_OFFSET.X rot BORDER_SIZE BOARD_WIDTH + * + BORDER_SIZE 2 / - 226 | rect 227 | end 228 | end 229 | 230 | proc draw-cell int int ptr in 231 | let ix iy cell in 232 | cell @drawOffset 233 | iy + swap ix + 234 | let y x in 235 | cell highlighted @ptr ptr= if 236 | 0x0024 237 | else 238 | 0x0023 239 | end 240 | !COLORS 241 | 242 | CELL_BOUNDS dup y x rect 243 | 244 | cell @int 0 != if 0x0001 !COLORS 245 | y CELL_FONT_CENTER + 246 | x CELL_FONT_CENTER + 247 | 1 248 | CHARS cell @int ptr+ 249 | textUtf8 250 | end 251 | end 252 | end 253 | end 254 | 255 | proc draw-board ptr in 256 | peek board in 257 | @board.coord 258 | BORDER_SIZE BOARD_HEIGHT + * GRID_OFFSET.Y + swap 259 | BORDER_SIZE BOARD_WIDTH + * GRID_OFFSET.X + 260 | let y x in 261 | 0 while dup BOARD_CELLS < do 262 | board over @board.cell(i) 263 | x y rot 264 | draw-cell 265 | 1 + 266 | end drop 267 | end 268 | end 269 | end 270 | 271 | proc draw-grid in 272 | 0 while dup BOARD_CELLS < do 273 | dup board(i) 274 | draw-board 275 | 1 + 276 | end drop 277 | end 278 | 279 | proc update in 280 | frame-count++ 281 | 282 | frame-count @int DELTA_TIME 2 * % 0 = if 283 | reset-control-state 284 | else frame-count @int DELTA_TIME % 0 = if* 285 | check-keys 286 | end 287 | 288 | draw-current-board 289 | draw-grid 290 | 291 | 0x0004 !COLORS 292 | 3 56 1 CHARS player @bool cast(int) 1 + ptr+ textUtf8 293 | 3 63 " Turn"c text 294 | end -------------------------------------------------------------------------------- /modules/4orth-compilation.porth: -------------------------------------------------------------------------------- 1 | /// BEGIN Code Injection ////////////////////////////// 2 | /// Start of a inline WASM code block 3 | /// Is used by the op OP_INJECTED 4 | const Inject.ins sizeof(TypeStack) offset end 5 | const Inject.outs sizeof(TypeStack) offset end 6 | const Inject.size sizeof(int) offset end 7 | const Inject.addr sizeof(int) offset end 8 | const sizeof(Injection) reset end 9 | 10 | const INJECT_CAP 1024 end 11 | memory inject-count sizeof(u64) end 12 | memory injects sizeof(Injection) INJECT_CAP * end 13 | 14 | proc inject-define 15 | ptr // proc 16 | in 17 | sizeof(Injection) swap INJECT_CAP injects inject-count append-item lnot if 18 | here eputs ": ERROR: injections definitions capacity exceeded\n" eputs 19 | 1 exit 20 | end 21 | drop 22 | end 23 | 24 | proc inject-lookup-by-addr 25 | int // proc addr 26 | -- 27 | ptr // proc 28 | in 29 | memory addr sizeof(int) end 30 | addr !int 31 | 32 | 0 while 33 | dup inject-count @64 < if 34 | dup sizeof(Injection) * injects +ptr Inject.addr ptr+ @int 35 | addr @int 36 | != 37 | else false end 38 | do 1 + end 39 | 40 | dup inject-count @64 < if 41 | sizeof(Injection) * injects +ptr 42 | else 43 | drop NULL 44 | end 45 | end 46 | 47 | /// Array of strings to inject on the compiled program. 48 | /// The operand of OP_INJECT_CODE is the 49 | /// index within this array 50 | const INJECTIONS_CAP 2 1024 * end 51 | memory injections-count sizeof(int) end 52 | memory injections sizeof(Str) INJECTIONS_CAP * end 53 | 54 | proc injection-define 55 | int ptr 56 | -- 57 | int 58 | in 59 | memory injection sizeof(Str) end 60 | injection !Str 61 | 62 | sizeof(Str) injection 63 | INJECTIONS_CAP injections 64 | injections-count 65 | append-item lnot if 66 | here eputs ": ERROR: code injection capacity exceeded\n" eputs 67 | 1 exit 68 | end 69 | end 70 | 71 | memory inside-injection sizeof(bool) end 72 | 73 | proc current-inject -- ptr in 74 | inside-injection @bool if 75 | inject-count @int 76 | 1 - 77 | sizeof(Injection) * 78 | injects +ptr 79 | else 80 | NULL 81 | end 82 | end 83 | /// END Code Injection ////////////////////////////// 84 | 85 | const WASM_MODULES_CAP 8 end 86 | memory wasm-modules sizeof(Str) WASM_MODULES_CAP * end 87 | memory wasm-modules-count sizeof(int) end 88 | 89 | proc wasm-modules-add 90 | int ptr 91 | in 92 | wasm-modules-count @int 93 | let n s count in 94 | count WASM_MODULES_CAP >= if 95 | here eputs ": Assertion Failed: wasm-modules capacity overflow\n" eputs 96 | 1 exit 97 | end 98 | 99 | n s 100 | count sizeof(Str) * wasm-modules +ptr 101 | !Str 102 | 103 | wasm-modules-count inc64 104 | end 105 | end 106 | 107 | proc introduce-wasm-module 108 | ptr // token 109 | ptr // lexer 110 | in 111 | memory lexer_ sizeof(ptr) end 112 | lexer_ !ptr 113 | memory token sizeof(Token) end 114 | sizeof(Token) swap token memcpy drop 115 | 116 | inside-proc @bool if 117 | token Token.loc ptr+ eputloc 118 | ": ERROR: definition of imports inside of procedures is not allowed\n" eputs 119 | procs-count @int 1 - sizeof(Proc) * procs +ptr Proc.loc ptr+ eputloc 120 | ": NOTE: the current procedure starts here\n" eputs 121 | 1 exit 122 | end 123 | 124 | token Token.type ptr+ @64 TOKEN_WORD != if 125 | token Token.loc ptr+ eputloc 126 | ": ERROR: expected import type to be a word or 'proc' but found " eputs 127 | token Token.type ptr+ @64 HUMAN_SINGULAR human-token-type eputs 128 | " instead\n" eputs 129 | 1 exit 130 | end 131 | 132 | token Token.value ptr+ @Str "module" streq lnot if 133 | token Token.loc ptr+ eputloc 134 | ": ERROR: unknown import type found: " eputs 135 | token Token.value ptr+ @Str eputs 136 | "\n" eputs 137 | 1 exit 138 | end 139 | 140 | memory token2 sizeof(Token) end 141 | 142 | token2 lexer_ @ptr lexer-next-token lnot if 143 | token2 Token.loc ptr+ eputloc 144 | ": ERROR: expected import module name but found nothing\n" eputs 145 | 1 exit 146 | end 147 | 148 | token2 Token.type ptr+ @int TOKEN_STR != if 149 | token2 Token.loc ptr+ eputloc 150 | ": ERROR: expected import module name to be a string but found " eputs 151 | token2 Token.type ptr+ @int HUMAN_SINGULAR human-token-type eputs 152 | "\n" eputs 153 | 1 exit 154 | end 155 | 156 | token2 Token.value ptr+ @Str 157 | wasm-modules-add 158 | end 159 | 160 | const EXPORT_CAP 1024 end 161 | const sizeof(export) sizeof(Str) 2 * end 162 | memory exports sizeof(export) EXPORT_CAP * end 163 | memory exports-count sizeof(int) end 164 | 165 | proc exports-add 166 | int ptr 167 | int ptr 168 | in 169 | exports-count @int 170 | let n s n1 s1 count in 171 | count EXPORT_CAP >= if 172 | here eputs ": Assertion Failed: exports capacity overflow\n" eputs 173 | 1 exit 174 | end 175 | 176 | n s 177 | count sizeof(export) * exports +ptr 178 | !Str 179 | n1 s1 180 | count sizeof(export) * exports +ptr sizeof(Str) ptr+ 181 | !Str 182 | 183 | exports-count inc64 184 | end 185 | end 186 | 187 | proc introduce-export 188 | ptr // token 189 | ptr // lexer 190 | in 191 | memory lexer_ sizeof(ptr) end 192 | lexer_ !ptr 193 | memory token sizeof(Token) end 194 | sizeof(Token) swap token memcpy drop 195 | 196 | inside-proc @bool if 197 | token Token.loc ptr+ eputloc 198 | ": ERROR: definition of exports inside of procedures is not allowed\n" eputs 199 | procs-count @int 1 - sizeof(Proc) * procs +ptr Proc.loc ptr+ eputloc 200 | ": NOTE: the current procedure starts here\n" eputs 201 | 1 exit 202 | end 203 | 204 | token lexer_ @ptr lexer-next-token lnot if 205 | token Token.loc ptr+ eputloc 206 | ": ERROR: expected export value but found nothing\n" eputs 207 | 1 exit 208 | end 209 | 210 | token Token.type ptr+ @64 TOKEN_WORD != if 211 | token Token.loc ptr+ eputloc 212 | ": ERROR: expected export value to be a word but found " eputs 213 | token Token.type ptr+ @64 HUMAN_SINGULAR human-token-type eputs 214 | " instead\n" eputs 215 | 1 exit 216 | end 217 | 218 | memory token2 sizeof(Token) end 219 | 220 | token2 lexer_ @ptr lexer-next-token lnot if 221 | token2 Token.loc ptr+ eputloc 222 | ": ERROR: expected export name but found nothing\n" eputs 223 | 1 exit 224 | end 225 | 226 | token2 Token.type ptr+ @int TOKEN_STR != if 227 | token2 Token.loc ptr+ eputloc 228 | ": ERROR: expected export name to be a string but found " eputs 229 | token2 Token.type ptr+ @int HUMAN_SINGULAR human-token-type eputs 230 | "\n" eputs 231 | 1 exit 232 | end 233 | 234 | token Token.value ptr+ @Str 235 | token2 Token.value ptr+ @Str 236 | exports-add 237 | end 238 | 239 | proc introduce-import 240 | ptr // token 241 | ptr // lexer 242 | in 243 | memory lexer_ sizeof(ptr) end 244 | lexer_ !ptr 245 | memory token sizeof(Token) end 246 | sizeof(Token) swap token memcpy drop 247 | memory prok sizeof(Proc) end 248 | 249 | inside-proc @bool if 250 | token Token.loc ptr+ eputloc 251 | ": ERROR: definition procedures inside of procedures is not allowed (for now)\n" eputs 252 | procs-count @int 1 - sizeof(Proc) * procs +ptr Proc.loc ptr+ eputloc 253 | ": NOTE: the current procedure starts here\n" eputs 254 | 1 exit 255 | end 256 | 257 | sizeof(Proc) 0 prok memset drop 258 | 259 | wasm-modules-count @int 0 = if 260 | "env" wasm-modules-add 261 | end 262 | 263 | wasm-modules-count @int prok Proc.imported ptr+ !int 264 | 265 | token lexer_ @ptr lexer-next-token lnot if 266 | token Token.loc ptr+ eputloc 267 | ": ERROR: expected procedure name but found nothing\n" eputs 268 | 1 exit 269 | end 270 | 271 | token Token.type ptr+ @64 TOKEN_WORD != if 272 | token Token.loc ptr+ eputloc 273 | ": ERROR: expected procedure name to be a word but found " eputs 274 | token Token.type ptr+ @64 HUMAN_SINGULAR human-token-type eputs 275 | " instead\n" eputs 276 | 1 exit 277 | end 278 | 279 | sizeof(Loc) token Token.loc ptr+ prok Proc.loc ptr+ memcpy drop 280 | 281 | token Token.value ptr+ @Str 282 | token Token.loc ptr+ 283 | check-name-redefinition 284 | 285 | sizeof(Str) token Token.value ptr+ prok Proc.name ptr+ memcpy drop 286 | 287 | ops-count @64 288 | dup prok Proc.addr ptr+ !64 289 | parse-block-stack-push 290 | OP_PREP_PROC 0 token push-op 291 | 292 | prok 293 | lexer_ @ptr over Proc.ins ptr+ parse-proc-contract-list if 294 | lexer_ @ptr over Proc.outs ptr+ parse-proc-contract-list drop 295 | end 296 | drop 297 | 298 | true inside-proc !bool 299 | 300 | prok proc-define 301 | end 302 | 303 | proc introduce-injection 304 | ptr // token 305 | ptr // lexer 306 | in 307 | memory lexer_ sizeof(ptr) end 308 | lexer_ !ptr 309 | memory token sizeof(Token) end 310 | sizeof(Token) swap token memcpy drop 311 | memory injekt sizeof(Injection) end 312 | sizeof(Injection) 0 injekt memset drop 313 | 314 | ops-count @64 315 | dup injekt Inject.addr ptr+ !64 316 | parse-block-stack-push 317 | 318 | OP_INJECTED 319 | ops-count @64 320 | token 321 | push-op 322 | 323 | true inside-injection !bool 324 | 325 | inside-proc @bool if 326 | injekt 327 | lexer_ @ptr over Inject.ins ptr+ parse-proc-contract-list if 328 | lexer_ @ptr over Inject.outs ptr+ parse-proc-contract-list drop 329 | end 330 | drop 331 | end 332 | 333 | injekt inject-define 334 | end -------------------------------------------------------------------------------- /4orth.porth: -------------------------------------------------------------------------------- 1 | // The porth to wasm compiler implemented over a modified Porth implementation. 2 | 3 | include "modules/4std.porth" 4 | include "modules/porth-4ork.porth" 5 | 6 | proc include-paths-add-env int ptr in 7 | getenv-check if 8 | cstr-to-str append-std 9 | include-paths-add 10 | else drop end 11 | end 12 | 13 | proc generate-wasm-op-comment ptr ptr in 14 | let op bfd in 15 | op Op.type ptr+ @int 16 | op Op.operand ptr+ @int 17 | op Op.token ptr+ 18 | let type operand token in 19 | " ;; " bfd bputs 20 | type OP_INTRINSIC = if 21 | token Token.text ptr+ @Str bfd bputs 22 | else 23 | type op-type-as-str bfd bputs 24 | " " bfd bputs 25 | operand bfd bputu 26 | end 27 | "\n" bfd bputs 28 | end 29 | end 30 | end 31 | 32 | const sizeof(wasm-mem) 65536 end // 0x10000 33 | const sizeof(porth-stack) 64 64 * end // 0x1000 34 | 35 | const wasm-data-stack sizeof(wasm-mem) sizeof(porth-stack) - end 36 | 37 | memory wasm-mem-start sizeof(int) end 38 | memory wasm-global-mem sizeof(int) end 39 | memory wasm-return-stack sizeof(int) end 40 | 41 | memory skip-inline sizeof(bool) end 42 | 43 | memory proc-layers sizeof(int) OPS_CAP * end 44 | memory proc-index sizeof(int) end 45 | 46 | inline proc proc-get int -- int in sizeof(int) * proc-layers +ptr @int end 47 | inline proc proc-set int in proc-index @int sizeof(int) * proc-layers +ptr !int end 48 | inline proc proc-iota int -- int in proc-set proc-index @int proc-index inc64 end 49 | 50 | memory ifstar-layers sizeof(int) sizeof(int) * 8 * end 51 | memory ifstar-current sizeof(int) end 52 | 53 | inline proc @ifstar-count -- int in ifstar-layers ifstar-current @int sizeof(int) * ptr+ @int end 54 | inline proc !ifstar-count int in ifstar-layers ifstar-current @int sizeof(int) * ptr+ !int end 55 | inline proc ifstar-count.inc in @ifstar-count 1 + !ifstar-count end 56 | inline proc ifstar-count.dec in @ifstar-count 1 - !ifstar-count end 57 | 58 | proc generate-op-wat 59 | int // ip 60 | ptr // bfd 61 | in 62 | let ip bfd in 63 | ip sizeof(Op) * ops +ptr 64 | let op in 65 | op Op.type ptr+ @int 66 | op Op.operand ptr+ @int 67 | let type operand in 68 | assert "Exhaustive handling of Op types in generate-op-wat" COUNT_OPS 27 = end 69 | skip-inline @bool if 70 | else type OP_RET = if* 71 | operand 0 > if 72 | " i32.const " bfd bputs operand bfd bputu 73 | " call $free_local" bfd bputs 74 | end 75 | ")" bfd bputs 76 | else type OP_PUSH_INT = if* 77 | memory int-value sizeof(int) end operand int-value !int 78 | " i32.const " bfd bputs int-value @32 bfd bputu 79 | " call $push" bfd bputs 80 | else type OP_PUSH_BOOL = if* 81 | " i32.const " bfd bputs operand bfd bputu 82 | " call $push" bfd bputs 83 | else type OP_PUSH_PTR = if* 84 | " i32.const " bfd bputs operand bfd bputu 85 | " call $push" bfd bputs 86 | else type OP_PUSH_ADDR = if* 87 | " i32.const " bfd bputs 88 | proc-index @int while dup 0 >= over proc-get operand != land do 89 | 1 - 90 | end bfd bputu 91 | " call $push" bfd bputs 92 | else type OP_CALL_LIKE = if* 93 | " call $pop" bfd bputs 94 | " call_indirect (type $CallLike)" bfd bputs 95 | else type OP_BIND_LET = if* 96 | 0 while dup operand < do 97 | " call $bind" bfd bputs 98 | 1 + 99 | end drop 100 | else type OP_BIND_PEEK = if* 101 | 0 while dup operand < do 102 | " call $bind" bfd bputs 103 | 1 + 104 | end drop 105 | 0 while dup operand < do 106 | "\n i32.const " bfd bputs dup 1 + 4 * bfd bputu 107 | " call $push_bind" bfd bputs 108 | 1 + 109 | end drop 110 | else type OP_UNBIND = if* 111 | " i32.const " bfd bputs operand 4 * bfd bputu 112 | " call $free_local" bfd bputs 113 | else type OP_PUSH_BIND = if* 114 | " i32.const " bfd bputs operand 1 + 4 * bfd bputu 115 | " call $push_bind" bfd bputs 116 | else type OP_PUSH_LOCAL_MEM = if* 117 | " global.get $RETURN_STACK_TOP" bfd bputs 118 | " i32.const " bfd bputs operand 8 / 1 + 4 * bfd bputu 119 | " i32.sub call $push" bfd bputs 120 | else type OP_PUSH_GLOBAL_MEM = if* 121 | " i32.const " bfd bputs operand wasm-global-mem @int + bfd bputu 122 | " call $push" bfd bputs 123 | else type OP_PUSH_STR = if* 124 | " i32.const " bfd bputs op Op.token ptr+ Token.value ptr+ @Str drop bfd bputu 125 | " call $push" bfd bputs 126 | " global.get $str" bfd bputs operand bfd bputu 127 | " call $push" bfd bputs 128 | else type OP_PUSH_CSTR = if* 129 | " global.get $str" bfd bputs operand bfd bputu 130 | " call $push" bfd bputs 131 | else type OP_INJECTED = if* 132 | else type OP_INJECT_CODE = if* 133 | operand sizeof(Str) * injections +ptr @Str bfd bputs 134 | else type OP_IF = if* 135 | ifstar-current inc64 136 | " call $pop" bfd bputs 137 | " if" bfd bputs 138 | else type OP_IFSTAR = if* 139 | ifstar-count.inc 140 | " call $pop" bfd bputs 141 | " if" bfd bputs 142 | else type OP_ELSE = if* 143 | " else" bfd bputs 144 | else type OP_END_WHILE = if* 145 | " br $while" bfd bputs operand 1 + bfd bputu 146 | " end" bfd bputs 147 | " end" bfd bputs 148 | else type OP_END_IF = if* 149 | while @ifstar-count 0 > do 150 | " end" bfd bputs 151 | ifstar-count.dec 152 | end ifstar-current dec64 153 | 154 | " end" bfd bputs 155 | else type OP_WHILE = if* 156 | " loop $while" bfd bputs operand bfd bputu 157 | else type OP_DO = if* 158 | " call $pop" bfd bputs 159 | " if" bfd bputs 160 | else type OP_PREP_PROC = if* 161 | op Op.token ptr+ Token.text ptr+ @Str proc-lookup-by-name 162 | let prok in 163 | prok NULL ptr= if 164 | here eputs ": Assertion Failed: couldn't find proc name by token text" eputs 165 | 1 exit 166 | end 167 | 168 | prok Proc.inlinable ptr+ @bool 169 | prok Proc.imported ptr+ @int 0 != lor 170 | if 171 | true skip-inline !bool 172 | else 173 | false skip-inline !bool 174 | "\n(elem (i32.const " bfd bputs ip proc-iota bfd bputu 175 | ") $f" bfd bputs ip bfd bputu 176 | ")\n(func $f" bfd bputs ip bfd bputu 177 | 178 | " ;; proc " bfd bputs prok Proc.name ptr+ @Str bfd bputs 179 | 180 | operand 0 > if 181 | "\n i32.const " bfd bputs operand bfd bputu 182 | " call $aloc_local" bfd bputs 183 | end 184 | end 185 | end 186 | else type OP_CALL = if* 187 | op Op.token ptr+ Token.text ptr+ @Str proc-lookup-by-name 188 | let prok in 189 | prok NULL ptr= if 190 | here eputs ": Assertion Failed: couldn't find proc name by token text" eputs 191 | 1 exit 192 | end 193 | prok Proc.imported ptr+ @int 0 != if 194 | prok Proc.ins ptr+ 195 | TypeStack.top ptr+ @ptr 196 | dup NULL ptr!= if 197 | while dup NULL ptr!= do 198 | " call $pop" bfd bputs 199 | TypeFrame.prev ptr+ @ptr 200 | end drop 201 | else drop end 202 | end 203 | " call $f" bfd bputs 204 | prok Proc.name ptr+ @Str "rnd" streq if 205 | "rnd" bfd bputs 206 | else 207 | operand bfd bputu 208 | end 209 | prok Proc.imported ptr+ @int 0 != if 210 | prok Proc.outs ptr+ 211 | TypeStack.top ptr+ @ptr 212 | dup NULL ptr!= if 213 | while dup NULL ptr!= do 214 | " call $push" bfd bputs 215 | TypeFrame.prev ptr+ @ptr 216 | end drop 217 | else drop end 218 | end 219 | end 220 | else type OP_INLINED = if* 221 | else type OP_INTRINSIC = if* 222 | assert "Exhaustive handling of Intrinsics in generate-op-wat" 223 | COUNT_INTRINSICS 46 = 224 | end 225 | 226 | operand INTRINSIC_PLUS = if 227 | " call $pop" bfd bputs 228 | " call $pop" bfd bputs 229 | " i32.add" bfd bputs 230 | " call $push" bfd bputs 231 | else operand INTRINSIC_MINUS = if* 232 | " call $swap" bfd bputs 233 | " call $pop" bfd bputs 234 | " call $pop" bfd bputs 235 | " i32.sub" bfd bputs 236 | " call $push" bfd bputs 237 | else operand INTRINSIC_MUL = if* 238 | " call $pop" bfd bputs 239 | " call $pop" bfd bputs 240 | " i32.mul" bfd bputs 241 | " call $push" bfd bputs 242 | else operand INTRINSIC_DIVMOD = if* 243 | " call $divmod" bfd bputs 244 | else operand INTRINSIC_IDIVMOD = if* 245 | " call $divmod" bfd bputs 246 | else operand INTRINSIC_MAX = if* 247 | " call $pop" bfd bputs 248 | " f32.convert_i32_s" bfd bputs 249 | " call $pop" bfd bputs 250 | " f32.convert_i32_s" bfd bputs 251 | " f32.max " bfd bputs 252 | " i32.trunc_f32_s" bfd bputs 253 | " call $push" bfd bputs 254 | else operand INTRINSIC_SHR = if* 255 | " call $swap" bfd bputs 256 | " call $pop" bfd bputs 257 | " call $pop" bfd bputs 258 | " i32.shr_s" bfd bputs 259 | " call $push" bfd bputs 260 | else operand INTRINSIC_SHL = if* 261 | " call $swap" bfd bputs 262 | " call $pop" bfd bputs 263 | " call $pop" bfd bputs 264 | " i32.shl" bfd bputs 265 | " call $push" bfd bputs 266 | else operand INTRINSIC_OR = if* 267 | " call $pop" bfd bputs 268 | " call $pop" bfd bputs 269 | " i32.or" bfd bputs 270 | " call $push" bfd bputs 271 | else operand INTRINSIC_AND = if* 272 | " call $pop" bfd bputs 273 | " call $pop" bfd bputs 274 | " i32.and" bfd bputs 275 | " call $push" bfd bputs 276 | else operand INTRINSIC_NOT = if* 277 | " call $pop" bfd bputs 278 | " i32.const -1" bfd bputs 279 | " i32.xor" bfd bputs 280 | " call $push" bfd bputs 281 | else operand INTRINSIC_PRINT = if* 282 | " call $pop" bfd bputs 283 | " call $f" bfd bputs 284 | "trace" proc-lookup-by-name 285 | Proc.addr ptr+ @int bfd bputu 286 | else operand INTRINSIC_EQ = if* 287 | " call $pop" bfd bputs 288 | " call $pop" bfd bputs 289 | " i32.eq" bfd bputs 290 | " call $push" bfd bputs 291 | else operand INTRINSIC_GT = if* 292 | " call $swap" bfd bputs 293 | " call $pop" bfd bputs 294 | " call $pop" bfd bputs 295 | " i32.gt_s" bfd bputs 296 | " call $push" bfd bputs 297 | else operand INTRINSIC_LT = if* 298 | " call $swap" bfd bputs 299 | " call $pop" bfd bputs 300 | " call $pop" bfd bputs 301 | " i32.lt_s" bfd bputs 302 | " call $push" bfd bputs 303 | else operand INTRINSIC_GE = if* 304 | " call $swap" bfd bputs 305 | " call $pop" bfd bputs 306 | " call $pop" bfd bputs 307 | " i32.ge_s" bfd bputs 308 | " call $push" bfd bputs 309 | else operand INTRINSIC_LE = if* 310 | " call $swap" bfd bputs 311 | " call $pop" bfd bputs 312 | " call $pop" bfd bputs 313 | " i32.le_s" bfd bputs 314 | " call $push" bfd bputs 315 | else operand INTRINSIC_NE = if* 316 | " call $pop" bfd bputs 317 | " call $pop" bfd bputs 318 | " i32.ne" bfd bputs 319 | " call $push" bfd bputs 320 | else operand INTRINSIC_DUP = if* 321 | " call $dup" bfd bputs 322 | else operand INTRINSIC_SWAP = if* 323 | " call $swap" bfd bputs 324 | else operand INTRINSIC_DROP = if* 325 | " call $drop" bfd bputs 326 | else operand INTRINSIC_OVER = if* 327 | " call $over" bfd bputs 328 | else operand INTRINSIC_ROT = if* 329 | " call $rot" bfd bputs 330 | else operand INTRINSIC_LOAD8 = if* 331 | " call $pop" bfd bputs 332 | " i32.load8_u" bfd bputs 333 | " call $push" bfd bputs 334 | else operand INTRINSIC_STORE8 = if* 335 | " call $pop" bfd bputs 336 | " call $pop" bfd bputs 337 | " i32.store8" bfd bputs 338 | else operand INTRINSIC_LOAD16 = if* 339 | " call $pop" bfd bputs 340 | " i32.load16_u" bfd bputs 341 | " call $push" bfd bputs 342 | else operand INTRINSIC_STORE16 = if* 343 | " call $pop" bfd bputs 344 | " call $pop" bfd bputs 345 | " i32.store16" bfd bputs 346 | else operand INTRINSIC_LOAD32 = if* 347 | " call $pop" bfd bputs 348 | " i32.load" bfd bputs 349 | " call $push" bfd bputs 350 | else operand INTRINSIC_STORE32 = if* 351 | " call $pop" bfd bputs 352 | " call $pop" bfd bputs 353 | " i32.store" bfd bputs 354 | else operand INTRINSIC_LOAD64 = if* 355 | here eputs ": 4orth does not support u64.\n" eputs 356 | 1 exit 357 | else operand INTRINSIC_STORE64 = if* 358 | here eputs ": 4orth does not support u64.\n" eputs 359 | 1 exit 360 | else operand INTRINSIC_ARGC = if* 361 | else operand INTRINSIC_ARGV = if* 362 | else operand INTRINSIC_ENVP = if* 363 | else operand INTRINSIC_CAST_PTR = if* 364 | else operand INTRINSIC_CAST_INT = if* 365 | else operand INTRINSIC_CAST_BOOL = if* 366 | else operand INTRINSIC_CAST_ADDR = if* 367 | else operand INTRINSIC_SYSCALL0 = if* 368 | else operand INTRINSIC_SYSCALL1 = if* 369 | else operand INTRINSIC_SYSCALL2 = if* 370 | else operand INTRINSIC_SYSCALL3 = if* 371 | else operand INTRINSIC_SYSCALL4 = if* 372 | else operand INTRINSIC_SYSCALL5 = if* 373 | else operand INTRINSIC_SYSCALL6 = if* 374 | else operand INTRINSIC_??? = if* 375 | else 376 | here eputs ": unreachable. Invalid intrinsic.\n" eputs 377 | 1 exit 378 | end 379 | else 380 | here eputs ": unreachable. Invalid op.\n" eputs 381 | 1 exit 382 | end 383 | skip-inline @bool if 384 | type OP_RET = if 385 | false skip-inline !bool 386 | end 387 | else 388 | op bfd generate-wasm-op-comment 389 | // "\n" bfd bputs 390 | end 391 | end 392 | end 393 | end 394 | end 395 | 396 | memory raw-wasm sizeof(bool) end 397 | 398 | proc generate-wasm-imports 399 | int // ip 400 | ptr // bfd 401 | in 402 | over sizeof(Op) * ops +ptr Op.type ptr+ @int OP_PREP_PROC = if 403 | let ip bfd in 404 | ip sizeof(Op) * ops +ptr Op.token ptr+ Token.text ptr+ dup @Str 405 | proc-lookup-by-name 406 | let name prok in 407 | prok NULL ptr= if 408 | here eputs ": Assertion Failed: couldn't find proc name by token text" eputs 409 | 1 exit 410 | end 411 | prok Proc.imported ptr+ @int 0 != if 412 | "(import \"" bfd bputs 413 | prok Proc.imported ptr+ @int 1 - sizeof(Str) * 414 | wasm-modules +ptr @Str bfd bputs 415 | "\" \"" bfd bputs 416 | name @Str bfd bputs 417 | "\" (func $f" bfd bputs ip bfd bputu 418 | prok Proc.ins ptr+ 419 | TypeStack.top ptr+ @ptr 420 | dup NULL ptr!= if 421 | " (param" bfd bputs 422 | while dup NULL ptr!= do 423 | " i32" bfd bputs 424 | TypeFrame.prev ptr+ @ptr 425 | end drop 426 | ")" bfd bputs 427 | else drop end 428 | prok Proc.outs ptr+ 429 | TypeStack.top ptr+ @ptr 430 | dup NULL ptr!= if 431 | " (result" bfd bputs 432 | while dup NULL ptr!= do 433 | " i32" bfd bputs 434 | TypeFrame.prev ptr+ @ptr 435 | end drop 436 | ")" bfd bputs 437 | else drop end 438 | "))\n" bfd bputs 439 | end 440 | end 441 | end 442 | else drop drop end 443 | end 444 | 445 | proc generate-wasm-exports 446 | int // ip 447 | ptr // bfd 448 | in 449 | let ip bfd in 450 | ip sizeof(export) * exports +ptr dup @Str 451 | proc-lookup-by-name swap sizeof(Str) ptr+ 452 | let prok eksport in 453 | prok NULL ptr!= if 454 | "(export \"" bfd bputs 455 | eksport @Str bfd bputs 456 | "\"" bfd bputs 457 | " (func $f" bfd bputs 458 | prok Proc.addr ptr+ @int bfd bputu 459 | "))\n" bfd bputs 460 | end 461 | end 462 | end 463 | end 464 | 465 | proc inc-by-char-count ptr ptr in 466 | memory str sizeof(Str) end 467 | @Str str !Str 468 | memory count sizeof(ptr) end 469 | count !ptr 470 | 471 | while 472 | while 473 | str @Str.count 0 > "\\" 474 | str @Str str-starts-with 475 | lnot land 476 | do 477 | count @ptr inc64 478 | str str-chop-one-left 479 | end 480 | str @Str.count 3 >= "\\" 481 | str @Str str-starts-with 482 | land 483 | do 484 | str 3 485 | str-chop-left-by 486 | count @ptr inc64 487 | end 488 | end 489 | 490 | proc generate-wat 491 | ptr // file-path 492 | in 493 | memory char-counter sizeof(int) end 494 | 0 char-counter !int 495 | 496 | memory bfd sizeof(Bfd) end 497 | sizeof(Bfd) 0 bfd memset drop 498 | 499 | let file-path in 500 | silent @bool lnot if 501 | "[INFO] Generating " puts 502 | file-path cstr-to-str puts 503 | "\n" puts 504 | end 505 | 506 | 420 // mode 507 | O_CREAT O_WRONLY or O_TRUNC or // flags 508 | file-path // pathname 509 | AT_FDCWD 510 | openat 511 | 512 | BFD_CAP tmp-alloc 513 | let fd buff in 514 | fd bfd Bfd.fd ptr+ !int 515 | buff bfd Bfd.buff ptr+ !ptr 516 | 517 | fd 0 < if 518 | "[ERROR] could not open file\n" eputs 519 | 1 exit 520 | end 521 | 522 | "(type $CallLike (func))\n\n" bfd bputs 523 | 524 | 0 while dup ops-count @64 < do 525 | dup bfd generate-wasm-imports 526 | 1 + 527 | end drop 528 | 529 | raw-wasm @bool if 530 | "(memory 1)\n" bfd bputs 531 | "(export \"memory\" (memory 0))\n" bfd bputs 532 | else 533 | 6560 wasm-mem-start !int // 0x19a0 534 | "(import \"" bfd bputs 535 | wasm-modules @Str bfd bputs 536 | "\" \"memory\" (memory 1))\n" bfd bputs 537 | end 538 | 539 | 0 while dup strlits-count @64 < do 540 | let i in 541 | i sizeof(Str) * strlits +ptr 542 | let str in 543 | str ?str-empty lnot if 544 | "\n(global $str" bfd bputs i bfd bputu 545 | " i32 (i32.const " bfd bputs 546 | char-counter @int wasm-mem-start @int + bfd bputu 547 | "))" bfd bputs 548 | char-counter str 549 | inc-by-char-count 550 | end 551 | end 552 | i 1 + 553 | end 554 | end drop 555 | 556 | wasm-mem-start @int 557 | char-counter @int 558 | 8 / 1 + 8 * + dup 559 | wasm-global-mem !int 560 | global-memory-capacity @int + 561 | wasm-return-stack !int 562 | 563 | wasm-return-stack @int wasm-data-stack > if 564 | "[ERROR] Global memory size exceeds the limits\n" eputs 565 | "[INFO] use ./4orth summary to view more details\n" puts 566 | 1 exit 567 | end 568 | 569 | "\n(global $RETURN_STACK_TOP (mut i32) (i32.const " bfd bputs wasm-return-stack @int bfd bputu "))" bfd bputs 570 | "\n(global $DATA_STACK_TOP (mut i32) (i32.const " bfd bputs wasm-data-stack bfd bputu "))" bfd bputs 571 | "\n(global $DATA_STACK i32 (i32.const " bfd bputs wasm-data-stack bfd bputu "))\n\n" bfd bputs 572 | 573 | "(func $dup (local i32)\n" bfd bputs 574 | " call $pop local.tee 0\n" bfd bputs 575 | " call $push local.get 0\n" bfd bputs 576 | " call $push)\n\n" bfd bputs 577 | "(func $swap (local i32)\n" bfd bputs 578 | " call $pop\n" bfd bputs 579 | " call $pop local.set 0\n" bfd bputs 580 | " call $push local.get 0\n" bfd bputs 581 | " call $push)\n\n" bfd bputs 582 | "(func $over (local i32 i32)\n" bfd bputs 583 | " call $pop local.set 1\n" bfd bputs 584 | " call $pop local.tee 0\n" bfd bputs 585 | " call $push local.get 1\n" bfd bputs 586 | " call $push local.get 0\n" bfd bputs 587 | " call $push)\n\n" bfd bputs 588 | "(func $drop call $pop drop)\n\n" bfd bputs 589 | "(func $rot (local i32)\n" bfd bputs 590 | " call $pop\n" bfd bputs 591 | " call $pop\n" bfd bputs 592 | " call $pop local.set 0\n" bfd bputs 593 | " call $push\n" bfd bputs 594 | " call $push local.get 0\n" bfd bputs 595 | " call $push)\n\n" bfd bputs 596 | "(func $divmod (local i32 i32)\n" bfd bputs 597 | " call $pop local.set 0\n" bfd bputs 598 | " call $pop local.tee 1\n" bfd bputs 599 | " local.get 0 i32.rem_s\n" bfd bputs 600 | " local.get 1 local.get 0\n" bfd bputs 601 | " i32.div_s call $push\n" bfd bputs 602 | " call $push)\n\n" bfd bputs 603 | "(func $push (param i32)\n" bfd bputs 604 | " global.get $DATA_STACK_TOP\n" bfd bputs 605 | " local.get 0 i32.store\n" bfd bputs 606 | " global.get $DATA_STACK_TOP\n" bfd bputs 607 | " i32.const 4 i32.add \n" bfd bputs 608 | " global.set $DATA_STACK_TOP)\n\n" bfd bputs 609 | "(func $pop (result i32)\n" bfd bputs 610 | " global.get $DATA_STACK_TOP\n" bfd bputs 611 | " i32.const 4 i32.sub\n" bfd bputs 612 | " global.set $DATA_STACK_TOP\n" bfd bputs 613 | " global.get $DATA_STACK_TOP\n" bfd bputs 614 | " i32.load)\n\n" bfd bputs 615 | "(func $aloc_local (param i32)\n" bfd bputs 616 | " (local i32)\n" bfd bputs 617 | " global.get $RETURN_STACK_TOP\n" bfd bputs 618 | " local.get 0 i32.add local.tee 1\n" bfd bputs 619 | " global.get $DATA_STACK i32.ge_u\n" bfd bputs 620 | " if unreachable end local.get 1\n" bfd bputs 621 | " global.set $RETURN_STACK_TOP)\n\n" bfd bputs 622 | "(func $free_local (param i32)\n" bfd bputs 623 | " global.get $RETURN_STACK_TOP\n" bfd bputs 624 | " local.get 0 i32.sub\n" bfd bputs 625 | " global.set $RETURN_STACK_TOP\n" bfd bputs 626 | " global.get $RETURN_STACK_TOP\n" bfd bputs 627 | " i32.const 0 local.get 0 \n" bfd bputs 628 | " memory.fill)\n\n" bfd bputs 629 | "(func $bind\n" bfd bputs 630 | " global.get $RETURN_STACK_TOP \n" bfd bputs 631 | " call $pop i32.store\n" bfd bputs 632 | " i32.const 4 call $aloc_local)\n\n" bfd bputs 633 | "(func $push_bind (param i32)\n" bfd bputs 634 | " global.get $RETURN_STACK_TOP\n" bfd bputs 635 | " local.get 0 i32.sub i32.load \n" bfd bputs 636 | " call $push)\n" bfd bputs 637 | 638 | "main" proc-lookup-by-name 639 | let main-proc in 640 | main-proc NULL ptr= if 641 | here eputs ": Assertion Failed: type checking phase did not check the existence of `main` procedure\n" eputs 642 | 1 exit 643 | end 644 | end 645 | 646 | 0 ifstar-current !int 647 | 0 while dup ops-count @64 < do 648 | dup bfd generate-op-wat 649 | 1 + 650 | end drop 651 | 652 | "\n(table " bfd bputs 653 | proc-index @64 bfd bputu 654 | " funcref)\n" bfd bputs 655 | 656 | 0 while dup exports-count @64 < do 657 | dup bfd generate-wasm-exports 658 | 1 + 659 | end drop 660 | 661 | strlits-count @64 0 > if 662 | "(data (i32.const " bfd bputs wasm-mem-start @int bfd bputu ")\n" bfd bputs 663 | 664 | 0 while dup strlits-count @64 < do 665 | let i in 666 | i sizeof(Str) * strlits +ptr 667 | let str in 668 | str ?str-empty lnot if 669 | " " bfd bputs 670 | str @Str bfd bputwatstr 671 | end 672 | end 673 | "\n" bfd bputs 674 | i 1 + 675 | end 676 | end drop 677 | ")" bfd bputs 678 | end 679 | 680 | bfd bflush 681 | fd close drop 682 | buff tmp-rewind 683 | end 684 | end 685 | end 686 | 687 | proc wasm-usage 688 | ptr // program name 689 | int // fd 690 | in 691 | let name fd in 692 | "Usage: " eputs name cstr-to-str puts " [OPTIONS] \n" fd fputs 693 | " OPTIONS:\n" fd fputs 694 | " -porth Use the original porth compiler and CLI instead of 4orth.\n" fd fputs 695 | " -unsafe Disable type checking.\n" fd fputs 696 | " -I Add to the include paths list.\n" fd fputs 697 | " SUBCOMMANDS:\n" fd fputs 698 | " com [OPTIONS] Compile the program\n" fd fputs 699 | " OPTIONS:\n" fd fputs 700 | // TODO: implement -o flag for com subcommand 701 | " -r Run the program after successful compilation\n" fd fputs 702 | " -b Bundles the program to a linux executable. (If with -r, executes the bundle)\n" fd fputs 703 | " -opt Optimize the program with wasm-opt\n" fd fputs 704 | " -wat Transforms the stripped program back from the final `.wasm` to `.wat` \n" fd fputs 705 | " -wasm Target WASM instead of Wasm4 (doesn't support -b or -r)\n" fd fputs 706 | " -s Silent mode. Don't print any info about compilation phases\n" fd fputs 707 | " -o File to write the result to \n" fd fputs 708 | // " dump Dump the ops of the program\n" fd fputs 709 | // " lex Produce lexical analysis of the file\n" fd fputs 710 | // " summary Print the summary of the program\n" fd fputs 711 | " help Print this help to stdout and exit with 0 code\n" fd fputs 712 | end 713 | end 714 | 715 | proc wasm-main in 716 | memory output-file-path-cstr sizeof(ptr) end 717 | NULL output-file-path-cstr !ptr 718 | memory optimize sizeof(bool) end 719 | false optimize !bool 720 | memory wasm2wat sizeof(bool) end 721 | false wasm2wat !bool 722 | memory bundle sizeof(bool) end 723 | false bundle !bool 724 | memory output sizeof(bool) end 725 | false output !bool 726 | 727 | args @@ptr "com"c cstreq if 728 | while 729 | args sizeof(ptr) inc64-by 730 | args @@ptr NULL ptr= if 731 | false // break 732 | else args @@ptr "-r"c cstreq if* 733 | true run !bool 734 | true // continue 735 | else args @@ptr "-s"c cstreq if* 736 | true silent !bool 737 | true // continue 738 | else args @@ptr "-b"c cstreq if* 739 | true bundle !bool 740 | true // continue 741 | else args @@ptr "-opt"c cstreq if* 742 | true optimize !bool 743 | true // continue 744 | else args @@ptr "-wat"c cstreq if* 745 | true wasm2wat !bool 746 | true // continue 747 | else args @@ptr "-wasm"c cstreq if* 748 | true raw-wasm !bool 749 | true // continue 750 | else args @@ptr "-o"c cstreq if* 751 | true output !bool 752 | args sizeof(ptr) inc64-by 753 | args @@ptr NULL ptr= if 754 | false 755 | else 756 | args @@ptr output-file-path-cstr !ptr 757 | true // continue 758 | end 759 | else 760 | args @@ptr input-file-path-cstr !ptr 761 | args sizeof(ptr) inc64-by 762 | false // break 763 | end 764 | do end 765 | 766 | input-file-path-cstr @ptr NULL ptr= if 767 | program @ptr stderr wasm-usage 768 | "[ERROR] no input file is provided for the compilation.\n" eputs 769 | 1 exit 770 | end 771 | 772 | raw-wasm @bool run @bool bundle @bool lor land if 773 | "ERROR: Wasm compile option can't be used with bundle or run\n" eputs 774 | 1 exit 775 | end 776 | 777 | input-file-path-cstr @ptr cstr-to-str remove-ext base-file-path !Str 778 | 779 | input-file-path-cstr @ptr compile-program-into-ops 780 | unsafe @bool lnot if type-check-program end 781 | 782 | output @bool if 783 | output-file-path-cstr @ptr cstr-to-str remove-ext base-file-path !Str 784 | end 785 | 786 | timeit/from-here 787 | fpb-end 788 | base-file-path @Str fpb-append drop 789 | ".wat" fpb-append drop 790 | 1 fpb-alloc drop 791 | dup generate-wat 792 | fpb-rewind 793 | "[INFO] Generation" silent @bool timeit/to-here 794 | 795 | timeit/from-here 796 | cmd-dev-null-stdout @bool 797 | silent @bool cmd-dev-null-stdout !bool 798 | fpb-end 799 | tmp-end 800 | "wat2wasm"c tmp-append-ptr 801 | "--enable-bulk-memory"c tmp-append-ptr 802 | fpb-end 803 | base-file-path @Str fpb-append drop 804 | ".wat" fpb-append drop 805 | 1 fpb-alloc drop 806 | tmp-append-ptr 807 | "-o"c tmp-append-ptr 808 | fpb-end 809 | base-file-path @Str fpb-append drop 810 | ".wasm" fpb-append drop 811 | 1 fpb-alloc drop 812 | tmp-append-ptr 813 | NULL tmp-append-ptr 814 | silent @bool lnot cmd-echoed 815 | fpb-rewind 816 | cmd-dev-null-stdout !bool 817 | "[INFO] wat2wasm" silent @bool timeit/to-here 818 | 819 | optimize @bool if 820 | fpb-end 821 | tmp-end 822 | "wasm-opt"c tmp-append-ptr 823 | "-Oz"c tmp-append-ptr 824 | "--enable-bulk-memory"c tmp-append-ptr 825 | fpb-end 826 | base-file-path @Str fpb-append drop 827 | ".wasm" fpb-append drop 828 | 1 fpb-alloc drop 829 | tmp-append-ptr 830 | "-o"c tmp-append-ptr 831 | fpb-end 832 | base-file-path @Str fpb-append drop 833 | ".wasm" fpb-append drop 834 | 1 fpb-alloc drop 835 | tmp-append-ptr 836 | NULL tmp-append-ptr 837 | silent @bool lnot cmd-echoed 838 | fpb-rewind 839 | end 840 | 841 | wasm2wat @bool if 842 | fpb-end 843 | tmp-end 844 | "wasm2wat"c tmp-append-ptr 845 | "--enable-bulk-memory"c tmp-append-ptr 846 | fpb-end 847 | base-file-path @Str fpb-append drop 848 | ".wasm" fpb-append drop 849 | 1 fpb-alloc drop 850 | tmp-append-ptr 851 | "-o"c tmp-append-ptr 852 | fpb-end 853 | base-file-path @Str fpb-append drop 854 | ".wat" fpb-append drop 855 | 1 fpb-alloc drop 856 | tmp-append-ptr 857 | NULL tmp-append-ptr 858 | silent @bool lnot cmd-echoed 859 | fpb-rewind 860 | end 861 | 862 | bundle @bool if 863 | fpb-end 864 | tmp-end 865 | "w4"c tmp-append-ptr 866 | "bundle"c tmp-append-ptr 867 | "--title"c tmp-append-ptr 868 | "4orth Game"c tmp-append-ptr 869 | "--linux"c tmp-append-ptr 870 | fpb-end 871 | base-file-path @Str fpb-append drop 872 | 1 fpb-alloc drop 873 | tmp-append-ptr 874 | fpb-end 875 | base-file-path @Str fpb-append drop 876 | ".wasm" fpb-append drop 877 | 1 fpb-alloc drop 878 | tmp-append-ptr 879 | NULL tmp-append-ptr 880 | silent @bool lnot cmd-echoed 881 | fpb-rewind 882 | 883 | run @bool if 884 | fpb-end 885 | tmp-end 886 | fpb-end 887 | base-file-path @Str fpb-append drop 888 | 1 fpb-alloc drop 889 | tmp-append-ptr 890 | NULL tmp-append-ptr 891 | silent @bool lnot cmd-echoed 892 | fpb-rewind 893 | end 894 | else run @bool if* 895 | fpb-end 896 | tmp-end 897 | "w4"c tmp-append-ptr 898 | "run"c tmp-append-ptr 899 | fpb-end 900 | base-file-path @Str fpb-append drop 901 | ".wasm" fpb-append drop 902 | 1 fpb-alloc drop 903 | tmp-append-ptr 904 | NULL tmp-append-ptr 905 | silent @bool lnot cmd-echoed 906 | fpb-rewind 907 | end 908 | 909 | else args @@ptr "help"c cstreq if* 910 | program @ptr stdout wasm-usage 911 | 0 exit 912 | else args @@ptr "dump"c cstreq if* 913 | args sizeof(ptr) inc64-by 914 | args @@ptr NULL ptr= if 915 | program @ptr stderr wasm-usage 916 | "ERROR: no input file is provided for the `dump` subcommand\n" eputs 917 | 1 exit 918 | end 919 | 920 | args @@ptr compile-program-into-ops 921 | unsafe @bool lnot if type-check-program end 922 | 923 | dump-ops 924 | else args @@ptr "lex"c cstreq if* 925 | args sizeof(ptr) inc64-by 926 | args @@ptr NULL ptr= if 927 | program @ptr stderr wasm-usage 928 | "ERROR: no input file is provided for the `lex` subcommand\n" eputs 929 | 1 exit 930 | end 931 | 932 | args @@ptr lex-file 933 | else args @@ptr "summary"c cstreq if* 934 | args sizeof(ptr) inc64-by 935 | args @@ptr NULL ptr= if 936 | program @ptr stderr wasm-usage 937 | "ERROR: no input file is provided for the `dump` subcommand\n" eputs 938 | 1 exit 939 | end 940 | 941 | args @@ptr compile-program-into-ops 942 | unsafe @bool lnot if type-check-program end 943 | 944 | summary 945 | else 946 | program @ptr stderr wasm-usage 947 | "ERROR: unknown subcommand `" eputs args @@ptr cstr-to-str eputs "`\n" eputs 948 | 1 exit 949 | end 950 | end 951 | 952 | proc main in 953 | // Default include paths 954 | "." include-paths-add 955 | "./std" include-paths-add 956 | "./porth/std" include-paths-add 957 | "_4ORTH" include-paths-add-env 958 | "PORTH" include-paths-add-env 959 | 960 | NULL input-file-path-cstr !ptr 961 | 0 NULL base-file-path !Str 962 | false run !bool 963 | 964 | argv args !ptr 965 | args @@ptr program !ptr 966 | false unsafe !bool 967 | 968 | memory porth-mode sizeof(bool) end 969 | false porth-mode !bool 970 | 971 | while 972 | args sizeof(ptr) inc64-by 973 | args @@ptr NULL ptr= if 974 | false // break 975 | else args @@ptr "-unsafe"c cstreq if* 976 | true unsafe !bool 977 | true // continue 978 | else args @@ptr "-I"c cstreq if* 979 | args sizeof(ptr) inc64-by 980 | args @@ptr 981 | dup ?null if 982 | "ERROR: no argument is provided for -I flag\n" eputs 983 | 1 exit 984 | end 985 | dup cstr-to-str include-paths-add 986 | drop 987 | true // continue 988 | else args @@ptr "-porth"c cstreq if* 989 | true porth-mode !bool 990 | true // continue 991 | else 992 | false // break 993 | end 994 | do end 995 | 996 | args @@ptr NULL ptr= if 997 | program @ptr stderr 998 | porth-mode @bool if usage else wasm-usage end 999 | "ERROR: subcommand is not provided\n" eputs 1000 | 1 exit 1001 | end 1002 | 1003 | porth-mode @bool if 1004 | porth-main 1005 | else 1006 | wasm-main 1007 | end 1008 | end --------------------------------------------------------------------------------