├── .gitattributes ├── .github ├── build.sh └── workflows │ └── build.yml ├── .gitignore ├── LICENSE ├── README ├── build.sh ├── forth.img └── forth.scr /.gitattributes: -------------------------------------------------------------------------------- 1 | forth.scr linguist-language=Forth 2 | -------------------------------------------------------------------------------- /.github/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | case "$1" in 6 | ubuntu-*) 7 | export COMPAT_LINUX= 8 | 9 | sudo apt-get update 10 | sudo apt-get install bmake clang 11 | ;; 12 | macos-*) 13 | export COMPAT_MACOS= 14 | 15 | brew update 16 | brew install bmake 17 | ;; 18 | esac 19 | 20 | mkdir build 21 | cd build 22 | 23 | git clone https://github.com/ablevm/libable 24 | git clone https://github.com/ablevm/able 25 | git clone https://github.com/ablevm/forth-img 26 | git clone https://github.com/ablevm/forth-scr 27 | 28 | cd libable 29 | cp config.mk.def config.mk 30 | bmake 31 | sudo bmake install 32 | cd .. 33 | 34 | cd libable/misc 35 | cp config.mk.def config.mk 36 | sudo bmake install 37 | cd ../.. 38 | 39 | cd able 40 | cp config.mk.def config.mk 41 | bmake 42 | sudo bmake install 43 | cd .. 44 | 45 | cd forth-img 46 | bmake 47 | sudo bmake install 48 | cd .. 49 | 50 | cd forth-scr 51 | bmake 52 | sudo bmake install 53 | cd .. 54 | 55 | cd .. 56 | rm -rf build 57 | 58 | img -r 1M forth.img 59 | scr -r forth.scr | img -s 256B -i 128B forth.img 60 | echo '." SUCCESS" cr bye' | able forth.img | grep SUCCESS 61 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: [push, pull_request] 4 | 5 | defaults: 6 | run: 7 | shell: bash 8 | 9 | jobs: 10 | build: 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | - macos-latest 17 | name: Build 18 | steps: 19 | - uses: actions/checkout@v2 20 | - name: Build 21 | run: sh .github/build.sh ${{ matrix.os }} 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Mark Smith 2 | Copyright (c) 2015 Ryan Siddle 3 | Copyright (c) 2015 Merj Ltd 4 | 5 | Permission to use, copy, modify, and distribute this software for any purpose 6 | with or without fee is hereby granted, provided that the above copyright notice 7 | and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 10 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 11 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 13 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 15 | THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | able-forth 2 | 3 | able-forth implements a Forth-like programming language that targets the AbleVM 4 | 5 | REQUIREMENTS 6 | 7 | able 8 | 9 | GETTING STARTED 10 | 11 | able-forth only requires able to run but the img and scr tools are recommended 12 | for working with image and screen files (as demonstrated under "Bootstrapping") 13 | 14 | Example Session 15 | 16 | $ able forth.img 17 | ( ready for launch?) 18 | ok 19 | # 5 for i@ 1+ . cr next ." LIFTOFF!" cr 20 | 5 21 | 4 22 | 3 23 | 2 24 | 1 25 | LIFTOFF! 26 | ok 27 | bye 28 | $ 29 | 30 | Bootstrapping 31 | 32 | See build.sh for an example of how to bootstrap Able Forth 33 | 34 | GETTING INVOLVED 35 | 36 | Contact Details 37 | 38 | Find us online at ablevm.org or email us at team@ablevm.org 39 | 40 | Code of Conduct 41 | 42 | Respect each other and please don't spam 43 | 44 | LICENSE 45 | 46 | ISC-style license 47 | 48 | DETAILS 49 | 50 | Memory Map 51 | 52 | 0-64 main 53 | 54 | 0-1 boot 55 | 1-2 tasks 56 | 2- code 57 | 32-64 recv buff 58 | 59 | 64-128 reserved for deployment 60 | 61 | 128-192 Able Forth 62 | 63 | 128-129 task 64 | 129-130 eval buff 65 | 130-132 send buff 66 | 132- code 67 | 68 | 192-256 reserved for bootstrap 69 | 70 | 256- free 71 | 72 | 1024 byte blocks 73 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | img -r 1M forth.img 6 | scr -r forth.scr | img -s 256B -i 128B forth.img 7 | able forth.img <link ! 57 | # 1 `forth/ ~ load | 58 | 59 | ' [macro] ' _macro patch 60 | ' [micro] ' _micro patch 61 | ' evaluator >body # 1 task ! 62 | ' `forth/ prune 63 | 64 | 65 | # 56 forth/ ~ load | 66 | # 48 forth/ # 49 forth/ ~ thru | 67 | # 52 forth/ ~ load | 68 | # 50 forth/ # 51 forth/ ~ thru | 69 | 70 | # 132 block # 60 block # 0 cfill 71 | # 132 block here! 72 | # 0 ' patch >link ! 73 | # 1 `forth/ ~ load | 74 | 75 | ' [macro] ' _macro patch 76 | ' [micro] ' _micro patch 77 | ' evaluator >body # 1 task ! 78 | ' `forth/ prune 79 | 80 | 81 | # 55 forth/ # 56 forth/ ~ thru | 82 | 83 | # 194 block # 30 block # 0 cfill 84 | # 194 block here! 85 | # 2 forth/ ~ load | 86 | 87 | # 0 block # 1 block # 0 cfill 88 | # 0 block here! 89 | ' ?trap >body \ call ' main >body \ jump 90 | empty 91 | 92 | 93 | 94 | 95 | 96 | 97 | # 55 forth/ # 56 forth/ ~ thru | 98 | 99 | # 2 block # 30 block # 0 cfill 100 | # 2 block here! 101 | # 2 forth/ ~ load | 102 | 103 | # 0 block # 1 block # 0 cfill 104 | # 0 block here! 105 | ' ?trap >body \ call ' main >body \ jump 106 | empty 107 | 108 | 109 | 110 | 111 | 112 | 113 | `macro: push `( n ; - ; n) `$ 10 `c, `; 114 | `macro: pop `( ; n - n ;) `$ 11 `c, `; 115 | `macro: i@ `( ; n - n ; n) `$ 50 `c, `; 116 | `macro: i! `( n1 ; n2 - ; n1) `$ 51 `c, `; 117 | 118 | `macro: drop `( n -) `$ 1C `c, `; 119 | `macro: dup `( n - n n) `$ 1D `c, `; 120 | `macro: over `( n1 n2 - n1 n2 n1) `$ 1E `c, `; 121 | `macro: swap `( n1 n2 - n2 n1) `$ 1F `c, `; 122 | `macro: nip `( n1 n2 - n2) `$ 5C `c, `; 123 | `macro: tuck `( n1 n2 - n2 n1 n2) `$ 5D `c, `; 124 | `macro: rot `( n1 n2 n3 - n2 n3 n1) `$ 5E `c, `; 125 | `macro: -rot `( n1 n2 n3 - n3 n1 n2) `$ 5F `c, `; 126 | 127 | 128 | 129 | `macro: 2dup `( n1 n2 - n1 n2 n1 n2) `\ over `\ over `; 130 | `macro: 2drop `( n1 n2 -) `\ drop `\ drop `; 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | `macro: lit `( n -) `( - n) `$ 07 `c, `, `; 146 | `macro: clit `( cn -) `( - cn) `$ 27 `c, `c, `; 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | `macro: + `( n1 n2 - n3) `$ 18 `c, `; 162 | `macro: - `( n1 n2 - n3) `$ 19 `c, `; 163 | `macro: * `( n1 n2 - n3) `$ 1A `c, `; 164 | `macro: /mod `( n1 n2 - n3 n4) `$ 1B `c, `; 165 | `macro: u* `( u1 u2 - u3) `$ 5A `c, `; 166 | `macro: u/mod `( u1 u2 - u3 u4) `$ 5B `c, `; 167 | `macro: negate `( n1 - n2) `$ 54 `c, `; 168 | `macro: abs `( n1 - n2) `$ 55 `c, `; 169 | `macro: min `( n1 n2 - n3) `$ 56 `c, `; 170 | `macro: max `( n1 n2 - n3) `$ 57 `c, `; 171 | 172 | `macro: / `( n1 n2 - n3) `\ /mod `\ nip `; 173 | `macro: mod `( n1 n2 - n3) `\ /mod `\ drop `; 174 | `macro: u/ `( u1 u2 - u3) `\ u/mod `\ nip `; 175 | `macro: umod `( u1 u2 - u3) `\ u/mod `\ drop `; 176 | 177 | `macro: 1+ `( n1 - n2) `# 1 `\ clit `\ + `; 178 | `macro: 1- `( n1 - n2) `# 1 `\ clit `\ - `; 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | `macro: lshift `( n1 n2 - n3) `$ 12 `c, `; 194 | `macro: rshift `( n1 n2 - n3) `$ 58 `c, `; 195 | `macro: ashift `( n1 n2 - n3) `$ 13 `c, `; 196 | 197 | `macro: 2* `( n1 - n2) `# 1 `\ clit `\ lshift `; 198 | `macro: 2/ `( n1 - n2) `# 1 `\ clit `\ ashift `; 199 | 200 | `macro: not `( n1 - n2) `$ 14 `c, `; 201 | `macro: and `( n1 n2 - n3) `$ 15 `c, `; 202 | `macro: or `( n1 n2 - n3) `$ 16 `c, `; 203 | `macro: xor `( n1 n2 - n3) `$ 17 `c, `; 204 | 205 | 206 | 207 | 208 | 209 | `macro: = `( n1 n2 - ?) `$ 52 `c, `; 210 | `macro: < `( n1 n2 - ?) `$ 53 `c, `; 211 | `macro: u< `( u1 u2 - ?) `$ 59 `c, `; 212 | 213 | `macro: <> `( n1 n2 - ?) `\ = `\ not `; 214 | `macro: > `( n1 n2 - ?) `\ swap `\ < `; 215 | `macro: >= `( n1 n2 - ?) `\ < `\ not `; 216 | `macro: <= `( n1 n2 - ?) `\ > `\ not `; 217 | `macro: u> `( u1 u2 - ?) `\ swap `\ u< `; 218 | `macro: u>= `( u1 u2 - ?) `\ u< `\ not `; 219 | `macro: u<= `( u1 u2 - ?) `\ u> `\ not `; 220 | 221 | 222 | 223 | 224 | 225 | `macro: 0= `( n - ?) `# 0 `\ clit `\ = `; 226 | `macro: 0<> `( n - ?) `# 0 `\ clit `\ <> `; 227 | `macro: 0< `( n - ?) `# 0 `\ clit `\ < `; 228 | `macro: 0> `( n - ?) `# 0 `\ clit `\ > `; 229 | `macro: 0>= `( n - ?) `# 0 `\ clit `\ >= `; 230 | `macro: 0<= `( n - ?) `# 0 `\ clit `\ <= `; 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | `macro: r! `( r -) `( a -) `$ 48 `c, `c, `; 242 | `macro: r@ `( r -) `( - a) `$ 49 `c, `c, `; 243 | 244 | `macro: @r `( r -) `( - n) `$ 0A `c, `c, `; 245 | `macro: !r `( r -) `( n -) `$ 0B `c, `c, `; 246 | `macro: @r+ `( r -) `( - n) `$ 0C `c, `c, `; 247 | `macro: !r+ `( r -) `( n -) `$ 0D `c, `c, `; 248 | `macro: -@r `( r -) `( - n) `$ 0E `c, `c, `; 249 | `macro: -!r `( r -) `( n -) `$ 0F `c, `c, `; 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | `macro: cr! `( r -) `( a -) `$ 28 `c, `c, `; 258 | `macro: cr@ `( r -) `( - a) `$ 29 `c, `c, `; 259 | 260 | `macro: c@r `( r -) `( - cn) `$ 2A `c, `c, `; 261 | `macro: c!r `( r -) `( cn -) `$ 2B `c, `c, `; 262 | `macro: c@r+ `( r -) `( - cn) `$ 2C `c, `c, `; 263 | `macro: c!r+ `( r -) `( cn -) `$ 2D `c, `c, `; 264 | `macro: -c@r `( r -) `( - cn) `$ 2E `c, `c, `; 265 | `macro: -c!r `( r -) `( cn -) `$ 2F `c, `c, `; 266 | 267 | 268 | 269 | 270 | 271 | 272 | 273 | `macro: @ `( a - n) `$ 4 `\ r! `$ 4 `\ @r `; 274 | `macro: ! `( n a -) `$ 4 `\ r! `$ 4 `\ !r `; 275 | `macro: c@ `( a - cn) `$ 4 `\ r! `$ 4 `\ c@r `; 276 | `macro: c! `( cn a -) `$ 4 `\ r! `$ 4 `\ c!r `; 277 | 278 | 279 | 280 | 281 | 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | `macro: wait `( t p - n) `$ 80 `c, `; 290 | `macro: clip `( a # p - n) `$ 81 `c, `; 291 | `macro: recv `( p - a # n) `$ 82 `c, `; 292 | `macro: send `( a # l - n) `$ 83 `c, `; 293 | 294 | `macro: now `( - t) `$ 84 `c, `; 295 | 296 | `macro: reset `( - *) `$ 85 `c, `; 297 | `macro: depth `( - u1 u2) `$ 86 `c, `; 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | `macro: exit `( ; a - ;) `$ 00 `c, `; 306 | `macro: ex `( ; a1 - ; a2) `$ 01 `c, `; 307 | `macro: jump `( a -) `( *) `$ 02 `c, `, `; 308 | `macro: call `( a -) `( *) `$ 03 `c, `, `; 309 | 310 | `: abort `( - *) reset `; 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | `macro: begin `( - a) `( -) `here `; 322 | `macro: again `( a -) `( -) `\ jump `; 323 | 324 | `macro: for `( - a) `( n -) `\ 1- `\ push `\ begin `; 325 | `macro: next `( a -) `( ; n - ; n | ;) `$ 06 `c, `, `; 326 | 327 | `macro: if `( - a) `( ? -) `$ 04 `c, `here `$ 0 `, `; 328 | `macro: -if `( - a) `( ? -) `$ 05 `c, `here `$ 0 `, `; 329 | `macro: then `( a -) `( -) `here swap ! `; 330 | `macro: else `( a1 - a2) `( -) 331 | `$ 02 `c, `here `$ 0 `, swap `\ then `; 332 | 333 | `macro: while `( a1 - a2 a1) `( ? -) `\ if swap `; 334 | `macro: -while `( a1 - a2 a1) `( ? -) `\ -if swap `; 335 | `macro: repeat `( a1 a2 -) `( -) `\ again `\ then `; 336 | 337 | `macro: here! `( a -) `$ 2 `\ r! `; 338 | `macro: here@ `( - a) `$ 2 `\ r@ `; 339 | `macro: here `( - a) `\ here@ `; 340 | 341 | `macro: , `( n -) `$ 2 `\ !r+ `; 342 | `macro: c, `( cn -) `$ 2 `\ c!r+ `; 343 | 344 | `macro: allot `( # -) `$ 2 `\ r@ `\ + `$ 2 `\ r! `; 345 | 346 | `: naligned `( u1 u2 - u3) 1- dup not -rot + and `; 347 | `: aligned `( u1 - u2) `# 4 naligned `; 348 | `: align `( -) here@ aligned here! `; 349 | 350 | 351 | 352 | 353 | `macro: t! `( a -) `$ 1 `\ r! `; 354 | `macro: t@ `( - a) `$ 1 `\ r@ `; 355 | 356 | `macro: @t `( a - n) `$ 0 `\ r! `$ 0 `\ @r `; 357 | `macro: !t `( n a -) `$ 0 `\ r! `$ 0 `\ !r `; 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | `macro: here' `( - a) `# 0 `\ clit `; 370 | `macro: last `( - a) `# 4 `\ clit `; 371 | `macro: text `( - a) `# 8 `\ clit `; 372 | `macro: text# `( - a) `# 12 `\ clit `; 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | `macro: cells `( u1 - u2) `# 2 `\ clit `\ lshift `; 386 | `macro: cells+ `( u1 u2 - u3) `\ cells `\ + `; 387 | `macro: cells- `( u1 u2 - u3) `\ cells `\ - `; 388 | 389 | `macro: block `( u1 - u2) `# 10 `\ clit `\ lshift `; 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | `macro: eval-buff `( - a) `# 129 block `\ lit `; 402 | `macro: send-buff `( - a) `# 131 block `\ lit `; 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | `: `( - a #) send-buff `[ `$ 6 `] r@ over - `; 419 | `: ?c, `( cn -) `[ `$ 6 `] c!r+ `; 420 | 421 | `: emit `( c - ~) 422 | 423 | begin 2dup `# 0 send 0< while repeat 424 | 2drop `; 425 | 426 | `: cr `( - ~) `$ A emit `; 427 | `: space `( - ~) `$ 20 emit `; 428 | 429 | `: type `( a # - ~) 430 | dup 0<= if 2drop exit then 431 | swap `[ `$ 4 `] r! for `[ `$ 4 `] c@r+ emit next `; 432 | 433 | `macro: base! `( u -) `$ 8 `\ r! `; 434 | `macro: base@ `( - u) `$ 8 `\ r@ `; 435 | 436 | 437 | 438 | 439 | 440 | 441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | 449 | `: digit `( u - c) dup `# 9 > `# 7 and + `# 48 + `; 450 | 451 | `: `( - a #) drop `[ `$ 6 `] r@ send-buff over - `; 453 | `: hold `( c -) `[ `$ 6 `] -c!r `; 454 | `: ?# `( u1 - u2) base@ u/mod swap digit hold `; 455 | `: ?#s `( u - 0) begin ?# dup 0= -while repeat `; 456 | `: sign `( n -) 0< if `$ 2D hold then `; 457 | 458 | 459 | 460 | 461 | 462 | 463 | 464 | 465 | `: (.) `( n u - ~) 466 | base! dup abs type `; 467 | `: . `( n - ~) `# 10 (.) `; 468 | `: .x `( n - ~) `# 16 (.) `; 469 | `: .b `( n - ~) `# 2 (.) `; 470 | `: .o `( n - ~) `# 8 (.) `; 471 | 472 | `: (u.) `( u1 u2 - ~) 473 | base! type `; 474 | `: u. `( u - ~) `# 10 (u.) `; 475 | `: u.x `( u - ~) `# 16 (u.) `; 476 | `: u.b `( u - ~) `# 2 (u.) `; 477 | `: u.o `( u - ~) `# 8 (u.) `; 478 | 479 | 480 | 481 | `: trim `( a1 #1 - a2 #2) 482 | dup 0<= if exit then 483 | swap `[ `$ 4 `] r! for 484 | `[ `$ 4 `] c@r+ `# 33 < -if 485 | `[ `$ 4 `] r@ 1- pop 1+ 486 | exit 487 | then 488 | next 489 | `[ `$ 4 `] r@ 1- `# 0 `; 490 | 491 | 492 | 493 | 494 | 495 | 496 | 497 | `: scan `( a1 #1 c - a2 #2) 498 | `[ `$ 6 `] cr! dup 0<= if exit then 499 | over `[ `$ 4 `] r! dup for 500 | `[ `$ 4 `] c@r+ `[ `$ 6 `] cr@ = if 501 | pop 1+ - 502 | exit 503 | then 504 | next `; 505 | 506 | `: parse `( c ~ - a #) 507 | text @t text# @t 508 | rot scan 2dup + 1+ dup text @t - 509 | text# @t swap - 510 | text# !t text !t `; 511 | 512 | 513 | `: s, `( a # -) 514 | dup `c, swap `[ `$ 4 `] r! dup 0<= if drop exit then 515 | for `[ `$ 4 `] c@r+ `c, next `; 516 | `: s@ `( a1 - a2 #) 517 | `[ `$ 4 `] r! `[ `$ 4 `] c@r+ `[ `$ 4 `] r@ swap `; 518 | 519 | 520 | 521 | 522 | 523 | 524 | 525 | 526 | 527 | 528 | 529 | `: slit `( ; a1 - a2 # ; a3) 530 | i@ `[ `$ 4 `] r! 531 | `[ `$ 4 `] c@r+ `[ `$ 4 `] r@ swap 532 | 2dup + i! `; 533 | 534 | `macro: " `( ~ -) `( - a #) 535 | `# 34 parse dup 0< if drop `# 0 then `\ slit s, `; 536 | 537 | `macro: ." `( ~ -) `( - ~) `\ " `\ type `; 538 | 539 | `macro: abort" `( ~ -) `( - ~ *) 540 | `\ ." `\ cr `\ abort `; 541 | 542 | 543 | 544 | 545 | `: (word) `( ~ - a #) 546 | text @t text# @t trim text# !t text !t 547 | `$ 20 parse `; 548 | `: word `( ~ - a # | ~ *) 549 | (word) dup 0<= if 2drop abort" ?" then `; 550 | 551 | 552 | 553 | 554 | 555 | 556 | 557 | 558 | 559 | 560 | 561 | `: -digit `( c - n) 562 | `# 48 - dup `# 9 > if `# 7 - dup `# 10 < or then `; 563 | 564 | `: number `( a # - a # n | ~ *) 565 | dup 0<= if 2drop abort" ?" then 566 | 2dup swap `[ `$ 6 `] r! 567 | `[ `$ 6 `] c@r `# 45 = push 568 | `[ `$ 6 `] r@ i@ - `[ `$ 6 `] r! 569 | i@ + `# 0 swap for 570 | base@ * `[ `$ 6 `] c@r+ -digit 571 | dup base@ u>= if 572 | 2drop pop drop type abort" ?" 573 | then + 574 | next 575 | pop if negate then `; 576 | 577 | `: (#) `( u ~ - | ~ *) `( - n) 578 | base! word number `\ lit 2drop `; 579 | `macro: # `( ~ - | ~ *) `( - n) `# 10 (#) `; 580 | `macro: $ `( ~ - | ~ *) `( - n) `# 16 (#) `; 581 | `macro: % `( ~ - | ~ *) `( - n) `# 2 (#) `; 582 | `macro: & `( ~ - | ~ *) `( - n) `# 8 (#) `; 583 | 584 | `macro: char `( ~ - | ~ *) `( - c) 585 | text# @t 0<= if abort" ?" then 586 | text @t c@ `\ clit 587 | text @t 1+ text !t 588 | text# @t 1- text# !t `; 589 | 590 | `macro: ( `( ~ -) `( -) `# 41 parse 2drop `; 591 | 592 | 593 | `: same `( a1 #1 a2 #2 - ?) 594 | push `[ `$ 4 `] r! swap `[ `$ 6 `] r! 595 | i@ = dup -if pop drop exit then 596 | pop for 597 | `[ `$ 4 `] c@r+ `[ `$ 6 `] c@r+ = and 598 | dup i@ and i! 599 | next `; 600 | 601 | 602 | 603 | 604 | 605 | 606 | 607 | 608 | 609 | `macro: >data `( h - a) `# 2 cells `\ clit `\ - `; 610 | `macro: >code `( h - a) `# 1 cells `\ clit `\ - `; 611 | `macro: >link `( h - a) `; 612 | `macro: >name `( h - a) `# 1 cells `\ clit `\ + `; 613 | 614 | `macro: >body `( h - a) `\ >data `\ @ `; 615 | 616 | 617 | 618 | 619 | 620 | 621 | 622 | 623 | 624 | 625 | `: find `( a # - a # h | a # 0) 626 | last @t push 627 | begin i@ 0= -while 628 | 2dup i@ >name s@ same if pop exit then 629 | i@ >link @ i! 630 | repeat pop `; 631 | 632 | 633 | 634 | 635 | 636 | 637 | 638 | 639 | 640 | 641 | `: compile `( ~ - * | ~ *) 642 | begin (word) dup 0> while 643 | find dup if 644 | nip nip dup >code @ push ex 645 | else 646 | drop type abort" ?" 647 | then 648 | repeat 2drop `; 649 | 650 | 651 | 652 | 653 | 654 | 655 | 656 | 657 | `macro: [ `( -) 658 | here@ here' !t eval-buff here! `; 659 | `macro: ] `( - *) `( *) 660 | `\ exit here' @t here! eval-buff push `; 661 | `macro: | `( - *) `( *) `\ ] `\ [ `; 662 | 663 | `: evaluate `( a # ~ - * | ~ *) 664 | text @t push text# @t push 665 | text# !t text !t `\ [ compile `\ ] 666 | pop text# !t pop text !t `; 667 | 668 | 669 | 670 | 671 | 672 | 673 | `: evaluator `( a # ~ - ~ *) 674 | dup # 1 = if 2drop exit then 675 | `# 128 block t! here' @t here! 676 | text# !t text !t `\ [ compile `\ ] 677 | here@ here' !t 678 | ." ok" cr `; 679 | 680 | 681 | 682 | 683 | 684 | 685 | 686 | 687 | 688 | 689 | `: header `( a # -) 690 | `here last @t `, last !t s, `here here' !t `; 691 | `: define `( h ~ - | ~ *) 692 | `here push `# 0 `, >body `, 693 | word header 694 | `here pop ! `; 695 | 696 | `: [macro] `( h - *) `( *) >body push `; 697 | `macro: macro: `( ~ - | ~ *) `( *) 698 | `\ ] `' [macro] define `; 699 | `: [micro] `( h -) `( *) >body `\ call `; 700 | `macro: : `( ~ - | ~ *) `( *) 701 | `\ ] `' [micro] define `; 702 | `macro: ; `( ; a - ;) `\ exit `\ [ `; 703 | 704 | 705 | `: (') `( ~ - h | ~ *) 706 | word find dup if 707 | nip nip 708 | else 709 | drop type abort" ?" 710 | then `; 711 | 712 | `macro: ' `( ~ - | ~ *) `( - h) (') `\ lit `; 713 | 714 | `macro: \ `( ~ - | ~ *) `( *) 715 | `\ ' `\ dup `\ >code `\ @ `\ push `\ ex `; 716 | 717 | `macro: ~ `( ~ - | ~ *) `( *) (') >body `\ jump `; 718 | 719 | 720 | 721 | `: load `( u - *) 722 | block `# 1024 evaluate `; 723 | `: thru `( u1 u2 - *) 724 | over - 1+ for 725 | dup load 1+ 726 | next drop `; 727 | 728 | 729 | 730 | 731 | 732 | 733 | 734 | 735 | 736 | 737 | `: bye `( -) 738 | 739 | begin 2dup `# 0 send 0< while repeat 740 | 2drop `; 741 | 742 | 743 | 744 | 745 | 746 | 747 | 748 | 749 | 750 | 751 | 752 | 753 | `: words `( - ~) 754 | last @t push 755 | begin i@ 0= -while 756 | i@ >name s@ type space 757 | i@ >link @ i! 758 | repeat cr pop drop `; 759 | 760 | 761 | 762 | 763 | 764 | 765 | 766 | 767 | 768 | 769 | : patch ( h1 h2 -) 770 | last @t push 771 | begin i@ 0= -while 772 | dup >code @ i@ >code @ = if 773 | over >body i@ >code ! 774 | then 775 | i@ >link @ i! 776 | repeat 2drop pop drop ; 777 | 778 | macro: _macro ( -) ( -) ; 779 | : _micro ( -) ; 780 | 781 | 782 | 783 | 784 | 785 | : prune ( h -) 786 | last @t push 787 | begin i@ 0= -while 788 | dup i@ >link @ = if 789 | # 0 i@ >link ! 790 | drop pop drop exit 791 | then 792 | i@ >link @ i! 793 | repeat drop pop drop ; 794 | 795 | 796 | 797 | 798 | 799 | 800 | 801 | macro: `( ( ~ -) ( -) \ ( ; 802 | 803 | macro: `macro: ( ~ - | ~ *) ( *) \ macro: ; 804 | macro: `: ( ~ - | ~ *) ( *) \ : ; 805 | macro: `; ( ; a - ;) \ ; ; 806 | 807 | macro: `[ ( -) \ [ ; 808 | macro: `] ( - *) ( *) \ ] ; 809 | macro: `| ( - *) ( *) \ | ; 810 | macro: `~ ( ~ - | ~ *) ( *) \ ~ ; 811 | 812 | macro: `' ( ~ - | ~ *) ( - h) \ ' ; 813 | macro: `\ ( ~ - | ~ *) ( *) \ \ ; 814 | 815 | 816 | 817 | macro: `# ( ~ - | ~ *) ( - n) \ # ; 818 | macro: `$ ( ~ - | ~ *) ( - n) \ $ ; 819 | 820 | macro: `here ( - a) \ here ; 821 | macro: `, ( n -) \ , ; 822 | macro: `c, ( cn -) \ c, ; 823 | 824 | : `load ( u - *) load ; 825 | : `thru ( u1 u2 - *) thru ; 826 | 827 | : `forth/ ( u1 - u2) forth/ ; 828 | 829 | 830 | 831 | 832 | 833 | macro: tasks ( - a) # 1 block \ lit ; 834 | : task ( n - a) 1+ cells tasks + ; 835 | 836 | 837 | 838 | 839 | 840 | 841 | 842 | 843 | 844 | 845 | 846 | 847 | 848 | 849 | : wait' ( -) # -1 # 0 wait drop ; 850 | : clip' ( a # -) 851 | begin 2dup # 0 clip 0< while repeat 852 | 2drop ; 853 | : recv' ( - a #) 854 | begin # 0 recv 0< while 2drop wait' repeat ; 855 | : mark ( a # - n) 856 | over # 1 cells- @ dup # -1 = if drop over @ then ; 857 | 858 | : ?trap ( a n - | ~ *) 859 | dup # 2 < if 2drop exit then 860 | ." ERROR " . u.x cr 861 | reset ; 862 | 863 | 864 | 865 | : main ( - *) 866 | begin 867 | # 32 block dup clip' recv' 868 | mark task @ dup if 869 | push ex 870 | else 871 | drop 2drop 872 | then 873 | again ; 874 | 875 | 876 | 877 | 878 | 879 | 880 | 881 | last @t here@ 882 | 883 | macro: empty ( -) 884 | lit \ lit \ here! 885 | lit \ lit \ last \ !t ; 886 | 887 | 888 | 889 | 890 | 891 | 892 | 893 | 894 | 895 | 896 | 897 | : cfill ( a # cn -) 898 | -rot swap [ $ 4 ] r! for 899 | dup [ $ 4 ] c!r+ 900 | next drop ; 901 | 902 | : cmove ( a1 # a2 -) 903 | [ $ 6 ] r! swap [ $ 4 ] r! for 904 | [ $ 4 ] c@r+ [ $ 6 ] c!r+ 905 | next ; 906 | 907 | 908 | 909 | 910 | 911 | 912 | 913 | : execute ( h - *) >body push ; 914 | 915 | 916 | 917 | 918 | 919 | 920 | 921 | 922 | 923 | 924 | 925 | 926 | 927 | 928 | 929 | macro: alias ( h ~ - | ~ *) ( *) 930 | \ ] dup >data @ , >code @ , word header \ [ ; 931 | 932 | 933 | 934 | 935 | 936 | 937 | 938 | 939 | 940 | 941 | 942 | 943 | 944 | 945 | : internal ( - h) last @t ; 946 | : external ( - h) here aligned # 2 cells+ ; 947 | : module ( h1 h2 -) >link ! ; 948 | 949 | 950 | 951 | 952 | 953 | 954 | 955 | 956 | 957 | 958 | 959 | 960 | 961 | : rest ( ; a - a ;) pop ; 962 | : create ( ~ - | ~ *) ( - a) ' [micro] define \ rest ; 963 | : use ( a -) last @t >body 1+ ! ; 964 | : does ( ; a - ;) ( ; a - *) pop use ; 965 | 966 | : >rest ( h - a) >body 1+ # 1 cells+ ; 967 | 968 | 969 | 970 | 971 | 972 | 973 | 974 | 975 | 976 | 977 | macro: variable ( ~ - | ~ *) ( - a) 978 | \ ] create # 0 , \ [ ; 979 | 980 | macro: constant ( n ~ - | ~ *) ( - n) 981 | \ ] create , \ [ does pop @ ; 982 | 983 | 984 | 985 | 986 | 987 | 988 | 989 | 990 | 991 | 992 | 993 | macro: defer ( ~ - | ~ *) ( *) 994 | \ ] create ' abort >body , \ [ does pop @ push ; 995 | : defer! ( a h -) >rest ! ; 996 | : defer@ ( h - a) >rest @ ; 997 | macro: is ( ~ - | ~ *) ( h -) \ >body \ ' \ defer! ; 998 | 999 | 1000 | 1001 | 1002 | 1003 | 1004 | 1005 | 1006 | 1007 | 1008 | 1009 | : z.h ( cu - ~) 1010 | # 16 base! type ; 1011 | 1012 | : dump ( a # - ~) 1013 | swap [ $ A ] r! for 1014 | [ $ A ] c@r+ z.h 1015 | next cr ; 1016 | 1017 | : more ( - a) [ $ A ] r@ ; 1018 | 1019 | 1020 | 1021 | 1022 | 1023 | 1024 | 1025 | --------------------------------------------------------------------------------