├── .github └── workflows │ ├── benchmark.yaml │ ├── runtests-c.yaml │ ├── runtests-i386-linux-handwritten.yaml │ └── runtests-python.yaml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── benchmark ├── fib.fs ├── gendoc.sh ├── matmul.fs └── nop.fs ├── bootstrap.fs ├── example ├── fib.fs └── helloworld.fs ├── lib ├── array.fs ├── bitscan.fs ├── core.fs ├── string.fs ├── table.fs └── tester.fs ├── others ├── planck.c └── planck.py ├── planck.xxd ├── runtests.fs └── test ├── core.fs ├── coreexttest.fs ├── coreplustest.fs ├── export.fs ├── fileio-test0.txt ├── fileio.fs └── utilities.fs /.github/workflows/benchmark.yaml: -------------------------------------------------------------------------------- 1 | name: benchmark 2 | 3 | on: 4 | push: 5 | branches: "main" 6 | paths-ignore: ['README.md', 'LICENSE', '.gitignore'] 7 | jobs: 8 | runbenchmarks: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v1 12 | - name: take benchmarks 13 | run: | 14 | mkdir -p document 15 | ./benchmark/gendoc.sh ${{ github.sha }} | tee document/Benchmarks.md 16 | - name: upload to wiki 17 | uses: SwiftDocOrg/github-wiki-publish-action@v1 18 | with: 19 | path: "document" 20 | env: 21 | GH_PERSONAL_ACCESS_TOKEN: ${{ secrets.GH_PERSONAL_ACCESS_TOKEN }} 22 | -------------------------------------------------------------------------------- /.github/workflows/runtests-c.yaml: -------------------------------------------------------------------------------- 1 | name: testing c 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - main 7 | paths-ignore: ['README.md', 'LICENSE', '.gitignore'] 8 | jobs: 9 | runtests-c: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v1 13 | - name: run tests 14 | run: | 15 | make c 16 | ./planck < bootstrap.fs runtests.fs 17 | -------------------------------------------------------------------------------- /.github/workflows/runtests-i386-linux-handwritten.yaml: -------------------------------------------------------------------------------- 1 | name: testing i386-linux-handwritten 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - main 7 | jobs: 8 | runtests-i386-linux-handwritten: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v1 12 | - name: run tests 13 | run: | 14 | make i386-linux-handwritten 15 | ./planck < bootstrap.fs runtests.fs 16 | -------------------------------------------------------------------------------- /.github/workflows/runtests-python.yaml: -------------------------------------------------------------------------------- 1 | name: testing python 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - main 7 | paths-ignore: ['README.md', 'LICENSE', '.gitignore'] 8 | jobs: 9 | runtests-python: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v1 13 | - name: run tests 14 | run: | 15 | make python 16 | ./planck < bootstrap.fs runtests.fs 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | planck 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021 nineties 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included 11 | in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # planckforth - 2 | # Copyright (C) 2021 nineties 3 | 4 | default: i386-linux-handwritten 5 | 6 | i386-linux-handwritten: planck.xxd 7 | xxd -r -c 8 $< > planck 8 | chmod +x planck 9 | 10 | c: others/planck.c 11 | gcc -Wall -O2 $< -o planck -DCOMPILER="$(shell gcc --version | head -n1)" 12 | 13 | python: others/planck.py 14 | cp others/planck.py planck 15 | chmod +x planck 16 | 17 | .PHONY: clean test 18 | clean: 19 | rm -f planck 20 | 21 | test: planck bootstrap.fs runtests.fs 22 | ./planck < bootstrap.fs runtests.fs 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PlanckForth: Bootstrapping an Interpreter from Handwritten 1KB Binary 2 | 3 | This project aims to bootstrap a Forth interpreter from hand-written tiny (1KB) ELF binary. 4 | This is just for fun. No practical use. 5 | 6 | ## How to build 7 | 8 | Only `xxd` is needed to build PlanckForth. 9 | 10 | ``` 11 | $ git clone https://github.com/nineties/planckforth.git 12 | $ cd planckforth 13 | $ make 14 | xxd -r -c 8 planck.xxd > planck 15 | chmod +x planck 16 | ``` 17 | 18 | Implementations in other languages are in `others`. 19 | 20 | ## Hello World 21 | 22 | The hello world program at the beginning looks like this. 23 | 24 | ``` 25 | $ ./planck 26 | kHtketkltkltkotk tkWtkotkrtkltkdtk!tk:k0-tk0k0-Q 27 | ``` 28 | After bootstrapping by `bootstrap.fs`, it looks like this. 29 | 30 | ``` 31 | $ ./planck < bootstrap.fs 32 | ." Hello World!" cr 33 | ``` 34 | 35 | `bootstrap.fs` can also take a file as an input program like this. 36 | 37 | ``` 38 | $ cat example/fib.fs 39 | : fib dup 2 < unless 1- dup recurse swap 1- recurse + then ; 40 | 20 fib . cr 41 | $ ./planck < bootstrap.fs example/fib.fs 42 | 6765 43 | ``` 44 | 45 | # Running Tests 46 | 47 | ``` 48 | $ make test 49 | ``` 50 | 51 | # Builtin Words 52 | 53 | | code | name | stack effect | semantics | 54 | |:----:|:----------|:----------------|:----------------------------------------| 55 | | Q | quit | ( n -- ) | Exit the process | 56 | | C | cell | ( -- n ) | The size of Cells | 57 | | h | &here | ( -- a-addr ) | The address of 'here' cell | 58 | | l | &latest | ( -- a-addr ) | The address of 'latest' cell | 59 | | k | key | ( -- c ) | Read character | 60 | | t | type | ( c -- ) | Print character | 61 | | j | jump | ( -- ) | Unconditional branch | 62 | | J | 0jump | ( n -- ) | Jump if a == 0 | 63 | | f | find | ( c -- xt ) | Get execution token of c | 64 | | x | execute | ( xt -- ... ) | Run the execution token | 65 | | @ | fetch | ( a-addr -- w ) | Load value from addr | 66 | | ! | store | ( w a-addr -- ) | Store value to addr | 67 | | ? | cfetch | ( c-addr -- c ) | Load byte from addr with sign extension | 68 | | $ | cstore | ( c c-addr -- ) | Store byte to addr | 69 | | d | dfetch | ( -- a-addr ) | Get data stack pointer | 70 | | D | dstore | ( a-addr -- ) | Set data stack pointer | 71 | | r | rfetch | ( -- a-addr ) | Get return stack pointer | 72 | | R | rstore | ( a-addr -- ) | Set return stack pointer | 73 | | i | docol | ( -- a-addr ) | Get the code pointer of interpreter | 74 | | e | exit | ( -- ) | Exit current function | 75 | | L | lit | ( -- n ) | Load immediate | 76 | | S | litstring | ( -- c-addr ) | Load string literal | 77 | | + | add | ( a b -- c ) | c = (a + b) | 78 | | - | sub | ( a b -- c ) | c = (a - b) | 79 | | * | mul | ( a b -- c ) | c = (a * b) | 80 | | / | divmod | ( a b -- c d ) | c = (a mod b), d = (a / b) | 81 | | & | and | ( a b -- c ) | c = (a & b) | 82 | | \| | or | ( a b -- c ) | c = (a \| b) | 83 | | ^ | xor | ( a b -- c ) | c = (a ^ b) | 84 | | < | less | ( a b -- c ) | c = (a < b) | 85 | | u | uless | ( a b -- c ) | c = (a unsigned< b) | 86 | | = | equal | ( a b -- c ) | c = (a == b) | 87 | | ( | shl | ( a b -- c ) | c = a << b (logical) | 88 | | ) | shr | ( a b -- c ) | c = a >> b (logical) | 89 | | % | sar | ( a b -- c ) | c = a >> b (arithmetic) | 90 | | v | argv | ( -- a-addr u ) | argv and argc | 91 | | V | version | ( -- c-addr ) | Runtime infomation string | 92 | 93 | # Binary Layout 94 | 95 | ![binary layout](https://user-images.githubusercontent.com/172570/104666244-c0c58800-5716-11eb-9798-847ea2fe76b8.jpeg) 96 | 97 | # Implementations 98 | 99 | | Implementation of runtime | build | test status | 100 | |:----------------------------------|:------------------|:------------| 101 | | Handwritten ELF binary for i386-linux | `make` | [![testing i386-linux-handwritten](https://github.com/nineties/planckforth/actions/workflows/runtests-i386-linux-handwritten.yaml/badge.svg)](https://github.com/nineties/planckforth/actions/workflows/runtests-i386-linux-handwritten.yaml) | 102 | | C | `make c` | [![testing c](https://github.com/nineties/planckforth/actions/workflows/runtests-c.yaml/badge.svg)](https://github.com/nineties/planckforth/actions/workflows/runtests-c.yaml) | 103 | | Python 3.x | `make python` | [![testing python](https://github.com/nineties/planckforth/actions/workflows/runtests-python.yaml/badge.svg)](https://github.com/nineties/planckforth/actions/workflows/runtests-python.yaml) | 104 | 105 | # Benchmarks 106 | 107 | See [Wiki/Benchmarks](https://github.com/nineties/planckforth/wiki/Benchmarks) 108 | -------------------------------------------------------------------------------- /benchmark/fib.fs: -------------------------------------------------------------------------------- 1 | : fib dup 2 < unless 1- dup recurse swap 1- recurse + then ; 2 | 30 fib . cr 3 | -------------------------------------------------------------------------------- /benchmark/gendoc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | COMMIT="$1" 4 | TARGETS="i386-linux-handwritten c python" 5 | TIMEFORMAT='%U' 6 | CPU_MODEL=`cat /proc/cpuinfo | grep -m1 'model name' | cut -d: -f2 | sed "s/^ *//g"` 7 | MEM_SIZE="`cat /proc/meminfo | grep 'MemTotal' | awk '{ print $2/1024/1024 }'` GB" 8 | UNAME=`uname -a` 9 | 10 | function benchmark () { 11 | sum=0 12 | for i in `seq $2`; do 13 | t=`{ eval $1; } 2>&1` 14 | sum=`echo $t + $sum | bc` 15 | done 16 | average=`echo "scale=3; $sum / $2" | bc | xargs printf "%.3f"` 17 | echo $average 18 | } 19 | 20 | function generate-table { 21 | echo "## $1" 22 | echo "\`$2\`" 23 | echo 24 | #echo "Average of $3 execution times." 25 | #echo 26 | echo "| runtime implementation | execution time (sec) |" 27 | echo "|:-----------------------|---------------------:|" 28 | for impl in $TARGETS; do 29 | make $impl 2>&1 > /dev/null 30 | runtime=`./planck < bootstrap.fs --runtime` 31 | t=`benchmark "time $2 2>&1 > /dev/null" $3` 32 | echo "| $runtime | $t |" 33 | done 34 | echo 35 | } 36 | 37 | echo "# Environment" 38 | echo 39 | echo "- Commit: [[$COMMIT|https://github.com/nineties/planckforth/commit/$COMMIT]]" 40 | echo "- $CPU_MODEL" 41 | echo "- $MEM_SIZE" 42 | echo "- $UNAME" 43 | echo 44 | 45 | echo "# Benchmarks" 46 | 47 | generate-table "Bootstrap Time" "./planck < bootstrap.fs benchmark/nop.fs" 1 48 | generate-table "Fib(30)" "./planck < bootstrap.fs benchmark/fib.fs" 1 49 | generate-table "Matmul" "./planck < bootstrap.fs benchmark/matmul.fs" 1 50 | -------------------------------------------------------------------------------- /benchmark/matmul.fs: -------------------------------------------------------------------------------- 1 | 60 constant M 2 | 90 constant K 3 | 60 constant N 4 | 5 | M K * cells allocate throw constant mat1 6 | K N * cells allocate throw constant mat2 7 | M N * cells allocate throw constant mat3 8 | 9 | :noname 10 | M 0 do 11 | K 0 do 12 | i j + 1+ mat1 K j * i + cells + ! 13 | loop 14 | loop 15 | 16 | K 0 do 17 | N 0 do 18 | i j + 1+ mat2 N j * i + cells + ! 19 | loop 20 | loop 21 | 22 | M 0 do 23 | N 0 do 24 | 0 25 | K 0 do 26 | mat1 K k * i + cells + @ 27 | mat2 N i * j + cells + @ 28 | * + 29 | loop 30 | mat3 N i * j + cells + ! 31 | loop 32 | loop 33 | ; execute 34 | -------------------------------------------------------------------------------- /benchmark/nop.fs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nineties/planckforth/f7356eb63bfa15c173bc6a69db8a8d81a69fbd54/benchmark/nop.fs -------------------------------------------------------------------------------- /bootstrap.fs: -------------------------------------------------------------------------------- 1 | h@l@h@!h@C+h!k1k0-h@$k:k0-h@k1k0-+$h@C+h!ih@!h@C+h!kefh@!h@C+h!l! 2 | h@l@h@!h@C+h!k1k0-h@$k h@k1k0-+$h@C+h!ih@!h@C+h!kefh@!h@C+h!l! 3 | 4 | h@l@ h@!h@C+h! k1k0-h@$ k\h@k1k0-+$ h@C+h! 5 | i h@!h@C+h! 6 | kkf h@!h@C+h! 7 | kLf h@!h@C+h! 8 | k:k0- h@!h@C+h! 9 | k=f h@!h@C+h! 10 | kJf h@!h@C+h! 11 | k0k5-C* h@!h@C+h! 12 | kef h@!h@C+h! 13 | l! 14 | 15 | \ **Now we can use single-line comments!** 16 | 17 | \ planckforth - 18 | \ Copyright (C) 2021 nineties 19 | 20 | \ This project aims to bootstrap a Forth interpreter 21 | \ from hand-written tiny ELF binary. 22 | 23 | \ In the 1st stage, only single character words are registered 24 | \ in the dictionary. 25 | \ List of builtin words: 26 | \ 'Q' ( n -- ) Exit the process 27 | \ 'C' ( -- n ) The size of Cells 28 | \ 'h' ( -- a-addr ) The address of 'here' cell 29 | \ 'l' ( -- a-addr ) The address of 'latest' cell 30 | \ 'k' ( -- c ) Read character 31 | \ 't' ( c -- ) Print character 32 | \ 'j' ( -- ) Unconditional branch 33 | \ 'J' ( n -- ) Jump if a == 0 34 | \ 'f' ( c -- xt ) Get execution token of c 35 | \ 'x' ( xt -- ... ) Run the execution token 36 | \ '@' ( a-addr -- w ) Load value from addr 37 | \ '!' ( w a-addr -- ) Store value to addr 38 | \ '?' ( c-addr -- c ) Load byte from addr 39 | \ '$' ( c c-addr -- ) Store byte to addr 40 | \ 'd' ( -- a-addr ) Get data stack pointer 41 | \ 'D' ( a-addr -- ) Set data stack pointer 42 | \ 'r' ( -- a-addr ) Get return stack pointer 43 | \ 'R' ( a-addr -- ) Set return stack pointer 44 | \ 'i' ( -- a-addr ) Get the interpreter function 45 | \ 'e' ( -- ) Exit current function 46 | \ 'L' ( -- u ) Load immediate 47 | \ 'S' ( -- c-addr ) Load string literal 48 | \ '+' ( a b -- c ) c = (a + b) 49 | \ '-' ( a b -- c ) c = (a - b) 50 | \ '*' ( a b -- c ) c = (a * b) 51 | \ '/' ( a b -- c ) c = (a / b) 52 | \ '%' ( a b -- c ) c = (a % b) 53 | \ '&' ( a b -- c ) c = (a & b) 54 | \ '|' ( a b -- c ) c = (a | b) 55 | \ '^' ( a b -- c ) c = (a ^ b) 56 | \ '<' ( a b -- c ) c = (a < b) 57 | \ 'u' ( a b -- c ) c = (a unsigned< b) 58 | \ '=' ( a b -- c ) c = (a == b) 59 | \ '(' ( a b -- c ) c = a << b (logical) 60 | \ ')' ( a b -- c ) c = a >> b (logical) 61 | \ '%' ( a b -- c ) c = a >> b (arithmetic) 62 | \ 'v' ( -- a-addr u ) argv and argc 63 | \ 'V' ( -- c-addr ) Runtime information string 64 | 65 | \ The 1st stage interpreter repeats execution of k, f and x. 66 | \ The following line is an example program of planckforth 67 | \ which prints "Hello World!\n" 68 | \ -- 69 | \ kHtketkltkltkotk tkWtkotkrtkltkdtk!tk:k0-tk0k0-Q 70 | \ -- 71 | \ This code repeats that 'k' reads a character and 't' prints it. 72 | \ Note that ':' (58) minus '0' (48) is '\n' (10). 73 | 74 | \ The structure of the dictionary. 75 | \ +------+----------+---------+------------+---------------+ 76 | \ | link | len+flag | name... | padding... | code field ...| 77 | \ +------+----------+---------+------------+---------------+ 78 | \ - link pointer to the previous entry (CELL byte) 79 | \ - length of the name (6 bits) 80 | \ - smudge bit (1 bit) 81 | \ - immediate bit (1 bit) 82 | \ - characters of the name (N bytes) 83 | \ - padding to align CELL boundary if necessary. 84 | \ - codewords and datawords (CELL-bye aligned) 85 | 86 | \ The code group at the beginning of this file 87 | \ defines ' ' and '\n' as no-op operation and 88 | \ '\' to read following characters until '\n'. 89 | \ Since I couldn't write a comment at the beginning, 90 | \ I repost the definition of '\' for explanation. 91 | \ -- 92 | \ h@ ( save addr of new entry ) 93 | \ l@ h@!h@C+h! ( set link pointer. *here++ = latest ) 94 | \ k1k0-h@$ k\h@k1k0-+$ h@C+h! ( write the name '\' and its length ) 95 | \ i h@!h@C+h! ( docol ) 96 | \ kkf h@!h@C+h! ( key ) 97 | \ kLf h@!h@C+h! ( lit ) 98 | \ k:k0- h@!h@C+h! ( '\n' ) 99 | \ k=f h@!h@C+h! ( = ) 100 | \ kJf h@!h@C+h! ( branch ) 101 | \ k0k5-C* h@!h@C+h! ( -5*CELL ) 102 | \ kef h@!h@C+h! ( exit ) 103 | \ l! ( set latest to this new entry. ) 104 | \ -- 105 | 106 | \ That's all for the brief explanation. Let's restart bootstrap! 107 | 108 | \ The COMMA operator 109 | \ ',' ( a -- ) Store a to 'here' and increment 'here' CELL bytes. 110 | h@l@ h@!h@C+h! k1k0-h@$ k,h@k1k0-+$ h@C+h! 111 | i h@!h@C+h! \ docol 112 | \ store 'a' to here 113 | khf h@!h@C+h! 114 | k@f h@!h@C+h! 115 | k!f h@!h@C+h! 116 | \ here <- here + CELL 117 | khf h@!h@C+h! 118 | k@f h@!h@C+h! 119 | kCf h@!h@C+h! 120 | k+f h@!h@C+h! 121 | khf h@!h@C+h! 122 | k!f h@!h@C+h! 123 | \ exit 124 | kef h@!h@C+h! 125 | l! 126 | 127 | \ TICK-like operator 128 | \ '\'' ( "c" -- xt ) Get execution token of following character 129 | \ NB: This definition is different from the usual definition of tick 130 | \ because it does not skip leading spaces and can read only a single 131 | \ character. It will be redefined in later stage. 132 | h@l@, k1k0-h@$ k'h@k1k0-+$ h@C+h! 133 | i, kkf, kff, kef, 134 | l! 135 | 136 | \ Utility for defining a word 137 | \ 'c' ( "c" -- w ) 138 | \ Read character, create new word then push its address. 139 | \ 'latest' will not be updated. 140 | h@l@, k1k0-h@$ kch@k1k0-+$ h@C+h! 141 | i, 'h, '@, 'l, '@, ',, 142 | 'L, k1k0-, 'h, '@, '$, \ fill 1 143 | 'k, 'h, '@, 'L, k1k0-, '+, '$, \ fill "c" 144 | 'L, k0k0-, 'h, '@, 'L, k2k0-, '+, '$, \ fill "\0" 145 | 'h, '@, 'C, '+, 'h, '!, 146 | 'e, l! 147 | 148 | \ '_' ( a -- ) DROP 149 | c_ i, 'd, 'C, '+, 'D, 'e, l! 150 | 151 | \ '#' ( a -- a a ) DUP 152 | c# i, 'd, '@, 'e, l! 153 | 154 | 155 | 156 | \ Implementations of TOR and FROMR are a bit tricky. 157 | \ Since return-address will be placed at the top of return stack, 158 | \ the code in the body of these function have to manipulate 159 | \ 2nd element of the stack. 160 | 161 | \ '{' ( a -- R:a ) TOR 162 | \ Move value from data stack to return stack. 163 | c{ i, 164 | 'r, 'r, '@, \ ( a rsp ret ) 165 | 'r, 'C, '-, '#, \ ( a rsp ret rsp-1 rsp-1 ) 166 | 'R, \ ( a rsp+1 ret rsp ) extend return stack 167 | '!, \ ( a rsp+1 ) store return address to the top 168 | '!, \ store a to the 2nd 169 | 'e, l! 170 | 171 | \ '}' ( R:a -- a ) FROMR 172 | \ Move value from return stack to data stack. 173 | c} i, 174 | 'r, 'C, '+, '@, \ ( a ) load 2nd value 175 | 'r, '@, \ ( a ret ) load return addr 176 | 'r, 'C, '+, '#, \ ( a ret rsp+1 rsp+1 ) 177 | 'R, \ ( a ret rsp ) reduce return stack 178 | '!, \ ( a , R:ret ) store return addr to top of return stack 179 | 'e, l! 180 | 181 | \ 'o' ( a b -- a b a ) OVER 182 | co i, 'd, 'C, '+, '@, 'e, l! 183 | 184 | \ '~' ( a b -- b a ) SWAP 185 | c~ i, 186 | 'o, \ ( a b a ) 187 | '{, \ ( a b , R:a ) 188 | 'd, 'C, '+, \ ( a b sp+1 , R:a ) 189 | '!, \ ( b , R:a ) 190 | '}, \ ( b a ) 191 | 'e, l! 192 | 193 | \ 'B' ( c -- ) C-COMMA 194 | \ Store byte 'c' to here and increment it 195 | cB i, 'h, '@, '$, 'h, '@, 'L, k1k0-, '+, 'h, '!, 'e, l! 196 | 197 | \ 'm' ( c-addr u -- ) CMOVE, 198 | \ Copy u bytes from c-addr to here, 199 | \ increment here u bytes. 200 | cm i, 201 | \ 202 | '#, 'J, k>k0-C*, \ goto if u=0 203 | '{, \ preserve u 204 | '#, '?, 'B, \ copy byte 205 | 'L, k1k0-, '+, \ increment c-addr 206 | '}, 'L, k1k0-, '-, \ decrement u 207 | 'j, k0k?-C*, \ goto 208 | \ 209 | '_, '_, 210 | 'e, l! 211 | 212 | \ 'a' ( c-addr -- a-addr ) ALIGNED 213 | \ Round up to a nearest multiple of CELL 214 | ca i, 215 | 'L, Ck1k0--, '+, \ ( a+CELL-1 ) 216 | 'L, k0k0-C-, \ ( a+CELL-1 ~(CELL-1) ) 217 | '&, 218 | 'e, l! 219 | 220 | \ 'A' ( -- ) ALIGN 221 | \ Round up 'here' to a nearest multiple of CELL 222 | cA i, 'h, '@, 'a, 'h, '!, 'e, l! 223 | 224 | \ 'E' ( c-addr1 c-addr2 -- flag ) STR= 225 | \ Compare null-terminated strings. 226 | \ Return 1 if they are same 0 otherwise. 227 | cE i, 228 | \ 229 | 'o, '?, 'o, '?, \ ( c-addr1 c-addr2 c1 c2 ) 230 | 'o, '=, 'J, k=k0-C*, \ goto if c1<>c2 231 | 'J, kAk0-C*, \ goto if c1==0 232 | 'L, k1k0-, '+, '~, \ increment c-addr2 233 | 'L, k1k0-, '+, '~, \ increment c-addr1 234 | 'j, k0kC-C*, \ goto 235 | \ 236 | '_, '_, '_, 'L, k0k0-, 'e, 237 | \ 238 | '_, '_, 'L, k1k0-, 'e, 239 | l! 240 | 241 | \ 'z' ( c-addr -- u ) STRLEN 242 | \ Calculate length of string 243 | cz i, 244 | 'L, k0k0-, \ 0 245 | \ 246 | 'o, '?, 'J, k;k0-C*, \ goto if '\0' 247 | 'L, k1k0-, '+, '~, \ increment u 248 | 'L, k1k0-, '+, '~, \ increment c-addr 249 | 'j, k0k=-C*, \ goto 250 | \ 251 | '~, '_, 'e, 252 | l! 253 | 254 | \ 's' ( c -- n) 255 | \ Return 1 if c==' ' or c=='\n', 0 otherwise. 256 | cs i, '#, 'L, k , '=, '~, 'L, k:k0-, '=, '|, 'e, l! 257 | 258 | \ 'W' ( "name" -- c-addr ) 259 | \ Skip leading spaces (' ' and '\n'), 260 | \ Read name, then return its address. 261 | \ The maximum length of the name is 63. The behavior is undefined 262 | \ when the name exceeds 63 characters. 263 | \ The buffer will be terminated with '\0'. 264 | \ Note that it returns the address of statically allocated buffer, 265 | \ so the content will be overwritten each time 'W' executed. 266 | 267 | \ Allocate buffer of 63+1 bytes or more, 268 | \ push the address for compilation of 'W' 269 | h@ # kpk0-+ h! A 270 | cW~ 271 | i, 272 | \ skip leading spaces 273 | 'k, '#, 's, 'J, k4k0-C*, '_, 'j, k0k7-C*, 274 | \ p=address of buffer 275 | 'L, #, '~, 276 | \ 277 | \ ( p c ) 278 | 'o, '$, \ store c to p 279 | 'L, k1k0-, '+, \ increment p 280 | 'k, '#, 's, 'J, k0k9-C*, \ goto if c is not space 281 | '_, 282 | 'L, k0k0-, 'o, '$, \ fill \0 283 | '_, 'L, , \ return buf 284 | 'e, l! 285 | 286 | \ 'F' ( c-addr -- w ) 287 | \ Lookup multi-character word from dictionary. 288 | \ Return 0 if the word is not found. 289 | \ Entries with smudge-bit=1 are ignored. 290 | cF i, 291 | 'l, '@, 292 | \ ( addr it ) 293 | '#, 'J, kEk0-C*, \ goto if it=NULL 294 | '#, 'C, '+, '?, \ ( addr it len+flag ) 295 | 'L, k@, '&, \ test smudge-bit of it 296 | 'J, k4k0-C*, 297 | \ <1> 298 | \ smudge-bit=1 299 | '@, \ load link 300 | 'j, k0k>-C*, \ goto 301 | \ <2> 302 | \ smudge-bit=0 303 | 'o, 'o, \ ( addr it addr it ) 304 | 'L, Ck1k0-+, '+, \ address of name 305 | \ ( addr1 it addr1 addr2 ) 306 | 'E, 'J, k0k:-C*, \ goto <1> if different name 307 | \ 308 | '{, '_, '}, \ Drop addr, return it 309 | 'e, l! 310 | 311 | \ 'G' ( w -- xt ) 312 | \ Get CFA of the word 313 | cG i, 314 | 'C, '+, '#, '?, \ ( addr len+flag ) 315 | 'L, kok0-, '&, \ take length 316 | '+, \ add length to the addr 317 | 'L, k2k0-, '+, \ add 2 to the addr (len+field and \0) 318 | 'a, \ align 319 | 'e, l! 320 | 321 | \ 'M' ( -- a-addr) 322 | \ The state variable 323 | \ 0: immediate mode 324 | \ 1: compile mode 325 | h@ k0k0-, \ allocate 1 cell and fill 0 326 | cM~ i, 'L, , 'e, l! 327 | 328 | \ 'I' 329 | \ The 2nd Stage Interpreter 330 | cI i, 331 | \ 332 | 'W, \ read name from input 333 | 'F, \ find word 334 | 'M, '@, \ read state 335 | 'J, kAk0-C*, \ goto if state=0 336 | \ 337 | '#, 'C, '+, '?, \ ( w len+flag ) 338 | 'L, k@k@+, '&, \ test immediate bit 339 | 'L, k0k0-, '=, 340 | 'J, k5k0-C*, \ goto if immediate-bit=1 341 | 'G, ',, \ compile 342 | 'j, k0kE-C*, \ goto 343 | \ 344 | 'G, 'x, \ execute 345 | 'j, k0kI-C*, \ goto 346 | l! 347 | 348 | I \ Enter 2nd Stage 349 | 350 | \ === 2nd Stage Interpreter === 351 | 352 | } _ \ Drop 1st stage interpreter from call stack 353 | 354 | \ '\'' ( "name" -- xt ) 355 | \ Redefine existing '\'' which uses 'k' and 'f' 356 | \ to use 'W' and 'F'. 357 | c ' i , ' W , ' F , ' G , ' e , l ! 358 | 359 | \ [ immediate ( -- ) 360 | \ Switch to immediate mode 361 | c [ i , ' L , k 0 k 0 - , ' M , ' ! , ' e , l ! 362 | \ Set immediate-bit of [ 363 | l @ C + # { ? k @ k @ + | } $ 364 | 365 | \ ] ( -- ) 366 | \ Switch to compile mode 367 | c ] i , ' L , k 1 k 0 - , ' M , ' ! , ' e , l ! 368 | 369 | \ : ( "name" -- ) COLON 370 | \ Read name, create word with smudge=1, 371 | \ compile 'docol' and enter compile mode. 372 | c : i , 373 | ' A , \ align here 374 | ' h , ' @ , 375 | ' l , ' @ , ' , , \ fill link 376 | ' l , ' ! , \ update latest 377 | ' W , \ read name ( addr ) 378 | ' # , ' z , ' # , \ ( addr len len ) 379 | ' L , k @ , ' | , \ set smudge-bit 380 | ' B , \ fill length + smudge-bit 381 | ' m , \ fill name 382 | ' L , k 0 k 0 - , ' B , \ fill \0 383 | ' A , \ align here 384 | ' i , ' , , \ compile docol 385 | ' ] , \ enter compile mode 386 | ' e , l ! 387 | 388 | \ ; ( -- ) SEMICOLON 389 | \ Compile 'exit', unsmudge latest, and enter immediate mode. 390 | c ; i , 391 | ' A , \ align here 392 | ' L , ' e , ' , , \ compile exit 393 | ' l , ' @ , 394 | ' C , ' + , ' # , ' ? , 395 | ' L , k [ k d + , \ 0xbf 396 | ' & , ' ~ , ' $ , \ unsmudge 397 | ' [ , \ enter immediate mode 398 | ' e , l ! 399 | \ Set immediate-bit of ';' 400 | l @ C + # { ? k @ k @ + | } $ 401 | 402 | : immediate-bit [ ' L , k @ k @ + , ] ; \ 0x80 403 | : smudge-bit [ ' L , k @ , ] ; \ 0x40 404 | : length-mask [ ' L , k o k 0 - , ] ; \ 0x3f 405 | 406 | \ ( "name" -- ) 407 | : set-immediate 408 | W F C + # { ? immediate-bit | } $ 409 | ; 410 | 411 | \ Set immediate-bit of single-line comment word \ 412 | \ so that we can write comments in compile-mode. 413 | set-immediate \ 414 | 415 | \ Set immediate-bit of 'latest' 416 | : immediate 417 | l @ C + # { ? immediate-bit | } $ 418 | ; 419 | 420 | : alias-builtin \ ( "name-new" "name-old" -- ) 421 | \ Create new word "name-new". 422 | \ Copy code pointer of builtin word "name-old" to 423 | \ the new word "name-new". 424 | \ "name-old" must not be a FORTH word. 425 | A h @ l @ , l ! \ fill link, update latest 426 | W # z # B m \ fill length and chars of "name-new" 427 | [ ' L , k 0 k 0 - , ] B \ fill \0 428 | A 429 | W F G @ , \ fill code-pointer of "name-old" 430 | ; 431 | 432 | \ Add new names to builtin primities. 433 | \ Instead of defining as a new FORTH word like shown below, 434 | \ the aliases are created by copying their code-pointer. 435 | \ : new-name old-name ; 436 | \ Primitive operators which manipulate program counter and return stack 437 | \ can not be defined as a FORTH word. 438 | 439 | alias-builtin quit Q 440 | alias-builtin cell C 441 | alias-builtin &here h 442 | alias-builtin &latest l 443 | alias-builtin emit t 444 | alias-builtin branch j 445 | alias-builtin 0branch J 446 | alias-builtin execute x 447 | alias-builtin c@ ? 448 | alias-builtin c! $ 449 | alias-builtin sp@ d 450 | alias-builtin sp! D 451 | alias-builtin rp@ r 452 | alias-builtin rp! R 453 | alias-builtin docol i 454 | alias-builtin exit e 455 | alias-builtin lit L 456 | alias-builtin litstring S 457 | alias-builtin /mod / 458 | alias-builtin and & 459 | alias-builtin or | 460 | alias-builtin xor ^ 461 | alias-builtin u< u 462 | alias-builtin lshift ( 463 | alias-builtin rshift ) 464 | alias-builtin arshift % 465 | alias-builtin runtime-info_ V 466 | 467 | : bye [ ' L , k 0 k 0 - , ] quit ; 468 | 469 | \ Rename existing FORTH words 470 | : >cfa G ; 471 | : c, B ; 472 | : memcpy, m ; 473 | : strlen z ; 474 | : streq E ; 475 | : state M ; 476 | : aligned a ; 477 | : align A ; 478 | 479 | : here &here @ ; 480 | : latest &latest @ ; 481 | : >dfa >cfa cell + ; 482 | 483 | \ === Stub Functions === 484 | \ Use 1-step indirect reference so that we can replace 485 | \ the runtime later. 486 | 487 | : allot-cell &here @ # cell + &here ! ; 488 | 489 | alias-builtin key-old k 490 | 491 | allot-cell : &key [ ' L , , ] ; 492 | allot-cell : &key! [ ' L , , ] ; 493 | 494 | : key &key @ execute ; \ ( -- c ) Push -1 at EOF 495 | ' key-old &key ! 496 | 497 | : key! &key! @ execute ; \ ( -- c ) Throw exception at EOF 498 | ' key-old &key! ! 499 | 500 | allot-cell : &word [ ' L , , ] ; 501 | : word &word @ execute ; \ ( "name" -- c-addr e ) 502 | : stub-word W [ ' L , k 0 k 0 - , ] ; 503 | ' stub-word &word ! 504 | 505 | allot-cell : &word! [ ' L , , ] ; 506 | : word! &word! @ execute ; \ ( "name" -- c-addr ) Throw exception at error 507 | ' W &word! ! 508 | 509 | allot-cell : &find [ ' L , , ] ; \ ( c-addr -- nt|0 ) 510 | allot-cell : &find! [ ' L , , ] ; \ ( c-addr -- nt ) Throw exception at error 511 | 512 | : find &find @ execute ; 513 | : find! &find! @ execute ; 514 | ' F &find ! 515 | ' F &find! ! 516 | 517 | : ' word! find! >cfa ; 518 | 519 | \ === Compilers === 520 | 521 | \ compile: ( n -- ) 522 | \ runtime: ( -- n ) 523 | : literal 524 | lit lit , \ compile lit 525 | , \ compile n 526 | ; immediate 527 | 528 | \ compile: ( "name" -- ) 529 | \ '[compile] word' compiles word *now* even if it is immediate 530 | : [compile] 531 | ' , 532 | ; immediate 533 | 534 | \ ( xt -- ) 535 | \ postpone compilation of xt 536 | : (compile) 537 | [compile] literal \ compile 'literal' 538 | [ ' , ] literal , \ compile , 539 | ; 540 | 541 | \ compile: ( "name" -- ) 542 | \ 'compile word' compiles word *later* even if it is immediate 543 | : compile 544 | ' (compile) 545 | ; immediate 546 | 547 | \ runtime: ( w -- ) 548 | : compile, , ; 549 | 550 | \ ( -- xt ) 551 | : :noname 552 | align 553 | here latest , &latest ! 554 | smudge-bit c, \ length 0 555 | align 556 | here 557 | [ docol ] literal , \ compile docol 558 | ] \ enter compile mode 559 | ; 560 | 561 | \ ( "name" -- xt ) 562 | \ compile time tick 563 | : ['] 564 | ' \ read name and get xt 565 | [compile] literal \ call literal 566 | ; immediate 567 | 568 | \ === Constants === 569 | 570 | \ Since we don't have integer literals yet, 571 | \ define small integer words for convenience 572 | \ and readability. 573 | : 0 [ key 0 key 0 - ] literal ; 574 | : 1 [ key 1 key 0 - ] literal ; 575 | : 2 [ key 2 key 0 - ] literal ; 576 | : 3 [ key 3 key 0 - ] literal ; 577 | : 4 [ key 4 key 0 - ] literal ; 578 | : 5 [ key 5 key 0 - ] literal ; 579 | : 6 [ key 6 key 0 - ] literal ; 580 | : 7 [ key 7 key 0 - ] literal ; 581 | : 8 [ key 8 key 0 - ] literal ; 582 | : 9 [ key 9 key 0 - ] literal ; 583 | : 10 [ key : key 0 - ] literal ; 584 | : 11 [ key ; key 0 - ] literal ; 585 | : 12 [ key < key 0 - ] literal ; 586 | : 13 [ key = key 0 - ] literal ; 587 | : 14 [ key > key 0 - ] literal ; 588 | : 15 [ key ? key 0 - ] literal ; 589 | : 16 [ key @ key 0 - ] literal ; 590 | : -1 [ key 0 key 1 - ] literal ; 591 | 592 | : true 1 ; 593 | : false 0 ; 594 | 595 | \ === Address Arithmetic === 596 | 597 | : cell+ cell + ; 598 | : cell- cell - ; 599 | : cells cell * ; 600 | : char+ 1 + ; 601 | : char- 1 - ; 602 | : chars ; 603 | 604 | \ === Stack Manipulation === 605 | 606 | : drop sp@ cell+ sp! ; \ ( w -- ) 607 | : dup sp@ @ ; \ ( w -- w w ) 608 | 609 | : >r rp@ rp@ @ rp@ cell - dup rp! ! ! ; \ ( w -- R:w ) 610 | : r> rp@ cell + @ rp@ @ rp@ cell + dup rp! ! ; \ ( R:w -- w) 611 | : r@ rp@ cell + @ ; \ ( -- w, R: w -- w ) 612 | 613 | : swap sp@ cell + dup @ >r ! r> ; \ ( a b -- b a ) 614 | : rot >r swap r> swap ; \ ( a b c -- b c a ) 615 | : -rot swap >r swap r> ; \ ( a b c -- c a b ) 616 | : nip swap drop ; \ ( a b -- b ) 617 | : over >r dup r> swap ; \ ( a b -- a b a ) 618 | : tuck dup -rot ; \ ( a b -- b a b ) 619 | : pick cells sp@ + cell + @ ; \ ( xu ... x0 u -- xu ... x0 xu ) 620 | 621 | 622 | : 2drop drop drop ; \ ( a b -- ) 623 | : 3drop 2drop drop ; \ ( a b c -- ) 624 | : 2dup over over ; \ ( a b -- a b a b ) 625 | : 3dup 2 pick 2 pick 2 pick ; \ ( a b c -- a b c a b c ) 626 | : 2swap >r -rot r> -rot ; \ ( a b c d -- c d a b ) 627 | : 2nip 2swap 2drop ; \ ( a b c d -- c d ) 628 | : 2over 3 pick 3 pick ; \ ( a b c d -- a b c d a b ) 629 | : 2tuck 2swap 2over ; \ ( a b c d -- c d a b c d ) 630 | : 2rot >r >r 2swap r> r> 2swap ; \ ( a b c d e f -- c d e f a b ) 631 | : -2rot 2swap >r >r 2swap r> r> ; \ ( a b c d e f -- e f a b c d ) 632 | 633 | : rdrop r> rp@ ! ; \ ( R:w -- ) 634 | 635 | \ ( R xu ... x0 u -- xu ... x0 xu ) 636 | : rpick 637 | cells rp@ + cell + @ 638 | ; 639 | 640 | \ ( -- a-addr ) 641 | \ The bottom address of stacks. 642 | \ sp@ and rp@ points bottom if runtime so far is correct. 643 | : sp0 [ sp@ ] literal ; 644 | : rp0 [ rp@ ] literal ; 645 | 646 | \ === Integer Arithmetic === 647 | 648 | : 1+ 1 + ; 649 | : 1- 1 - ; 650 | 651 | : / /mod swap drop ; 652 | : mod /mod drop ; 653 | 654 | \ ( n -- -n ) 655 | : negate 0 swap - ; 656 | 657 | \ ( n1 -- n2 ) 658 | : not false = ; 659 | 660 | \ ( n1 -- n2 ) 661 | \ bitwise invert 662 | : invert -1 xor ; 663 | 664 | : > swap < ; 665 | : <= > not ; 666 | : >= < not ; 667 | : u> swap u< ; 668 | : u<= u> not ; 669 | : u>= u< not ; 670 | : <> = not ; 671 | 672 | : 0= 0 = ; 673 | : 0<> 0 <> ; 674 | : 0< 0 < ; 675 | : 0> 0 > ; 676 | : 0<= 0 <= ; 677 | : 0>= 0 >= ; 678 | 679 | \ ( x a b -- f ) 680 | \ Returns a <= x & x < b if a <= b. 681 | \ It is equivalent to x-a u< b-a. See chapter 4 of 682 | \ Hacker's delight. 683 | : within over - >r - r> u< ; 684 | 685 | \ arithmetic shift 686 | : 2* 1 lshift ; 687 | : 2/ 1 arshift ; 688 | 689 | \ === Conditional Branch === 690 | \ if then 691 | \ if else then 692 | \ unless then 693 | \ unless else then 694 | 695 | \ compile: ( -- orig ) 696 | \ runtime: ( n -- ) 697 | : if 698 | compile 0branch 699 | here 0 , \ save location of offset, fill dummy 700 | ; immediate 701 | 702 | \ compile: ( orig -- ) 703 | \ runtime: ( -- ) 704 | : then 705 | here \ ( orig dest ) 706 | over - \ ( orig offset ) 707 | swap ! \ fill offset to orig 708 | ; immediate 709 | 710 | \ compile: ( orig1 -- orig2 ) 711 | \ runtime: ( -- ) 712 | : else 713 | compile branch 714 | here 0 , \ save location of offset, fill dummy 715 | swap 716 | \ fill offset, here-orig1, to orig1 717 | here 718 | over - 719 | swap ! 720 | ; immediate 721 | 722 | \ compile: ( -- orig ) 723 | \ runtime: ( n -- ) 724 | : unless 725 | compile not 726 | [compile] if 727 | ; immediate 728 | 729 | \ ( n -- n n | n ) 730 | \ duplicate if n<>0 731 | : ?dup dup if dup then ; 732 | 733 | \ === Loops === 734 | \ begin until 735 | \ begin again 736 | \ begin while repeat 737 | 738 | \ compile: ( -- dest ) 739 | \ runtime: ( -- ) 740 | : begin 741 | here \ save location 742 | ; immediate 743 | 744 | \ compile: ( dest -- ) 745 | \ runtime: ( n -- ) 746 | : until 747 | compile 0branch 748 | here - , \ fill offset 749 | ; immediate 750 | 751 | \ compile: ( dest -- ) 752 | \ runtime: ( -- ) 753 | : again 754 | compile branch 755 | here - , \ fill offset 756 | ; immediate 757 | 758 | \ compile: ( dest -- orig dest ) 759 | \ runtime: ( n -- ) 760 | \ dest=location of begin 761 | \ orig=location of while 762 | : while 763 | compile 0branch 764 | here swap 765 | 0 , \ save location, fill dummy 766 | ; immediate 767 | 768 | \ compile: ( orig dest -- ) 769 | \ runtime: ( -- ) 770 | \ dest=location of begin 771 | \ orig=location of while 772 | : repeat 773 | compile branch 774 | here - , \ fill offset from here to begin 775 | here over - swap ! \ backfill offset from while to here 776 | ; immediate 777 | 778 | \ === Recursive Call === 779 | 780 | \ recursive call. 781 | \ compiles xt of current definition 782 | : recurse 783 | latest >cfa , 784 | ; immediate 785 | 786 | \ === Case === 787 | 788 | \ --- 789 | \ case 790 | \ of endof 791 | \ of endof 792 | \ ... 793 | \ 794 | \ endcase 795 | \ --- 796 | \ This is equivalent to 797 | \ --- 798 | \ 799 | \ over = if drop else 800 | \ over = if drop else 801 | \ ... 802 | \ 803 | \ then ... then then 804 | \ --- 805 | 806 | 807 | \ compile: ( -- 0 ) 808 | \ runtime: ( n -- ) 809 | : case 810 | 0 \ push 0 to indicate there is no more case 811 | ; immediate 812 | 813 | \ compile: ( -- orig ) 814 | : of 815 | compile over 816 | compile = 817 | [compile] if 818 | compile drop 819 | ; immediate 820 | 821 | \ a b rangeof endof 822 | \ Execute when 823 | \ a <= and <= b 824 | : rangeof 825 | compile 2 826 | compile pick 827 | compile >= 828 | compile swap 829 | compile 2 830 | compile pick 831 | compile <= 832 | compile and 833 | [compile] if 834 | compile drop 835 | ; immediate 836 | 837 | \ compile: ( orig1 -- orig2 ) 838 | : endof 839 | [compile] else 840 | ; immediate 841 | 842 | : endcase 843 | compile drop 844 | begin ?dup while 845 | [compile] then 846 | repeat 847 | ; immediate 848 | 849 | \ === Integer Arithmetic (that require control flow words) === 850 | \ ( a b -- c ) 851 | : max 2dup > if drop else nip then ; 852 | : min 2dup < if drop else nip then ; 853 | 854 | : abs dup 0< if negate then ; 855 | 856 | \ === Multiline Comment === 857 | 858 | : '(' [ key ( ] literal ; 859 | : ')' [ key ) ] literal ; 860 | 861 | : ( 862 | 1 \ depth counter 863 | begin ?dup while 864 | key! case 865 | '(' of 1+ endof \ increment depth 866 | ')' of 1- endof \ decrement depth 867 | endcase 868 | repeat 869 | ; immediate 870 | 871 | ( 872 | Now we can use multiline comment with ( nests. ) 873 | ) 874 | 875 | ( === Memory Operation === ) 876 | 877 | : +! ( n a-addr -- ) tuck @ + swap ! ; 878 | : -! ( n a-addr -- ) tuck @ swap - swap ! ; 879 | 880 | \ allocate n bytes 881 | : allot ( n -- ) &here +! ; 882 | 883 | ( === create and does> === ) 884 | 885 | \ no-operation 886 | : nop ; 887 | 888 | \ ( "name" -- ) 889 | \ Read name and create new dictionary entry. 890 | \ When the word is executed, it pushs value of here 891 | \ at the end of the entry. 892 | : create 893 | align 894 | latest , \ fill link 895 | here cell- &latest ! \ update latest 896 | word! dup strlen 897 | dup c, memcpy, 0 c, align \ fill length, name and \0 898 | docol , \ compile docol 899 | ['] lit , 900 | here 3 cells + , \ compile the address 901 | ['] nop , \ does>, if any, will fill this cell 902 | ['] exit , \ compile exit 903 | ; 904 | 905 | : >body ( xt -- a-addr ) 906 | 5 cells + 907 | ; 908 | 909 | : (does>) 910 | latest >cfa 911 | 3 cells + ! \ replace nop 912 | ; 913 | 914 | : does> 915 | align 916 | 0 [compile] literal \ literal for xt 917 | here cell- \ save addr of xt 918 | 919 | \ replace nop with xt at runtime 920 | compile (does>) 921 | 922 | [compile] ; \ finish compilation of initialization part 923 | :noname \ start compilation of does> part 924 | swap ! \ backfill xt to the operand of literal 925 | ; immediate 926 | 927 | ( === Variable and Constant === ) 928 | 929 | \ ( "name" -- ) 930 | : variable create 0 , ; 931 | 932 | \ ( n "name" -- ) 933 | : constant create , does> @ ; 934 | 935 | ( === Value === ) 936 | 937 | \ ( n "name" -- ) 938 | : value create , does> @ ; 939 | 940 | \ ( n "name" -- ) 941 | : to 942 | word! find! >cfa >body 943 | state @ if 944 | [compile] literal 945 | compile ! 946 | else 947 | ! 948 | then 949 | ; immediate 950 | 951 | ( === Throw and Catch === ) 952 | 953 | \ 'xt catch' saves data stack pointer and a marker 954 | \ to indicate where to return on return stack 955 | \ then execute 'xt'. 956 | \ When 'n throw' is executed, the catch statement returns 957 | \ 'n'. If no throw is executed, returns 0. 958 | 959 | \ At the beginning of execution of 'xt', return stack 960 | \ contains following information. 961 | \ +-------------------------+ 962 | \ | original return address | 963 | \ | saved stack pointer | 964 | \ | exception marker | <- top of return stack 965 | \ +-------------------------+ 966 | \ If no 'throw' is called, after execution of 'xt' 967 | \ program goes to the exception-marker because it is 968 | \ on the top of return stack. 969 | \ The exception-marker drops 'saved stack pointer', 970 | \ push 0 to indicate no error and return to the 971 | \ 'original return address'. 972 | \ When 'n throw' is called, it scans return stack 973 | \ to find the exception-marker, restore return stack pointer 974 | \ and data stack pointer, push error code, and returns to 975 | \ the 'original return address' 976 | 977 | create exception-marker 978 | ' rdrop , \ drop saved stack pointer 979 | 0 literal \ push 0 to indicate no-error 980 | ' exit , 981 | 982 | : catch ( xt -- n ) 983 | sp@ cell+ >r \ save stack pointer 984 | exception-marker >r \ push exception marker 985 | execute 986 | ; 987 | 988 | : success 0 ; 989 | 990 | : throw ( w -- ) 991 | ?dup unless exit then \ do nothing if no error 992 | rp@ 993 | begin 994 | dup rp0 cell- < \ rp < rp0 995 | while 996 | dup @ \ load return stack entry 997 | exception-marker = if 998 | rp! \ restore return stack pointer 999 | rdrop \ drop exception marker 1000 | 1001 | \ Reserve enough working space of data stack since 1002 | \ following code manipulates data stack pointer 1003 | \ and write value to data stack directly via 1004 | \ address. 1005 | dup dup dup dup 1006 | 1007 | r> \ original stack pointer 1008 | \ ( n sp ) 1009 | cell- \ allocate space for error code 1010 | tuck ! \ store error code of top of stack 1011 | sp! \ restore data stack pointer 1012 | exit 1013 | then 1014 | cell+ 1015 | repeat 1016 | drop 1017 | ; 1018 | 1019 | ( === Printing Numbers === ) 1020 | 1021 | \ Skip reading spaces, read characters and returns first character 1022 | : char ( ccc -- c ) word! c@ ; 1023 | 1024 | \ compile-time version of char 1025 | : [char] ( compile: ccc -- ; runtime: --- c ) 1026 | char 1027 | [compile] literal 1028 | ; immediate 1029 | 1030 | 1031 | : '\n' [ key : key 0 - ] literal ; \ newline (10) 1032 | : bl [ key P key 0 - ] literal ; \ space (32) 1033 | : '"' [char] "" ; 1034 | 1035 | : cr '\n' emit ; 1036 | : space bl emit ; 1037 | 1038 | 1039 | variable base \ number base 1040 | : decimal 10 base ! ; 1041 | : hex 16 base ! ; 1042 | 1043 | decimal \ set default to decimal 1044 | 1045 | : '0' [char] 0 ; 1046 | : '9' [char] 9 ; 1047 | : 'a' [char] a ; 1048 | : 'x' [char] x ; 1049 | : 'z' [char] z ; 1050 | : 'A' [char] A ; 1051 | : 'Z' [char] Z ; 1052 | : '-' [char] - ; 1053 | : '&' [char] & ; 1054 | : '#' [char] # ; 1055 | : '%' [char] % ; 1056 | : '$' [char] $ ; 1057 | : '\'' [char] ' ; 1058 | : '\\' [char] \ ; 1059 | : 'a' [char] a ; 1060 | : 'b' [char] b ; 1061 | : 't' [char] t ; 1062 | : 'n' [char] n ; 1063 | : 'v' [char] v ; 1064 | : 'f' [char] f ; 1065 | : 'r' [char] r ; 1066 | 1067 | \ Display unsigned integer u2 with number base u1. 1068 | : print-uint ( u1 u2 -- ) 1069 | over /mod ( base mod quot ) 1070 | ?dup if 1071 | >r over r> \ ( base mod base quot ) 1072 | recurse 1073 | then 1074 | dup 10 < if '0' + else 10 - 'a' + then emit 1075 | drop 1076 | ; 1077 | 1078 | \ Display signed integer n with number base u. 1079 | : print-int ( u n -- ) 1080 | dup 0< if '-' emit negate then 1081 | print-uint 1082 | ; 1083 | 1084 | \ Display unsigned integer followed by a space. 1085 | : u. ( u -- ) base @ swap print-uint space ; 1086 | 1087 | \ Display n followed by a space. 1088 | : . ( n -- ) base @ swap print-int space ; 1089 | 1090 | \ Display n as a signed decimal number followed by a space. 1091 | : dec. ( n -- ) 10 swap print-int space ; 1092 | 1093 | \ Display u as an unsigned hex number prefixed with $ 1094 | \ and followed by a space. 1095 | : hex. ( u -- ) '$' emit 16 swap print-uint space ; 1096 | 1097 | \ Number of characters of u in 'base' 1098 | : uwidth ( u -- u ) 1099 | base @ / 1100 | ?dup if recurse 1+ else 1 then 1101 | ; 1102 | 1103 | : spaces ( n -- ) 1104 | begin dup 0> while space 1- repeat drop 1105 | ; 1106 | 1107 | \ Display unsigned integer u right aligned in n characters. 1108 | : u.r ( u n -- ) 1109 | over uwidth 1110 | - spaces base @ swap print-uint 1111 | ; 1112 | 1113 | \ Display signed integer n1 right aligned in n2 characters. 1114 | : .r ( n1 n2 -- ) 1115 | over 0>= if 1116 | u.r 1117 | else 1118 | swap negate 1119 | dup uwidth 1+ 1120 | rot swap - spaces 1121 | '-' emit 1122 | base @ swap print-uint 1123 | then 1124 | ; 1125 | 1126 | ( === Parsing Numbers === ) 1127 | 1128 | \ Parse string c-addr as an unsigned integer with base u 1129 | \ and return n. f represents the conversion is success or not. 1130 | : parse-uint ( u c-addr -- n f ) 1131 | 0 \ accumulator 1132 | begin over c@ while 1133 | \ ( base addr acc ) 1134 | >r \ save acc 1135 | dup c@ swap 1+ >r \ load char, increment addr and save 1136 | dup case 1137 | '0' '9' rangeof '0' - endof 1138 | 'a' 'z' rangeof 'a' - 10 + endof 1139 | 'A' 'Z' rangeof 'A' - 10 + endof 1140 | \ failed to convert 1141 | 2drop r> r> nip false 1142 | exit 1143 | endcase 1144 | 2dup 1145 | \ ( base n base n ) 1146 | swap 0 swap 1147 | \ ( base n n 0 base ) 1148 | within unless 1149 | \ failed to convert 1150 | 2drop r> r> nip false 1151 | exit 1152 | then 1153 | \ ( base addr n acc ) 1154 | r> swap r> 1155 | 3 pick * + 1156 | repeat 1157 | \ success 1158 | nip nip true 1159 | ; 1160 | 1161 | : parse-int ( u c-addr -- n f ) 1162 | dup c@ '-' = if 1163 | 1+ parse-uint swap negate swap 1164 | else 1165 | parse-uint 1166 | then 1167 | ; 1168 | 1169 | \ Return ascii-code of corresponding escaped char 1170 | \ e.g '\n' escaped-char -> 10 1171 | : escaped-char ( n -- n ) 1172 | case 1173 | '0' of 0 endof 1174 | 'a' of 7 endof 1175 | 'b' of 8 endof 1176 | 't' of 9 endof 1177 | 'n' of 10 endof 1178 | 'v' of 11 endof 1179 | 'f' of 12 endof 1180 | 'r' of 13 endof 1181 | [char] ' of [char] ' endof 1182 | [char] " of [char] " endof 1183 | '\\' of '\\' endof 1184 | drop -1 1185 | endcase 1186 | ; 1187 | 1188 | \ Parse string as number. 1189 | \ This function interprets prefixes that specifies number base. 1190 | : >number ( c-addr -- n f ) 1191 | dup c@ unless 1192 | drop 1193 | 0 false 1194 | exit 1195 | then 1196 | dup c@ case 1197 | '-' of 1198 | 1+ 1199 | recurse if 1200 | negate true 1201 | else 1202 | false 1203 | then 1204 | endof 1205 | '&' of 1+ 10 swap parse-int endof 1206 | '#' of 1+ 10 swap parse-int endof 1207 | '$' of 1+ 16 swap parse-int endof 1208 | '%' of 1+ 2 swap parse-int endof 1209 | '0' of 1210 | \ hexadecimal 1211 | \ ( addr ) 1212 | 1+ 1213 | dup c@ unless 1214 | drop 0 true exit 1215 | then 1216 | dup c@ 'x' = if 1217 | 1+ 16 swap parse-uint exit 1218 | then 1219 | drop 0 false exit 1220 | endof 1221 | '\'' of 1222 | \ character code 1223 | \ ( addr ) 1224 | 1+ 1225 | dup c@ unless 1226 | drop 0 false exit 1227 | then 1228 | dup c@ '\\' = if 1229 | 1+ dup c@ escaped-char swap 1+ 1230 | else 1231 | dup c@ swap 1+ 1232 | then 1233 | c@ case 1234 | 0 of true exit endof 1235 | '\'' of true exit endof 1236 | drop 0 false 1237 | endcase 1238 | endof 1239 | \ default case 1240 | \ ( addr base ) 1241 | drop base @ swap parse-uint 1242 | dup \ need this because endcase drops top of stack 1243 | endcase 1244 | ; 1245 | 1246 | ( === String === ) 1247 | 1248 | \ c-addr2 = c-addr1+n 1249 | \ u2 = u1-n 1250 | : succ-buffer ( c-addr1 u1 n -- c-addr2 u2 ) 1251 | dup -rot - >r + r> 1252 | ; 1253 | 1254 | \ ( c-from c-to u -- ) 1255 | \ Copy u bytes from c-from to c-to. 1256 | \ The memory regions must not be overlapped. 1257 | : memcpy 1258 | begin dup 0> while 1259 | 1- >r \ decrement u, save 1260 | over c@ 1261 | over c! \ copy character 1262 | 1+ >r \ increment c-to, save 1263 | 1+ \ increment c-from 1264 | r> r> 1265 | repeat 3drop 1266 | ; 1267 | 1268 | \ we already have memcpy, 1269 | 1270 | \ ( c-from c-to -- ) 1271 | \ copy nul terminated string from c-from to c-to 1272 | : strcpy 1273 | begin over c@ dup while 1274 | \ ( c-from c-to c ) 1275 | over c! 1276 | 1+ swap 1+ swap 1277 | repeat 1278 | over c! 1279 | 2drop 1280 | ; 1281 | 1282 | \ ( c-addr -- ) 1283 | \ copy string to here including \0 1284 | : strcpy, 1285 | begin dup c@ dup while 1286 | c, 1+ 1287 | repeat 2drop 1288 | 0 c, 1289 | ; 1290 | 1291 | \ ( c-from c-to u -- ) 1292 | : strncpy 1293 | begin dup 0> while 1294 | >r 1295 | \ ( c-from c-to ) 1296 | over c@ over c! 1297 | over c@ unless r> 3drop exit then 1298 | 1+ swap 1+ swap r> 1- 1299 | repeat 1300 | drop 1- 0 swap c! drop 1301 | ; 1302 | 1303 | \ ( c-addr1 c-addr2 u -- f ) 1304 | : strneq 1305 | begin dup 0> while 1306 | 1- >r 1307 | dup 1+ >r c@ 1308 | swap dup 1+ >r c@ 1309 | <> if rdrop rdrop rdrop false exit then 1310 | r> r> r> 1311 | repeat 1312 | 3drop true 1313 | ; 1314 | 1315 | \ Print string 1316 | : type ( c-addr -- ) 1317 | begin dup c@ dup while \ while c<>\0 1318 | emit 1+ 1319 | repeat 1320 | 2drop 1321 | ; 1322 | 1323 | \ Print string up to u characters 1324 | : typen ( c-addr u -- ) 1325 | begin dup 0> while 1326 | 1- swap dup c@ dup unless 1327 | 2drop exit 1328 | then 1329 | emit 1+ swap 1330 | repeat 2drop 1331 | ; 1332 | 1333 | 1334 | \ Allocate a buffer for string literal 1335 | bl bl * constant s-buffer-size \ 1024 1336 | create s-buffer s-buffer-size allot 1337 | 1338 | \ Will define the error message corresponds to this error later 1339 | \ because we can't write string literal yet. 1340 | char 0 char B - constant STRING-OVERFLOW-ERROR \ -18 1341 | 1342 | \ Parse string delimited by " 1343 | \ compile mode: the string is stored as operand of 'string' operator. 1344 | \ immediate mode: the string is stored to temporary buffer. 1345 | : s" 1346 | state @ if 1347 | compile litstring 1348 | here 0 , \ save location of length and fill dummy 1349 | 0 \ length of the string + 1 (\0) 1350 | begin key! dup '"' <> while 1351 | dup '\\' = if drop key! escaped-char then 1352 | c, \ store character 1353 | 1+ \ increment length 1354 | repeat drop 1355 | 0 c, \ store \0 1356 | 1+ aligned 1357 | swap ! \ back-fill length 1358 | align 1359 | else 1360 | s-buffer dup \ save start address 1361 | begin key! dup '"' <> while 1362 | dup '\\' = if drop key! escaped-char then 1363 | over 3 pick - s-buffer-size 1- >= if 1364 | STRING-OVERFLOW-ERROR throw 1365 | then 1366 | over c! \ store char 1367 | 1+ \ increment address 1368 | repeat drop 1369 | 0 swap c! \ store \0 1370 | then 1371 | ; immediate 1372 | 1373 | \ Print string delimited by " 1374 | : ." 1375 | [compile] s" 1376 | state @ if 1377 | compile type 1378 | else 1379 | type 1380 | then 1381 | ; immediate 1382 | 1383 | ( === Error Code and Messages === ) 1384 | 1385 | \ Single linked list of error code and messages. 1386 | \ Thre structure of each entry: 1387 | \ | link | code | message ... | 1388 | variable error-list 1389 | 0 error-list ! 1390 | 1391 | : error>next ( a-addr -- a-addr) @ ; 1392 | : error>message ( a-addr -- c-addr ) 2 cells + ; 1393 | : error>code ( a-addr -- n ) cell+ @ ; 1394 | 1395 | : add-error ( n c-addr -- ) 1396 | error-list here 1397 | ( n c-addr ) 1398 | over @ , \ fill link 1399 | swap ! \ update error-list 1400 | swap , \ fill error-code 1401 | strcpy, \ fill message 1402 | ; 1403 | 1404 | : def-error ( n c-addr "name" -- ) 1405 | create over , 1406 | add-error 1407 | does> @ 1408 | ; 1409 | 1410 | decimal 1411 | STRING-OVERFLOW-ERROR s" Too long string literal" add-error 1412 | 1413 | variable next-user-error 1414 | s" -256" >number drop next-user-error ! 1415 | 1416 | \ Create new user defined error and returns error code. 1417 | : exception ( c-addr -- n ) 1418 | next-user-error @ swap add-error 1419 | next-user-error @ 1420 | 1 next-user-error -! 1421 | ; 1422 | 1423 | ( === 3rd Stage Interpreter === ) 1424 | 1425 | s" -13" >number drop s" Undefined word" def-error UNDEFINED-WORD-ERROR 1426 | :noname 1427 | find ?dup unless UNDEFINED-WORD-ERROR throw then 1428 | ; &find! ! 1429 | 1430 | create word-buffer s" 64" >number drop cell+ allot 1431 | 1432 | : interpret 1433 | word! \ read name from input 1434 | \ ( addr ) 1435 | dup word-buffer strcpy \ save input 1436 | dup find \ lookup dictionary 1437 | ?dup if 1438 | \ Found the word 1439 | nip 1440 | state @ if 1441 | \ compile mode 1442 | dup cell+ c@ immediate-bit and if 1443 | \ execute immediate word 1444 | >cfa execute 1445 | else 1446 | \ compile the word 1447 | >cfa , 1448 | then 1449 | else 1450 | \ immediate mode 1451 | >cfa execute 1452 | then 1453 | else 1454 | >number unless 1455 | UNDEFINED-WORD-ERROR throw 1456 | then 1457 | \ Not found 1458 | state @ if 1459 | \ compile mode 1460 | [compile] literal 1461 | then 1462 | then 1463 | ; 1464 | 1465 | :noname 1466 | rp0 rp! \ drop 2nd stage 1467 | begin 1468 | ['] interpret catch 1469 | ?dup if 1470 | \ lookup error code 1471 | error-list @ 1472 | begin ?dup while 1473 | \ ( error-code error-entry ) 1474 | dup error>code 1475 | 2 pick = if 1476 | error>message type 1477 | ." : " 1478 | word-buffer type cr 1479 | bye 1480 | then 1481 | error>next 1482 | repeat 1483 | ." Unknown error code: " 1484 | word-buffer type 1485 | ." (" 0 .r ." )" cr 1486 | bye 1487 | then 1488 | again 1489 | ; execute 1490 | 1491 | ( === Error-codes === ) 1492 | 1493 | decimal 1494 | -1 s" Aborted" def-error ABORTED-ERROR 1495 | -37 s" File I/O exception" def-error FILE-IO-ERROR 1496 | -39 s" Unexpected end of file" def-error UNEXPECTED-EOF-ERROR 1497 | -59 s" ALLOCATE" def-error ALLOCATE-ERROR 1498 | -62 s" CLOSE-FILE" def-error CLOSE-FILE-ERROR 1499 | -68 s" FLUSH-FILE" def-error FLUSH-FILE-ERROR 1500 | -69 s" OPEN-FILE" def-error OPEN-FILE-ERROR 1501 | -70 s" READ-FILE" def-error READ-FILE-ERROR 1502 | -71 s" READ-LINE" def-error READ-LINE-ERROR 1503 | -75 s" WRITE-FILE" def-error WRITE-FILE-ERROR 1504 | 1505 | : abort ABORTED-ERROR throw ; 1506 | 1507 | s" Not implemented" exception constant NOT-IMPLEMENTED 1508 | : not-implemented NOT-IMPLEMENTED throw ; 1509 | 1510 | s" Not supported" exception constant NOT-SUPPORTED 1511 | : not-supported NOT-SUPPORTED throw ; 1512 | 1513 | ( 31 bytes ) 1514 | s" Not reachable here. may be a bug" exception constant NOT-REACHABLE 1515 | : not-reachable NOT-REACHABLE throw ; 1516 | 1517 | ( === Do-loop === ) 1518 | 1519 | \ limit start do ... loop 1520 | 1521 | 1 constant do-mark 1522 | 2 constant leave-mark 1523 | 1524 | create do-stack 16 cells allot 1525 | variable do-sp 1526 | do-stack 16 cells + do-sp ! 1527 | 1528 | : >do ( w -- do: w ) 1529 | cell do-sp -! 1530 | do-sp @ ! 1531 | ; 1532 | 1533 | : do> ( do: w -- w ) 1534 | do-sp @ @ 1535 | cell do-sp +! 1536 | ; 1537 | 1538 | : do@ ( do: w -- w, do: w) 1539 | do-sp @ @ 1540 | ; 1541 | 1542 | \ compile: ( -- do: dest mark ) 1543 | : do 1544 | compile >r \ save start 1545 | compile >r \ save limit 1546 | here >do do-mark >do 1547 | ; immediate 1548 | 1549 | \ compile: ( -- ... ) 1550 | : ?do 1551 | compile 2dup 1552 | compile >r \ save start 1553 | compile >r \ save limit 1554 | compile <> 1555 | compile 0branch 1556 | 0 , 1557 | here >do do-mark >do 1558 | here cell- >do leave-mark >do 1559 | ; immediate 1560 | 1561 | : leave ( -- do: orig mark ) 1562 | compile branch 1563 | here >do 1564 | 0 , \ fill dummy offset 1565 | leave-mark >do 1566 | ; immediate 1567 | 1568 | : backpatch-leave ( dest , do: orig1 mark1 ... -- do: origN markN ... ) 1569 | begin do@ leave-mark = while 1570 | do> drop do> 1571 | 2dup - 1572 | swap ! 1573 | repeat 1574 | drop 1575 | ; 1576 | 1577 | : loop 1578 | compile r> 1579 | compile r> 1580 | compile 1+ 1581 | compile 2dup 1582 | compile >r 1583 | compile >r 1584 | compile = 1585 | compile 0branch 1586 | here cell + backpatch-leave \ leave jumps to here 1587 | do> drop \ do-mark 1588 | do> here - , 1589 | compile rdrop 1590 | compile rdrop 1591 | ; immediate 1592 | 1593 | \ This code is taken from Gforth 1594 | : crossed-boundary? ( d n i ) 1595 | swap - ( d i-n ) 1596 | 2dup + ( d i-n i+d-n ) 1597 | over xor ( d i-n (i-n)^(i+d-n) ) 1598 | >r xor r> ( d^(i-n) (i^n)^(i+d-n) ) 1599 | and 0< 1600 | ; 1601 | 1602 | : +loop 1603 | compile r> 1604 | compile r> 1605 | compile 3dup 1606 | compile rot 1607 | compile + 1608 | compile >r 1609 | compile >r 1610 | compile crossed-boundary? 1611 | compile 0branch 1612 | here cell + backpatch-leave \ leave jumps to here 1613 | do> drop \ do-mark 1614 | do> here - , 1615 | compile rdrop 1616 | compile rdrop 1617 | ; immediate 1618 | 1619 | : unloop ( R:a b -- ) 1620 | compile rdrop 1621 | compile rdrop 1622 | ; immediate 1623 | 1624 | : i 2 rpick ; 1625 | : j 4 rpick ; 1626 | : k 6 rpick ; 1627 | 1628 | ( === Dump of data stack === ) 1629 | 1630 | \ ( -- n ) 1631 | \ Number of elements in the stack 1632 | : depth sp0 sp@ - cell- cell / ; 1633 | : rdepth rp0 rp@ - cell / ; 1634 | 1635 | : .s ( -- ) 1636 | depth 1637 | '<' emit 0 u.r '>' emit space 1638 | sp@ sp0 ( beg end ) 1639 | begin 2dup < while 1640 | cell- dup @ . 1641 | repeat 2drop 1642 | cr 1643 | ; 1644 | 1645 | ( === Data Structure === ) 1646 | 1647 | \ align n1 to u-byte boundary 1648 | : aligned-by ( n1 u -- n2 ) 1649 | 1- dup invert \ ( n1 u-1 ~(u-1) ) 1650 | -rot + and 1651 | ; 1652 | 1653 | \ align here to u-byte boundary 1654 | : align-by ( u -- ) 1655 | here swap aligned-by &here ! 1656 | ; 1657 | 1658 | : struct ( -- offset ) 1659 | 0 1660 | ; 1661 | 1662 | \ struct ... end-struct new-word 1663 | \ defines new-word as an operator 1664 | \ that returns alignment and size of the struct. 1665 | \ new-word: ( -- align size ) 1666 | : end-struct ( offset "name" -- ) 1667 | create , does> @ cell swap 1668 | ; 1669 | 1670 | : cell% ( -- align size ) cell cell ; 1671 | : char% ( -- align size ) 1 1 ; 1672 | : byte% 1 1 ; 1673 | : ptr% cell% ; 1674 | : int% cell% ; 1675 | : i32% 4 4 ; 1676 | : u32% 4 4 ; 1677 | : i16% 2 2 ; 1678 | : u16% 2 2 ; 1679 | 1680 | \ allocate user memory 1681 | : %allot ( align size -- addr ) 1682 | here -rot swap align-by allot 1683 | ; 1684 | 1685 | : field ( offset1 align size "name" -- offset2 ) 1686 | \ align offset with 'align' 1687 | -rot aligned-by \ ( size offset ) 1688 | create 1689 | dup , \ fill offset 1690 | + \ return new offset 1691 | does> @ + 1692 | ; 1693 | 1694 | ( === File I/O === ) 1695 | 1696 | -1 constant EOF 1697 | 1698 | \ file access methods (fam) 1699 | 0x000 constant R/O \ read-only 1700 | 0x241 constant W/O \ write-only 1701 | 0x242 constant R/W \ read-write 1702 | 1703 | 1024 constant BUFSIZE 1704 | 128 constant FILENAME-MAX 1705 | 1706 | \ File 1707 | struct 1708 | cell% field file>fd \ file descriptor 1709 | cell% field file>read ( c-addr u fd -- n ) 1710 | cell% field file>write ( c-addr u fd -- n ) 1711 | 1712 | char% field file>fam 1713 | char% FILENAME-MAX * field file>name 1714 | 1715 | \ read buffer 1716 | cell% field file>rbuf 1717 | cell% field file>rbeg \ read head 1718 | cell% field file>rend 1719 | 1720 | \ write buffer 1721 | cell% field file>wbuf 1722 | cell% field file>wbeg \ write head 1723 | cell% field file>wend 1724 | end-struct file% 1725 | 1726 | : writable? ( file -- f ) file>fam c@ R/O <> ; 1727 | : readable? ( file -- f ) file>fam c@ W/O <> ; 1728 | 1729 | \ Write buffer 1730 | \ +-------------+-----+ 1731 | \ |aaaaaaaaaaaaa| | 1732 | \ +-------------+-----+ 1733 | \ ^ ^ ^ 1734 | \ wbuf wbeg wend 1735 | 1736 | : write-buffer-content ( file -- c-addr u ) 1737 | dup file>wbeg @ swap file>wbuf @ tuck - 1738 | ; 1739 | 1740 | : empty-write-buffer ( file -- ) 1741 | dup file>wbuf @ over file>wbeg ! 1742 | dup file>wbuf @ over file>wend ! 1743 | drop 1744 | ; 1745 | 1746 | : succ-write-buffer ( file n -- ) 1747 | swap file>wbeg +! 1748 | ; 1749 | 1750 | : write-buffer-count ( file -- n ) 1751 | dup file>wbeg @ swap file>wbuf @ - 1752 | ; 1753 | 1754 | \ Read buffer 1755 | \ +-------------+-----+ 1756 | \ | |aaaaaaa| | 1757 | \ +-------------+-----+ 1758 | \ ^ ^ ^ 1759 | \ rbuf rbeg rend 1760 | 1761 | : read-buffer-content ( file -- c-addr u) 1762 | dup file>rend @ swap file>rbeg @ tuck - 1763 | ; 1764 | 1765 | : empty-read-buffer ( file -- ) 1766 | dup file>rbuf @ over file>rbeg ! 1767 | dup file>rbuf @ over file>rend ! 1768 | drop 1769 | ; 1770 | 1771 | : succ-read-buffer ( file n -- ) 1772 | swap file>rbeg +! 1773 | ; 1774 | 1775 | : read-buffer-count ( file -- n ) 1776 | dup file>rend @ swap file>rbeg @ - 1777 | ; 1778 | 1779 | \ Flush output buffer of file, return error-code. 1780 | : flush-file ( file -- e ) 1781 | dup writable? unless FLUSH-FILE-ERROR exit then 1782 | dup write-buffer-content ( file buf u ) 1783 | begin 1784 | ( file buf u ) 1785 | dup 0= if 2drop empty-write-buffer success exit then 1786 | 2dup 4 pick file>fd @ 5 pick file>write @ execute 1787 | ( file buf u n ) 1788 | dup 0< if 2drop FLUSH-FILE-ERROR exit then 1789 | ( file buf u n ) 1790 | 2dup < if not-reachable then 1791 | tuck - >r + r> 1792 | ( file buf+n u-n ) 1793 | again 1794 | ; 1795 | 1796 | \ Write bytes from c-addr u to file, return error-code. 1797 | : write-file ( c-addr u file -- e ) 1798 | dup writable? unless WRITE-FILE-ERROR exit then 1799 | over 0<= if 3drop WRITE-FILE-ERROR exit then 1800 | 1801 | dup write-buffer-content nip BUFSIZE swap - ( space ) 1802 | 2 pick 1803 | ( c-addr u file space u ) 1804 | >= if 1805 | \ enogu space, copy u-bytes from c-addr to buf 1806 | ( c-addr u file ) 1807 | 2 pick over file>wbeg @ 3 pick memcpy 1808 | \ increment wbeg 1809 | swap succ-write-buffer drop success exit 1810 | then 1811 | ( c-addr u file buf ) 1812 | not-implemented 1813 | dup flush-file throw 1814 | 1815 | over BUFSIZE <= if 1816 | \ fill data to wbuf 1817 | 2 pick over file>wbeg @ 3 pick memcpy 1818 | swap succ-write-buffer drop success exit 1819 | then 1820 | 1821 | \ write large data directly to the file 1822 | begin 1823 | ( c-addr u file ) 1824 | 2 pick 2 pick 2 pick file>fd @ 3 pick file>write @ execute 1825 | ( c-addr u file n ) 1826 | dup 0< if 2drop 2drop WRITE-FILE-ERROR exit then 1827 | swap >r succ-buffer r> 1828 | over 0> 1829 | until 1830 | empty-write-buffer 2drop success 1831 | ; 1832 | 1833 | \ Read u1-bytes at most from file, write it to c-addr. 1834 | \ Return number of bytes read and error-code. 1835 | : read-file ( c-addr u1 file -- u2 e ) 1836 | dup readable? unless READ-FILE-ERROR exit then 1837 | over 0<= if 3drop 0 success exit then 1838 | 1839 | dup read-buffer-count 2 pick ( count u1 ) 1840 | >= if 1841 | \ enough data in read buffer 1842 | dup file>rbeg @ 3 pick 3 pick memcpy 1843 | \ increment rbeg 1844 | over succ-read-buffer 1845 | nip success exit 1846 | then 1847 | 1848 | \ copy rbeg..rend to the buffer 1849 | dup read-buffer-content 4 pick swap memcpy 1850 | ( buf u file ) 1851 | dup read-buffer-count dup >r 1852 | ( buf u file n , R:written ) 1853 | swap >r succ-buffer r> 1854 | dup empty-read-buffer 1855 | 1856 | ( buf u file , R:count ) 1857 | over BUFSIZE <= if 1858 | \ read data to rbuf as much as BUFSIZE 1859 | dup file>rbuf @ BUFSIZE 2 pick file>fd @ 3 pick file>read @ execute 1860 | dup 0< if 2drop 2drop r> READ-FILE-ERROR exit then 1861 | ( buf u file n , R:count ) 1862 | dup 2 pick file>rend +! 1863 | 2 pick min 1864 | over file>rbeg @ 4 pick 2 pick memcpy 1865 | dup 2 pick file>rbeg +! 1866 | ( buf u file n , R:count ) 1867 | >r 3drop r> r> + success 1868 | else 1869 | \ read large data directly from the file 1870 | dup file>fd @ swap file>read @ execute 1871 | ( n , R:count ) 1872 | dup 0< if drop r> READ-FILE-ERROR exit then 1873 | r> + success 1874 | then 1875 | ; 1876 | 1877 | \ Read a character. Return EOF at end of input. 1878 | : key-file ( file -- c ) 1879 | 0 sp@ 1 3 pick read-file throw 1880 | ( file c u ) 1881 | 1 = if 1882 | nip 1883 | else 1884 | 2drop EOF 1885 | then 1886 | ; 1887 | 1888 | \ Read characters from 'file' to the buffer c-addr u1 1889 | \ until reaches '\n' or end of file, null character is 1890 | \ stored at last. 1891 | \ u2 is the number of characters written to the buffer. 1892 | \ flag=true if it reads '\n'. e is error code. 1893 | : read-line ( c-addr u1 file -- u2 e ) 1894 | over 1- 0 do 1895 | 2 pick i + 1 2 pick read-file 1896 | dup 0< if false leave then 1897 | drop 1898 | ( c-addr u1 file u2 ) 1899 | 0= if i success false leave then \ EOF 1900 | 2 pick i + c@ '\n' = if 1901 | i 1+ success true leave 1902 | then 1903 | loop 1904 | ( c-addr u1 file u2 e flag ) 1905 | >r >r 1906 | 3 pick over + 0 swap c! \ fill '\0' 1907 | >r 3drop r> r> r> swap 1908 | ; 1909 | 1910 | \ Temporary runtime stdin and stdout using 'key' and 'type' 1911 | 1912 | create stdin_ file% %allot drop 1913 | R/O stdin_ file>fam c! 1914 | ' not-implemented stdin_ file>write ! 1915 | here BUFSIZE allot stdin_ file>rbuf ! 1916 | stdin_ dup file>rbuf @ swap file>rbeg ! 1917 | stdin_ dup file>rbuf @ swap file>rend ! 1918 | s" " stdin_ file>name FILENAME-MAX strncpy 1919 | 1920 | \ Read just 1 byte from stdin to c-buffer 1921 | :noname ( c-addr u obj -- n ) 1922 | drop 1923 | 1 < if 1924 | drop 0 1925 | else 1926 | key-old swap c! 1927 | 1 1928 | then 1929 | ; stdin_ file>read ! 1930 | 1931 | ( === Input Stream === ) 1932 | 1933 | \ input stream stack 1934 | struct 1935 | cell% field input>next 1936 | cell% field input>file 1937 | cell% field input>lineno 1938 | end-struct inputstream% 1939 | 1940 | variable inputstreams 1941 | 0 inputstreams ! 1942 | 1943 | : push-inputstream ( file -- ) 1944 | inputstream% %allot \ addr 1945 | tuck input>file ! 1946 | 0 over input>lineno ! 1947 | inputstreams @ over input>next ! 1948 | inputstreams ! 1949 | ; 1950 | 1951 | : pop-inputstream ( -- file ) 1952 | inputstreams @ dup 1953 | input>next @ inputstreams ! 1954 | input>file @ 1955 | ; 1956 | 1957 | stdin_ push-inputstream 1958 | 1959 | : sourcefilename ( -- c-addr ) 1960 | inputstreams @ input>file @ file>name 1961 | ; 1962 | 1963 | \ Replacing parser functions using input stream. 1964 | 1965 | variable source-buffer BUFSIZE allot 1966 | BUFSIZE constant source-buffer-size 1967 | variable source-buffer-pos 0 source-buffer-pos ! 1968 | variable source-buffer-end 0 source-buffer-end ! 1969 | 1970 | : increment-lineno ( -- ) 1 inputstreams @ input>lineno +! ; 1971 | 1972 | : source ( -- c-addr) source-buffer ; 1973 | : >in ( -- c-addr ) source-buffer-pos ; 1974 | 1975 | \ Throw UNEXPECTED-EOF-ERROR at EOF 1976 | :noname ( -- c ) 1977 | key dup EOF = if drop UNEXPECTED-EOF-ERROR throw then 1978 | ; &key! ! 1979 | 1980 | \ New version of single line comment 1981 | : \ begin key! '\n' = until ; immediate 1982 | 1983 | \ New version of 'key'. 1984 | : new-key ( -- c ) 1985 | source-buffer-pos @ source-buffer-end @ = if 1986 | \ the buffer is empty 1987 | 0 source-buffer-pos ! 1988 | 0 source-buffer-end ! 1989 | increment-lineno 1990 | 1991 | source-buffer BUFSIZE inputstreams @ input>file @ read-line throw 1992 | if 1993 | \ reached end of line 1994 | dup 0= if 1995 | drop '\n' exit \ empty line 1996 | then 1997 | source-buffer-end +! 1998 | else 1999 | \ reached EOF 2000 | dup 0= if 2001 | drop EOF exit 2002 | then 2003 | source-buffer-end +! 2004 | then 2005 | then 2006 | source-buffer source-buffer-pos @ + c@ 2007 | 1 source-buffer-pos +! 2008 | ; 2009 | 2010 | \ Read a word from input stream, return address of the string 2011 | \ and error-code. 2012 | :noname ( -- c-addr e ) 2013 | \ skip leading spaces 2014 | 0 2015 | begin 2016 | drop 2017 | key 2018 | dup bl <> over '\n' <> and 2019 | until 2020 | dup EOF = if 2021 | drop word-buffer UNEXPECTED-EOF-ERROR 2022 | exit 2023 | then 2024 | word-buffer tuck c! 2025 | 1+ 2026 | begin 2027 | \ ( p ) 2028 | key 2029 | dup bl = over '\n' = or over EOF = or if 2030 | drop 2031 | 0 swap c! \ store \0 2032 | word-buffer success 2033 | exit 2034 | then 2035 | over c! 2036 | 1+ 2037 | again 2038 | ; &word ! 2039 | 2040 | :noname 2041 | word throw 2042 | ; &word! ! 2043 | 2044 | : : ( "name -- ) 2045 | align 2046 | here latest , &latest ! 2047 | word throw dup strlen 2048 | smudge-bit or c, 2049 | strcpy, 2050 | align 2051 | docol , 2052 | ] 2053 | ; 2054 | 2055 | ( === 4th Stage Interpreter === ) 2056 | 2057 | -56 s" Bye" def-error QUIT 2058 | 2059 | : interpret-inner 2060 | begin 2061 | word \ read name from input 2062 | 2063 | \ EOF at this point is not an error 2064 | UNEXPECTED-EOF-ERROR = if QUIT throw then 2065 | 2066 | dup word-buffer strcpy \ save input 2067 | dup find \ lookup dictionary 2068 | ?dup if 2069 | \ Found the word 2070 | nip 2071 | state @ if 2072 | \ compile mode 2073 | dup cell+ c@ immediate-bit and if 2074 | \ execute immediate word 2075 | >cfa execute 2076 | else 2077 | \ compile the word 2078 | >cfa , 2079 | then 2080 | else 2081 | \ immediate mode 2082 | >cfa execute 2083 | then 2084 | else 2085 | >number unless 2086 | UNDEFINED-WORD-ERROR throw 2087 | then 2088 | \ Not found 2089 | state @ if 2090 | \ compile mode 2091 | [compile] literal 2092 | then 2093 | then 2094 | again 2095 | ; 2096 | 2097 | : interpret-outer 2098 | begin 2099 | ['] interpret-inner catch 2100 | ?dup if 2101 | \ lookup error code 2102 | dup QUIT = if throw then 2103 | 2104 | decimal 2105 | '[' emit inputstreams @ input>file @ file>name type ':' emit 2106 | inputstreams @ input>lineno @ 0 u.r ." ] " 2107 | 2108 | error-list @ 2109 | begin ?dup while 2110 | \ ( error-code error-entry ) 2111 | dup error>code 2112 | 2 pick = if 2113 | error>message type 2114 | ." : " 2115 | word-buffer type cr 2116 | 1 quit 2117 | then 2118 | error>next 2119 | repeat 2120 | ." Unknown error code: " 2121 | word-buffer type 2122 | ." (" 0 .r ." )" cr 2123 | 1 quit 2124 | then 2125 | again 2126 | ; 2127 | 2128 | :noname 2129 | rp0 rp! \ drop 3rd stage 2130 | ['] new-key &key ! 2131 | 2132 | ['] interpret-outer catch bye 2133 | ; execute 2134 | 2135 | ( === [if]..[else]..[then] === ) 2136 | 2137 | : [if] ( f -- ) 2138 | unless 2139 | \ skip inputs until corresponding [else] or [then] 2140 | 0 \ depth 2141 | begin 2142 | word throw 2143 | dup s" [if]" streq if 2144 | drop 1+ 2145 | else dup s" [else]" streq if 2146 | drop 2147 | dup 0= if drop exit then 2148 | else s" [then]" streq if 2149 | dup 0= if drop exit then 2150 | 1- 2151 | then then then 2152 | again 2153 | then 2154 | ; immediate 2155 | 2156 | : [unless] ( f -- ) 2157 | not 2158 | [compile] [if] 2159 | ; immediate 2160 | 2161 | : [else] 2162 | \ If the condition is false, [else] is skipped by [if]. 2163 | \ So when the execution reaches [else] it means that 2164 | \ the condition was true. 2165 | 2166 | \ skip inputs until corresponding [then] 2167 | 0 \ depth 2168 | begin 2169 | word throw 2170 | dup s" [if]" streq if 2171 | drop 1+ 2172 | else s" [then]" streq if 2173 | dup 0= if drop exit then 2174 | 1- 2175 | then then 2176 | again 2177 | ; immediate 2178 | 2179 | : [then] ; immediate \ do nothing 2180 | 2181 | ( === Dictionary === ) 2182 | 2183 | \ print the name of the word 2184 | : id. ( nt -- ) 2185 | cell+ dup c@ length-mask and 2186 | begin dup 0> while 2187 | swap 1+ dup c@ emit swap 1- 2188 | repeat 2189 | 2drop 2190 | ; 2191 | 2192 | \ print all visible words 2193 | : words 2194 | latest 2195 | begin ?dup while 2196 | dup cell+ c@ smudge-bit and unless 2197 | dup id. space 2198 | then 2199 | @ 2200 | repeat 2201 | cr 2202 | ; 2203 | 2204 | : name>link ( nt -- nt ) @ ; 2205 | : name>string ( nt -- c-addr ) cell+ 1+ ; 2206 | 2207 | ( === Command-line Arguments === ) 2208 | 2209 | variable argc 2210 | variable argv 2211 | v argc ! argv ! 2212 | 2213 | : arg ( u -- c-addr ) 2214 | dup argc @ < if 2215 | cells argv @ + @ 2216 | else 2217 | drop 0 2218 | then 2219 | ; 2220 | 2221 | \ Remove 1 arg, update argv and argc 2222 | : shift-args ( -- ) 2223 | argc @ 1 = if exit then 2224 | argc @ 1 do 2225 | i 1+ arg \ argv[i+1] 2226 | i cells argv @ + \ &argv[i] 2227 | ! \ copy argv[i+1] to argv[i] 2228 | loop 2229 | 1 argc -! 2230 | ; 2231 | 2232 | \ Take 1 arg and shift arguments 2233 | : next-arg ( -- c-addr ) 2234 | argc @ 1 = if 0 exit then 2235 | 1 arg 2236 | shift-args 2237 | ; 2238 | 2239 | ( === Version and Copyright === ) 2240 | 2241 | \ The version of planckforth (not runtime) 2242 | : version s" 0.0.1" ; 2243 | 2244 | : strchr ( c-addr2 c -- c-addr2 ) 2245 | begin over c@ while 2246 | over c@ over = if drop exit then 2247 | swap 1+ swap 2248 | repeat 2249 | 2drop 0 2250 | ; 2251 | 2252 | \ The version string is colon separated 2253 | \ : 2254 | 2255 | create runtime-info runtime-info_ strcpy, 2256 | 2257 | runtime-info constant runtime 2258 | runtime-info ':' strchr 0 over c! 1+ constant copyright-text 2259 | 2260 | : copyright 2261 | copyright-text type cr 2262 | ; 2263 | 2264 | \ The version of PlanckForth (not runtime) 2265 | : version s" 0.0.1" ; 2266 | 2267 | ( === Environment Dependent Code === ) 2268 | 2269 | runtime s" i386-linux-handwritten" streq [if] 2270 | 2271 | %000 constant eax immediate 2272 | %001 constant ecx immediate 2273 | %010 constant edx immediate 2274 | %011 constant ebx immediate 2275 | %100 constant esp immediate 2276 | %101 constant ebp immediate 2277 | %110 constant esi immediate 2278 | %111 constant edi immediate 2279 | 2280 | : mod-reg-r/m ( mod reg r/m -- u ) 2281 | 0 2282 | swap 0x7 and or 2283 | swap 0x7 and 8 * or 2284 | swap 0x3 and 64 * or 2285 | ; 2286 | 2287 | : scale-index-byte ( scale index byte -- u ) 2288 | 0 2289 | swap 0x7 and or 2290 | swap 0x7 and 8 * or 2291 | swap 0x3 and 64 * or 2292 | ; 2293 | 2294 | \ compile 'pop reg' and 'push reg' 2295 | : pop ( reg -- ) 0x58 + c, ; immediate 2296 | : push ( reg -- ) 0x50 + c, ; immediate 2297 | 2298 | \ lodsl; jmp *(%eax); 2299 | : next ( -- ) 0xad c, 0xff c, 0x20 c, ; immediate 2300 | : int80 ( -- ) 0xcd c, 0x80 c, ; immediate 2301 | 2302 | \ movl disp(reg1), reg2 2303 | : movmr ( disp reg1 reg2 -- ) 2304 | 0x8b c, \ opcode 2305 | swap dup %100 = if \ if reg1=esp 2306 | \ ( disp reg2 reg1 ) 2307 | %01 -rot mod-reg-r/m c, 2308 | %00 %100 %100 scale-index-byte c, 2309 | else 2310 | \ ( disp reg2 reg1 ) 2311 | %01 -rot mod-reg-r/m c, 2312 | then 2313 | c, \ displacement 2314 | ; immediate 2315 | 2316 | \ overwrite code field by DFA 2317 | : ;asm 2318 | [compile] ; \ finish compilation 2319 | latest dup >dfa swap >cfa ! 2320 | ; immediate 2321 | 2322 | : syscall0 ( n -- e ) 2323 | eax pop 2324 | int80 2325 | eax push 2326 | next 2327 | ;asm 2328 | 2329 | : syscall1 ( arg1 n -- e ) 2330 | eax pop 2331 | ebx pop 2332 | int80 2333 | eax push 2334 | next 2335 | ;asm 2336 | 2337 | : syscall2 ( arg2 arg1 n -- e ) 2338 | eax pop 2339 | ebx pop 2340 | ecx pop 2341 | int80 2342 | eax push 2343 | next 2344 | ;asm 2345 | 2346 | : syscall3 ( arg3 arg2 arg1 n -- e ) 2347 | eax pop 2348 | ebx pop 2349 | ecx pop 2350 | edx pop 2351 | int80 2352 | eax push 2353 | next 2354 | ;asm 2355 | 2356 | : syscall4 ( arg4 arg3 arg2 arg1 n -- e ) 2357 | eax pop 2358 | ebx pop 2359 | ecx pop 2360 | edx pop 2361 | esi push \ save program counter ( arg4 esi ) 2362 | [ 4 ] esp esi movmr \ movl 4(%esp), %esi 2363 | int80 2364 | esi pop \ restore esi 2365 | ebx pop 2366 | eax push 2367 | next 2368 | ;asm 2369 | 2370 | : syscall5 ( arg5 arg4 arg3 arg2 arg1 n -- e ) 2371 | eax pop 2372 | ebx pop 2373 | ecx pop 2374 | edx pop 2375 | esi push \ save esi ( arg5 arg4 esi ) 2376 | [ 4 ] esp esi movmr 2377 | [ 8 ] esp edi movmr 2378 | int80 2379 | esi pop 2380 | ebx pop 2381 | ebx pop 2382 | eax push 2383 | next 2384 | ;asm 2385 | 2386 | : syscall6 ( arg6 arg5 arg4 arg3 arg2 arg1 n -- e ) 2387 | eax pop 2388 | ebx pop 2389 | ecx pop 2390 | edx pop 2391 | esi push 2392 | ebp push \ ( arg6 arg5 arg4 esi ebp ) 2393 | [ 8 ] esp esi movmr 2394 | [ 12 ] esp edi movmr 2395 | [ 16 ] esp ebp movmr 2396 | int80 2397 | ebp pop 2398 | esi pop 2399 | ebx pop 2400 | ebx pop 2401 | ebx pop 2402 | eax push 2403 | next 2404 | ;asm 2405 | 2406 | ( === Heap Memory === ) 2407 | 2408 | 192 constant SYS-MMAP2 2409 | 2410 | 0x0 constant PROT-NONE 2411 | 0x1 constant PROT-READ 2412 | 0x2 constant PROT-WRITE 2413 | 0x4 constant PROT-EXEC 2414 | 0x8 constant PROT-SEM 2415 | 2416 | 0x01 constant MAP-SHARED 2417 | 0x02 constant MAP-PRIVATE 2418 | 0x0f constant MAP-TYPE 2419 | 0x10 constant MAP-FIXED 2420 | 0x20 constant MAP-ANONYMOUS 2421 | 2422 | : mmap2 ( addr1 u -- addr2 e ) 2423 | >r >r \ ( R: u addr1 ) 2424 | 0 \ offset 2425 | -1 \ fd 2426 | MAP-ANONYMOUS MAP-PRIVATE or \ flags 2427 | PROT-READ PROT-WRITE or PROT-EXEC or \ prot 2428 | r> r> swap \ u addr1 2429 | SYS-MMAP2 2430 | syscall6 2431 | dup -1 = if 2432 | ALLOCATE-ERROR 2433 | else 2434 | success 2435 | then 2436 | ; 2437 | 2438 | \ Secure a large heap memory block and cut memories from the block. 2439 | \ The allocated memories are never released until the program exit. 2440 | 0x8000000 constant BLOCK-SIZE ( 128MB ) 2441 | variable block-addr 2442 | variable next-addr 2443 | variable remaining-size 2444 | 2445 | 0 BLOCK-SIZE mmap2 throw block-addr ! 2446 | block-addr @ next-addr ! 2447 | BLOCK-SIZE remaining-size ! 2448 | 2449 | \ Allocate u bytes of heap memory 2450 | \ The region must be zero cleared. 2451 | : (allocate) ( u -- addr ) 2452 | dup remaining-size @ <= if 2453 | ( u addr ) 2454 | next-addr @ 2455 | swap aligned dup next-addr +! remaining-size -! 2456 | else 2457 | drop -1 2458 | then 2459 | ; 2460 | 2461 | \ Bootstrapping version of free do nothing. 2462 | : (free) ( addr -- ) drop ; 2463 | 2464 | ( === File I/O === ) 2465 | 2466 | 3 constant SYS-READ 2467 | 4 constant SYS-WRITE 2468 | 5 constant SYS-OPEN 2469 | 6 constant SYS-CLOSE 2470 | 2471 | : (open) ( c-addr fam -- fd ) 2472 | %110100100 -rot swap SYS-OPEN syscall3 2473 | ; 2474 | 2475 | : (close) ( obj -- n ) 2476 | SYS-CLOSE syscall1 2477 | ; 2478 | 2479 | : (read) ( c-addr u fd -- n ) 2480 | >r swap r> SYS-READ syscall3 2481 | ; 2482 | 2483 | : (write) ( c-addr u1 fd -- n ) 2484 | >r swap r> \ ( u1 u1 c-addr fd ) 2485 | SYS-WRITE syscall3 \ ( u2 ) 2486 | ; 2487 | 2488 | [then] \ End of environment dependent code 2489 | 2490 | : defined? ( "name" -- f ) 2491 | word throw find 0 <> 2492 | ; 2493 | 2494 | : need-defined ( "name" -- ) 2495 | word throw dup find unless 2496 | ." Implementation of " type ." for " runtime type ." is missing." cr 2497 | ." Please implement it." cr 2498 | UNDEFINED-WORD-ERROR throw 2499 | then drop 2500 | ; 2501 | 2502 | ( === Heap Memory === ) 2503 | 2504 | need-defined (allocate) 2505 | need-defined (free) 2506 | 2507 | : allocate ( size -- addr e ) 2508 | (allocate) dup 0<> if success else ALLOCATE-ERROR then 2509 | ; 2510 | 2511 | : free ( addr -- ) 2512 | (free) 2513 | ; 2514 | 2515 | \ allocate heap memory 2516 | : %allocate ( align size -- addr e ) 2517 | over 1- + allocate ?dup unless 2518 | swap 1- tuck + swap invert and success 2519 | then 2520 | ; 2521 | 2522 | ( === open/close === ) 2523 | 2524 | need-defined (open) 2525 | need-defined (close) 2526 | need-defined (write) 2527 | need-defined (read) 2528 | 2529 | : open-file ( c-addr fam -- file e ) 2530 | 2dup (open) dup 0< if 2531 | ( c-addr fam fd ) 2532 | 3drop 0 OPEN-FILE-ERROR exit 2533 | then 2534 | file% %allocate throw 2535 | tuck file>fd ! 2536 | tuck file>fam ! 2537 | tuck file>name FILENAME-MAX strncpy 2538 | ['] (read) over file>read ! 2539 | ['] (write) over file>write ! 2540 | dup file>fam @ W/O <> if 2541 | BUFSIZE allocate throw over file>rbuf ! 2542 | dup file>rbuf @ over file>rbeg ! 2543 | dup file>rbuf @ over file>rend ! 2544 | then 2545 | dup file>fam @ R/O <> if 2546 | BUFSIZE allocate throw over file>wbuf ! 2547 | dup file>wbuf @ over file>wbeg ! 2548 | dup file>wbuf @ BUFSIZE + over file>wend ! 2549 | then 2550 | success 2551 | ; 2552 | 2553 | : close-file ( file -- e ) 2554 | dup file>fd @ swap 2555 | ( fd file ) 2556 | \ release heap objects 2557 | dup file>rbuf @ (free) 2558 | dup file>wbuf @ (free) 2559 | (free) 2560 | \ close file object 2561 | (close) 0= if success else CLOSE-FILE-ERROR then 2562 | ; 2563 | 2564 | ( === File Include === ) 2565 | 2566 | : loaded ( c-addr -- ) 2567 | R/O open-file throw 2568 | push-inputstream 2569 | ['] interpret-outer catch drop 2570 | pop-inputstream close-file throw 2571 | ; 2572 | 2573 | : load ( "name" -- ) 2574 | word throw loaded 2575 | ; 2576 | 2577 | struct 2578 | char% FILENAME-MAX * field included-list>path 2579 | cell% field included-list>next 2580 | end-struct included-list% 2581 | 2582 | variable included-list 2583 | 0 included-list ! 2584 | 2585 | : already-included? ( c-addr -- n ) 2586 | included-list @ 2587 | begin ?dup while 2588 | ( c-addr entry ) 2589 | dup included-list>path 2590 | ( c-addr entry path ) 2591 | 2 pick streq if 2drop true exit then 2592 | included-list>next @ 2593 | repeat 2594 | drop false 2595 | ; 2596 | 2597 | : push-included-list ( c-addr -- ) 2598 | included-list% %allocate throw 2599 | ( c-addr entry ) 2600 | tuck included-list>path FILENAME-MAX strncpy 2601 | included-list @ over included-list>next ! 2602 | included-list ! 2603 | ; 2604 | 2605 | : included ( c-addr -- ) 2606 | dup already-included? if drop exit then 2607 | dup push-included-list 2608 | loaded 2609 | ; 2610 | 2611 | : include ( "name" -- ) 2612 | word throw included 2613 | ; 2614 | 2615 | ( === Forget === ) 2616 | 2617 | \ Define a word "name". The word forgets itself and everything 2618 | \ defined after when executed. 2619 | : marker ( "name" -- ) 2620 | create 2621 | latest name>link , \ save latest 2622 | does> 2623 | @ &latest ! 2624 | ; 2625 | 2626 | ( === Private and Export === ) 2627 | 2628 | \ Words defined between private{ ... }private 2629 | \ are invisible outside of this scope. 2630 | \ You can export words using 'export'. 2631 | \ : name .... ; export 2632 | 2633 | : private{ 2634 | align 2635 | latest , 2636 | here cell- &latest ! 2637 | s" private-marker" dup strlen 2638 | c, strcpy, align 2639 | ; 2640 | 2641 | : }private 2642 | s" private-marker" find! name>link &latest ! 2643 | ; 2644 | 2645 | : export 2646 | \ Move latest to the bottom of the dictionary. 2647 | latest 2648 | begin dup name>link while 2649 | name>link 2650 | repeat 2651 | latest 2652 | ( last latest ) 2653 | dup name>link &latest ! 2654 | 0 over ! 2655 | swap ! 2656 | ; 2657 | 2658 | ( === Primitive Instructions === ) 2659 | 2660 | : insn:docol docol ; 2661 | : insn:exit ['] e ; 2662 | : insn:lit ['] lit ; 2663 | : insn:litstring ['] litstring ; 2664 | : insn:branch ['] branch ; 2665 | : insn:0branch ['] 0branch ; 2666 | 2667 | ( === Remove Unnecessary Words === ) 2668 | 2669 | \ compile: ( "name" -- ) 2670 | \ runtime: ( nt1 -- nt2 ) 2671 | : update-dictionary ( "name1" "name" ... -- ) 2672 | compile 0 2673 | begin 2674 | word throw 2675 | dup s" end-update-dictionary" streq if 2676 | drop 2677 | compile &latest 2678 | compile ! 2679 | exit 2680 | then 2681 | find ?dup if 2682 | [compile] literal 2683 | compile tuck 2684 | compile ! 2685 | else 2686 | UNDEFINED-WORD-ERROR throw 2687 | then 2688 | again 2689 | ; immediate 2690 | 2691 | \ rebuild dictionary 2692 | :noname 2693 | update-dictionary 2694 | insn:docol insn:exit insn:lit insn:litstring insn:branch insn:0branch 2695 | 2696 | words id. name>string name>link 2697 | load loaded include included source >in sourcefilename 2698 | next-arg shift-args arg argv argc version runtime copyright 2699 | 2700 | [if] [unless] [else] [then] defined? private{ }private export 2701 | open-file close-file write-file flush-file 2702 | read-file key-file read-line 2703 | R/W W/O R/O EOF 2704 | 2705 | abort ABORTED-ERROR 2706 | QUIT not-reachable NOT-REACHABLE 2707 | not-implemented NOT-IMPLEMENTED 2708 | WRITE-FILE-ERROR READ-FILE-ERROR OPEN-FILE-ERROR 2709 | FLUSH-FILE-ERROR CLOSE-FILE-ERROR 2710 | ALLOCATE-ERROR UNEXPECTED-EOF-ERROR FILE-IO-ERROR 2711 | STRING-OVERFLOW-ERROR UNDEFINED-WORD-ERROR 2712 | exception 2713 | 2714 | %allocate %allot char% cell% byte% ptr% int% i32% u32% i16% u16% 2715 | field struct end-struct 2716 | sp0 sp@ sp! dup ?dup drop swap over tuck pick nip rot -rot 2717 | 2rot -2rot 2tuck 2over 2nip 2swap 2dup 2drop 3dup 3drop depth 2718 | rp0 rp@ rp! r> >r r@ rdrop rpick rdepth 2719 | 2720 | allocate free allot memcpy strlen streq strneq strcpy strncpy 2721 | cell cell+ cell- cells char+ char- chars align aligned +! -! 2722 | 2723 | if else then unless begin until again while repeat 2724 | recurse case of rangeof endof endcase 2725 | do ?do loop +loop unloop leave i j k 2726 | 2727 | char [char] key emit spaces 2728 | .s . .r u. u.r dec. hex. type typen 2729 | ." s" bl '\n' cr space base decimal hex 2730 | print-int print-uint 2731 | catch throw success 2732 | : ; [ ] immediate create >body :noname does> 2733 | variable constant value to 2734 | ' ['] compile compile, [compile] literal state 2735 | + - * /mod / mod negate not and or xor invert within max min abs 2736 | < > <= >= = <> 0< 0> 0<= 0>= 0= 0<> 1+ 1- 2737 | u< u> u<= u>= lshift rshift arshift 2* 2/ 2738 | 2739 | true false 2740 | 2741 | ( \ 2742 | c@ c! c, @ ! , 2743 | word find >cfa >dfa marker 2744 | quit bye execute exit here latest 2745 | end-update-dictionary 2746 | ; execute 2747 | 2748 | 2749 | ( === End of bootstrap === ) 2750 | 2751 | :noname 2752 | argc @ 2 < if exit then 2753 | 1 arg s" --version" 10 strneq if 2754 | ." PlanckForth " version type cr bye 2755 | else 1 arg s" --runtime" 10 strneq if 2756 | runtime type cr bye 2757 | then then 2758 | ; execute 2759 | 2760 | include lib/core.fs 2761 | 2762 | :noname 2763 | rdrop 2764 | argc @ 1 > if 2765 | next-arg dup argv @ ! 2766 | included 2767 | else 2768 | ." Welcome to PlanckForth " version type 2769 | ." [" runtime type ." ]" cr 2770 | copyright 2771 | ." Type 'bye' to exit." cr 2772 | s" /dev/tty" included 2773 | then 2774 | ; execute 2775 | -------------------------------------------------------------------------------- /example/fib.fs: -------------------------------------------------------------------------------- 1 | : fib dup 2 < unless 1- dup recurse swap 1- recurse + then ; 2 | 20 fib . cr 3 | -------------------------------------------------------------------------------- /example/helloworld.fs: -------------------------------------------------------------------------------- 1 | kHtketkltkltkotk tkWtkotkrtkltkdtk!tk:k0-tk0k0-Q 2 | -------------------------------------------------------------------------------- /lib/array.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | ( === Variable Length Array === ) 5 | 6 | private{ 7 | 8 | defined? array-alloc-strategy [unless] 9 | 10 | \ Compute new capacity 11 | : array-alloc-strategy ( u1 -- u2 ) 12 | dup 0= if 4 else 2 * then 13 | ; 14 | 15 | [then] 16 | 17 | struct 18 | cell% field array>buf 19 | int% field array>size 20 | int% field array>capa 21 | end-struct array% 22 | 23 | \ Allocate array with capacity 24 | : allocate-array ( n capa -- arr ) 25 | array% %allocate throw 26 | ( n capa addr ) 27 | over cells allocate throw over array>buf ! 28 | tuck array>capa ! 29 | tuck array>size ! 30 | ; 31 | 32 | : make-array ( n -- arr ) 33 | dup 0>= check-argument 34 | \ compute capa 35 | dup 0= if 10 else dup then 36 | allocate-array 37 | ; export 38 | 39 | : release-array ( arr -- ) 40 | dup array>buf @ free 41 | free 42 | ; export 43 | 44 | : array-size ( arr -- n ) array>size @ ; export 45 | 46 | : check-index ( i arr -- ) 47 | over 0< if OUT-OF-RANGE throw then 48 | array-size >= if OUT-OF-RANGE throw then 49 | ; 50 | 51 | : array@ ( i arr -- w ) 52 | 2dup check-index 53 | array>buf @ swap cells + @ 54 | ; export 55 | 56 | : array! ( v i arr -- ) 57 | 2dup check-index 58 | array>buf @ swap cells + ! 59 | ; export 60 | 61 | : array-reallocate ( capa arr -- ) 62 | over cells allocate throw 63 | \ copy elements to new buffer 64 | over array>buf @ over 3 pick array>size @ cells memcpy 65 | over array>buf @ free 66 | over array>buf ! 67 | over over array>capa ! 68 | 2drop 69 | ; 70 | 71 | : array-resize ( n arr -- ) 72 | over 0>= check-argument 73 | 2dup array>capa @ < if 74 | \ If n is smaller than the capacity 75 | \ just change array>size 76 | array>size ! 77 | exit 78 | else 79 | 2dup array-reallocate 80 | array>size ! 81 | then 82 | ; export 83 | 84 | : array-push ( w arr -- ) 85 | dup array>size @ over array>capa @ >= if 86 | dup array>capa @ array-alloc-strategy 87 | ( w arr new-capa ) 88 | over array-reallocate 89 | then 90 | swap ( arr w ) 91 | over array>buf @ 2 pick array>size @ cells + ! 92 | array>size 1 swap +! 93 | ; export 94 | 95 | : array-pop ( arr -- w ) 96 | dup array-size 0> unless OUT-OF-RANGE throw then 97 | 1 over array>size -! 98 | dup array-size cells swap array>buf @ + @ 99 | ; export 100 | 101 | 102 | }private 103 | 104 | T{ -1 ' make-array catch -> -1 INVALID-ARGUMENT }T 105 | 106 | T{ 0 make-array constant A -> }T 107 | T{ A array-size -> 0 }T 108 | T{ 0 A ' array@ catch -> 0 A OUT-OF-RANGE }T 109 | T{ 1 0 A ' array! catch -> 1 0 A OUT-OF-RANGE }T 110 | T{ A ' array-pop catch -> A OUT-OF-RANGE }T 111 | 112 | T{ :noname 100 0 do i A array-push loop ; execute -> }T 113 | 114 | T{ A array-size -> 100 }T 115 | T{ 0 A array@ -> 0 }T 116 | T{ 5 A array@ -> 5 }T 117 | T{ 10 A array@ -> 10 }T 118 | T{ 50 A array@ -> 50 }T 119 | T{ 99 A array@ -> 99 }T 120 | 121 | T{ A array-pop -> 99 }T 122 | T{ A array-size -> 99 }T 123 | T{ A array-pop -> 98 }T 124 | T{ A array-size -> 98 }T 125 | 126 | T{ -1 A ' array-resize catch -> -1 A INVALID-ARGUMENT }T 127 | T{ 5 A array-resize -> }T 128 | T{ A array-size -> 5 }T 129 | T{ 100 A array-resize -> }T 130 | T{ A array-size -> 100 }T 131 | 132 | T{ 1 -1 A ' array! catch -> 1 -1 A OUT-OF-RANGE }T 133 | T{ 1 100 A ' array! catch -> 1 100 A OUT-OF-RANGE }T 134 | T{ -1 A ' array@ catch -> -1 A OUT-OF-RANGE }T 135 | T{ 100 A ' array@ catch -> 100 A OUT-OF-RANGE }T 136 | T{ 1 0 A array! -> }T 137 | T{ 0 A array@ -> 1 }T 138 | T{ 2 99 A array! -> }T 139 | T{ 99 A array@ -> 2 }T 140 | T{ A release-array -> }T 141 | -------------------------------------------------------------------------------- /lib/bitscan.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | ( === Bit-Scan operations === ) 5 | 6 | cell 16 > [if] 7 | ." Bit-Scan for integers longer than 128bits is not supported" 8 | not-supported 9 | [then] 10 | 11 | private{ 12 | 13 | create bsf-modulo-131-table 14 | -1 , 0 , 1 , 72 , 2 , 46 , 73 , 96 , 15 | 3 , 14 , 47 , 56 , 74 , 18 , 97 , 118 , 16 | 4 , 43 , 15 , 35 , 48 , 38 , 57 , 23 , 17 | 75 , 92 , 19 , 86 , 98 , 51 , 119 , 29 , 18 | 5 , -1 , 44 , 12 , 16 , 41 , 36 , 90 , 19 | 49 , 126 , 39 , 124 , 58 , 60 , 24 , 105 , 20 | 76 , 62 , 93 , 115 , 20 , 26 , 87 , 102 , 21 | 99 , 107 , 52 , 82 , 120 , 78 , 30 , 110 , 22 | 6 , 64 , -1 , 71 , 45 , 95 , 13 , 55 , 23 | 17 , 117 , 42 , 34 , 37 , 22 , 91 , 85 , 24 | 50 , 28 , 127 , 11 , 40 , 89 , 125 , 123 , 25 | 59 , 104 , 61 , 114 , 25 , 101 , 106 , 81 , 26 | 77 , 109 , 63 , 70 , 94 , 54 , 116 , 33 , 27 | 21 , 84 , 27 , 10 , 88 , 122 , 103 , 113 , 28 | 100 , 80 , 108 , 69 , 53 , 32 , 83 , 9 , 29 | 121 , 112 , 79 , 68 , 31 , 8 , 111 , 67 , 30 | 7 , 66 , 65 , 31 | 32 | \ Find the index of the least significant 1 bit 33 | \ If u == 0, returns -1 34 | : bitscan-forward ( u -- u ) 35 | dup negate and \ LS1B isolation 36 | 131 mod \ perfect hashing 37 | cells bsf-modulo-131-table + @ 38 | ; export 39 | 40 | 41 | create msb-table 42 | -1 , 0 , 1 , 1 , 2 , 2 , 2 , 2 , 3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 , 43 | 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 44 | 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 45 | 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 5 , 46 | 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 47 | 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 48 | 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 49 | 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 6 , 50 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 51 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 52 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 53 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 54 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 55 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 56 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 57 | 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 7 , 58 | 59 | \ Find the index of the most significant 1 bit 60 | \ If u == 0, returns -1 61 | : bitscan-reverse ( u -- u ) 62 | dup 0xff u< if cells msb-table + @ exit then 63 | 8 rshift recurse 8 + 64 | ; export 65 | 66 | }private 67 | 68 | T{ 0 bitscan-forward -> -1 }T 69 | T{ 1 bitscan-forward -> 0 }T 70 | T{ 2 bitscan-forward -> 1 }T 71 | T{ 3 bitscan-forward -> 0 }T 72 | T{ 4 bitscan-forward -> 2 }T 73 | T{ 5 bitscan-forward -> 0 }T 74 | T{ -1 bitscan-forward -> 0 }T 75 | 76 | T{ 0 bitscan-reverse -> -1 }T 77 | T{ 1 bitscan-reverse -> 0 }T 78 | T{ 2 bitscan-reverse -> 1 }T 79 | T{ 3 bitscan-reverse -> 1 }T 80 | T{ 4 bitscan-reverse -> 2 }T 81 | T{ -1 bitscan-reverse -> cell 8 * 1- }T 82 | -------------------------------------------------------------------------------- /lib/core.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ Ignore test codes. lib/tester.fs will redefine this when 5 | \ running tests. 6 | : T{ 7 | begin 8 | word throw 9 | s" }T" streq if exit then 10 | again 11 | ; 12 | 13 | s" Invalid argument" exception constant INVALID-ARGUMENT 14 | 15 | : check-argument ( f -- ) 16 | unless INVALID-ARGUMENT throw then 17 | ; 18 | 19 | ( === Builtin Exceptions === ) 20 | s" Index out of range" exception constant OUT-OF-RANGE export 21 | 22 | defined? roll [unless] 23 | : roll ( wn ... w0 n -- w[n-1] ... w0 wn ) 24 | dup 0<= if drop else swap >r 1- recurse r> swap then 25 | ; 26 | [then] 27 | 28 | private{ 29 | 30 | ( === Cons Cell === ) 31 | 32 | struct 33 | cell% field first 34 | cell% field second 35 | end-struct cons-cell% 36 | 37 | : cons ( a b -- cons ) 38 | cons-cell% %allocate throw 39 | tuck second ! 40 | tuck first ! 41 | ; export 42 | 43 | : car first @ ; export 44 | : cdr second @ ; export 45 | 46 | ( === Enum === ) 47 | 48 | \ 0 49 | \ enum A 50 | \ enum B 51 | \ drop 52 | 53 | \ 0 constant A 54 | \ 1 constant B 55 | 56 | : enum ( n "name" -- n ) 57 | dup constant 1+ 58 | ; export 59 | 60 | }private 61 | -------------------------------------------------------------------------------- /lib/string.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | ( === Heap Allocated String === ) 5 | 6 | private{ 7 | 8 | : make-string ( c-addr -- str ) 9 | dup 0<> check-argument 10 | dup strlen 1+ allocate throw 11 | tuck strcpy 12 | ; export 13 | 14 | : release-string ( str -- ) 15 | free 16 | ; export 17 | 18 | : concat-string ( str1 str2 -- newstr ) 19 | dup 0<> check-argument 20 | over 0<> check-argument 21 | over strlen over strlen 22 | ( str1 str2 n1 n2 ) 23 | over + 1+ allocate throw 24 | ( str1 str2 n1 ptr ) 25 | 3 pick over strcpy \ copy str1 to ptr 26 | ( str1 str2 n1 ptr) 27 | tuck + 2 pick swap strcpy \ copy str2 to ptr + n1 28 | swap drop swap drop 29 | ; export 30 | 31 | }private 32 | 33 | T{ s" AAAAA" make-string constant A -> }T 34 | T{ s" BBBBBBB" make-string constant B -> }T 35 | T{ s" " make-string constant C -> }T 36 | T{ A B concat-string constant D -> }T 37 | T{ A s" AAAAA" streq -> true }T 38 | T{ B s" BBBBBBB" streq -> true }T 39 | T{ C s" " streq -> true }T 40 | T{ D s" AAAAABBBBBBB" streq -> true }T 41 | T{ A strlen -> 5 }T 42 | T{ B strlen -> 7 }T 43 | T{ C strlen -> 0 }T 44 | T{ D strlen -> 12 }T 45 | T{ A release-string -> }T 46 | T{ B release-string -> }T 47 | T{ C release-string -> }T 48 | T{ D release-string -> }T 49 | -------------------------------------------------------------------------------- /lib/table.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | ( === Hash Table === ) 5 | 6 | include lib/bitscan.fs 7 | include lib/array.fs 8 | 9 | private{ 10 | 11 | s" Key not found" exception constant KEY-NOT-FOUND export 12 | 13 | 14 | create prime_numbers 15 | 5 , 11 , 17 , 37 , 67 , 131 , 257 , 521 , 1031 , 16 | 2053 , 4099 , 8209 , 16411 , 32771 , 65537 , 131101 , 17 | 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 18 | 0 , 0 , 0 , 19 | 20 | struct 21 | cell% field table>bucket 22 | cell% field table>hash ( hash function ) 23 | cell% field table>equal ( equal function for keys ) 24 | cell% field table>entries ( list of entries ) 25 | int% field table>size ( number of entries ) 26 | end-struct table% 27 | 28 | struct 29 | cell% field entry>key 30 | cell% field entry>value 31 | cell% field entry>sibling ( pointer to the next entry in bucket ) 32 | cell% field entry>next ( pointer to the next entry in entries ) 33 | int% field entry>hash ( the hash value ) 34 | end-struct entry% 35 | 36 | \ Number of elments in the table 37 | : table-size ( tbl -- n ) table>size @ ; export 38 | 39 | \ Make hashtable considering given size hint 40 | : make-table-with-hint ( hash equal n -- tbl ) 41 | bitscan-reverse cells prime_numbers + @ ( n to bucket size ) 42 | make-array ( allocate bucket ) 43 | 44 | ( hash equal bucket ) 45 | table% %allocate throw 46 | tuck table>bucket ! 47 | tuck table>equal ! 48 | tuck table>hash ! 49 | 0 over table>entries ! 50 | 0 over table>size ! 51 | ; 52 | 53 | 10 constant DEFAULT_TABLE_SIZE_HINT 54 | 55 | \ Make hashtable. It takes two functions. 56 | \ hash ( w -- n ) : compute hash value of w 57 | \ equal ( w1 w2 -- n ) : compute equality of w1 and w2 58 | : make-table ( hash equal -- tbl ) 59 | DEFAULT_TABLE_SIZE_HINT make-table-with-hint 60 | ; export 61 | 62 | : release-table ( tbl -- ) 63 | dup table>entries @ 64 | begin ?dup while 65 | dup entry>next @ 66 | swap 67 | free 68 | repeat 69 | dup table>bucket @ release-array 70 | free 71 | ; export 72 | 73 | : find-entry ( key tbl hash -- entry ) 74 | over table>bucket @ array-size mod ( key tbl idx ) 75 | over table>bucket @ array@ ( key tbl entry ) 76 | swap table>equal @ -rot ( equal key entry ) 77 | begin ?dup while 78 | dup entry>key @ 79 | 2 pick 4 pick execute if 80 | ( equal key entry ) 81 | nip nip exit 82 | then 83 | entry>next @ 84 | repeat 85 | 2drop 0 86 | ; 87 | 88 | \ Lookup table entry. KEY-NOT-FOUND exception is raised 89 | \ when there is no corresponding entry. 90 | : table@ ( key tbl -- val ) 91 | 2dup 92 | 2dup table>hash @ execute 93 | find-entry ?dup if 94 | entry>value @ nip nip 95 | else 96 | KEY-NOT-FOUND throw 97 | then 98 | ; export 99 | 100 | \ Returns true when the key is in the table 101 | : ?table-in ( key tbl -- n ) 102 | 2dup table>hash @ execute 103 | find-entry 0 <> 104 | ; export 105 | 106 | \ Store key-value pair to the table 107 | : table! ( val key tbl -- ) 108 | 2dup 109 | 2dup table>hash @ execute 110 | dup >r find-entry r> swap 111 | ( val key tbl hash entry ) 112 | ?dup if 113 | ( `tbl` already has an entry for `key` ) 114 | nip nip nip 115 | entry>value ! 116 | else 117 | swap >r 118 | ( val key hash , R:tbl ) 119 | entry% %allocate throw 120 | tuck entry>hash ! 121 | tuck entry>key ! 122 | tuck entry>value ! 123 | 0 over entry>sibling ! 124 | 0 over entry>next ! 125 | r> 126 | ( entry tbl ) 127 | \ Find corresponding bucket entry 128 | over entry>hash @ 129 | over table>bucket @ 130 | tuck array-size mod 131 | ( entry tbl bucket index ) 132 | 133 | \ Add new entry to the bucket 134 | 2dup swap array@ 135 | 4 pick entry>sibling ! 136 | 3 pick swap rot array! 137 | 138 | \ Add the entry to the list of entries 139 | ( entry tbl ) 140 | tuck table>entries @ 141 | over entry>next ! 142 | over table>entries ! 143 | 144 | \ Increment table>size 145 | table>size 1 swap +! 146 | then 147 | ; export 148 | 149 | \ Returns cons-list of keys 150 | : table-keys ( tbl -- list ) 151 | 0 swap table>entries @ 152 | begin ?dup while 153 | tuck entry>key @ swap cons swap 154 | entry>next @ 155 | repeat 156 | ; export 157 | 158 | \ Returns cons-list of values 159 | : table-values ( tbl -- list ) 160 | 0 swap table>entries @ 161 | begin ?dup while 162 | tuck entry>value @ swap cons swap 163 | entry>next @ 164 | repeat 165 | ; export 166 | 167 | ( === tables for major builtin types === ) 168 | : hash-next ( n1 n2 -- n3 ) 169 | + 6122117 * 1627577 + 170 | ; 171 | 172 | : hash-int ( n -- n ) 173 | 0 hash-next 174 | ; 175 | 176 | : make-int-table ( -- tbl ) 177 | ['] hash-int ['] = make-table 178 | ; export 179 | 180 | : hash-string ( s -- n ) 181 | 0 begin over c@ dup while 182 | hash-next 183 | swap 1+ swap 184 | repeat drop nip 185 | ; 186 | 187 | : make-string-table ( -- tbl ) 188 | ['] hash-string ['] streq make-table 189 | ; export 190 | 191 | }private 192 | 193 | T{ make-int-table constant A -> }T 194 | T{ A table-size -> 0 }T 195 | T{ 0 A ' table@ catch -> 0 A KEY-NOT-FOUND }T 196 | T{ 0 A ?table-in -> false }T 197 | T{ 1 0 A table! -> }T 198 | T{ 0 A ?table-in -> true }T 199 | T{ 0 A table@ -> 1 }T 200 | T{ A table-size -> 1 }T 201 | T{ 2 0 A table! -> }T 202 | T{ A table-size -> 1 }T 203 | T{ 3 1 A table! -> }T 204 | T{ A table-size -> 2 }T 205 | T{ 1 A table@ -> 3 }T 206 | T{ :noname 100 0 do i 1 + i A table! loop ; execute -> }T 207 | T{ 0 A table@ -> 1 }T 208 | T{ 99 A table@ -> 100 }T 209 | T{ A table-size -> 100 }T 210 | 211 | T{ A table-keys car -> 0 }T 212 | T{ A table-keys cdr car -> 1 }T 213 | T{ A table-keys cdr cdr car -> 2 }T 214 | T{ A table-values car -> 1 }T 215 | T{ A table-values cdr car -> 2 }T 216 | T{ A table-values cdr cdr car -> 3 }T 217 | T{ A release-table -> }T 218 | 219 | T{ make-string-table constant A -> }T 220 | T{ s" zero" make-string constant ZERO -> }T 221 | T{ s" one" make-string constant ONE -> }T 222 | T{ 0 ZERO A table! -> }T 223 | T{ 1 ONE A table! -> }T 224 | T{ ZERO A table@ -> 0 }T 225 | T{ ONE A table@ -> 1 }T 226 | T{ s" zero" A table@ -> 0 }T 227 | T{ s" one" A table@ -> 1 }T 228 | T{ A release-table -> }T 229 | T{ ZERO release-string -> }T 230 | T{ ONE release-string -> }T 231 | -------------------------------------------------------------------------------- /lib/tester.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | variable verbose 8 | \ true verbose ! 9 | false verbose ! 10 | 11 | : empty-stack sp0 sp! ; 12 | 13 | variable #ok 0 #ok ! 14 | variable #error 0 #error ! 15 | variable #skip 0 #skip ! 16 | 17 | : ESC [ 0x1b ] literal ; 18 | : red ESC emit ." [31m" ; 19 | : green ESC emit ." [32m" ; 20 | : yellow ESC emit ." [33m" ; 21 | : reset ESC emit ." [m" ; 22 | : error ( c-addr -- ) 23 | red type source type reset 24 | empty-stack 25 | 1 #error +! 26 | ; 27 | 28 | variable actual-depth 29 | create actual-results 20 cells allot 30 | 31 | 32 | : T{ ; 33 | : -> ( save depth and contents ) 34 | depth dup actual-depth ! 35 | ?dup if 36 | 0 do actual-results i cells + ! loop 37 | then 38 | ; 39 | 40 | : }T ( compare expected data and actual-results ) 41 | depth actual-depth @ <> if 42 | s" wrong number of results: " error exit 43 | then 44 | true >r 45 | depth ?dup if 46 | 0 do 47 | actual-results i cells + @ <> if 48 | s" incorrect result: " error 49 | r> drop false >r 50 | leave 51 | then 52 | loop 53 | then 54 | r> if 55 | 1 #ok +! 56 | then 57 | ; 58 | 59 | : testing 60 | source verbose @ if 61 | dup type 62 | else 63 | '.' emit 64 | then 65 | strlen >in ! \ skip this line 66 | ; 67 | 68 | : skip 69 | source verbose @ if 70 | dup type 71 | then 72 | strlen >in ! \ skip this line 73 | 1 #skip +! 74 | ; 75 | 76 | : report-and-exit 77 | decimal 78 | 79 | cr ." --------------------------------" 80 | cr ." Run " #ok @ #error @ + #skip @ + . ." tests" cr 81 | green ." ok:" #ok @ . 82 | red ." failed:" #error @ . 83 | yellow ." skipped:" #skip @ . 84 | reset 85 | cr ." --------------------------------" 86 | cr 87 | #error @ 0= if bye else abort then 88 | ; 89 | -------------------------------------------------------------------------------- /others/planck.c: -------------------------------------------------------------------------------- 1 | /* planck - 2 | * Copyright (C) 2021 nineties 3 | */ 4 | #ifndef INCLUDE_DEFS 5 | #define INCLUDE_DEFS 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | #define COPYRIGHT "Copyright (c) 2021 Koichi Nakamura " 17 | #define STRINGIFY(s) #s 18 | #define RUNTIME_NAME(c) STRINGIFY(c) 19 | 20 | #define VERSION RUNTIME_NAME(COMPILER) ":" COPYRIGHT 21 | 22 | typedef uintptr_t cell; 23 | typedef void (**cfa)(); 24 | 25 | #define CELL sizeof(cell) 26 | #define STACK_SIZE 1024 27 | #define RSTACK_SIZE 1024 28 | #define MEMORY_SIZE 0x20000 29 | 30 | typedef struct builtin { 31 | struct builtin *prev; 32 | char len; 33 | char name; 34 | char padding[CELL-2]; 35 | void (*fun)(); 36 | } builtin; 37 | 38 | static cell stack[STACK_SIZE]; 39 | static cell rstack[RSTACK_SIZE]; 40 | static cell *dsp = stack + STACK_SIZE; 41 | static cell *rsp = rstack + RSTACK_SIZE; 42 | 43 | static cell memory[MEMORY_SIZE]; 44 | static builtin *latest = 0; 45 | static cell *here = memory; 46 | static cell *np = NULL; 47 | static cfa ip = NULL; 48 | 49 | #define next() (*(ip = (cfa)(*np++)))() 50 | 51 | static void push(cell v) { *(--dsp) = v; } 52 | static cell pop(void) { return *dsp++; } 53 | static void rpush(cell v) { *(--rsp) = v; } 54 | static cell rpop(void) { return *rsp++; } 55 | 56 | static void docol(void) { 57 | rpush((cell) np); 58 | np = (cell*)ip + 1; 59 | next(); 60 | } 61 | 62 | static cfa find(char c) { 63 | for (builtin *it = latest; it; it = it->prev) 64 | if (it->len == 1 && it->name == c) 65 | return &it->fun; 66 | return 0; 67 | } 68 | 69 | static int saved_argc = 0; 70 | static char **saved_argv = 0; 71 | 72 | #define defcode(name, label) \ 73 | static void label() 74 | #include "planck.c" 75 | #undef defcode 76 | 77 | static void align() { 78 | here = (cell*)((((cell)here) + CELL - 1) & ~(CELL - 1)); 79 | } 80 | static void comma(cell v) { *here++ = v; } 81 | static void comma_byte(char c) { 82 | *(char*)here = c; 83 | here = (cell*)(((char*)here) + 1); 84 | } 85 | static void comma_string(char *s) { 86 | while (*s) comma_byte(*s++); 87 | comma_byte(0); 88 | } 89 | 90 | int main(int argc, char *argv[]) { 91 | saved_argc = argc; 92 | saved_argv = argv; 93 | 94 | #define defcode(name, label) \ 95 | comma((cell) latest); \ 96 | latest = (void*)here - CELL; \ 97 | comma_byte(strlen(name)); \ 98 | comma_string(name); \ 99 | align(); \ 100 | comma((cell) label); \ 101 | if (0) // skip function body 102 | 103 | #include "planck.c" 104 | 105 | cfa start = (cfa) here; 106 | *here++ = (cell) find('k'); 107 | *here++ = (cell) find('f'); 108 | *here++ = (cell) find('x'); 109 | *here++ = (cell) find('j'); 110 | *here++ = (cell) -4 * CELL; 111 | np = (cell*) start; 112 | next(); 113 | return 0; 114 | } 115 | #else 116 | defcode("Q", quit) { exit(pop()); } 117 | defcode("C", cell_) { push(CELL); next(); } 118 | defcode("h", here_) { push((cell)&here); next(); } 119 | defcode("l", latest_) { push((cell)&latest); next(); } 120 | defcode("i", docol_) { push((cell)docol); next(); } 121 | defcode("e", exit_) { np = (cell*)rpop(); next(); } 122 | defcode("@", fetch) { cell *p = (cell*)pop(); push(*p); next(); } 123 | defcode("!", store) { cell *p = (cell*)pop(); *p = pop(); next(); } 124 | defcode("?", cfetch) { char *p = (char*)pop(); push(*p); next(); } 125 | defcode("$", cstore) { char *p = (char*)pop(); *p = pop(); next(); } 126 | defcode("d", dfetch) { push((cell)dsp); next(); } 127 | defcode("D", dstore) { dsp = (cell*) pop(); next(); } 128 | defcode("r", rfetch) { push((cell)rsp); next(); } 129 | defcode("R", rstore) { rsp = (cell*) pop(); next(); } 130 | defcode("j", jump) { np += (int)*np/CELL; next(); } 131 | defcode("J", jump0) { np += (int)(pop()?1:*np/CELL); next(); } 132 | defcode("L", lit) { push(*np++); next(); } 133 | defcode("S", litstring) { 134 | int n = *np++; 135 | push((cell)np); 136 | np += n/CELL; 137 | next(); 138 | } 139 | defcode("k", key) { 140 | int c = getchar(); 141 | if (c <= 0) 142 | exit(0); 143 | push(c); 144 | next(); 145 | } 146 | defcode("t", type) { putchar(pop()); next(); } 147 | defcode("x", exec) { (*(ip = (cfa) pop()))(); } 148 | defcode("f", find_) { push((cell) find(pop())); next(); } 149 | defcode("v", argv_) { push((cell) saved_argv); push(saved_argc); next(); } 150 | defcode("V", impl) { push((cell) VERSION); next(); } 151 | defcode("/", divmod) { 152 | uintptr_t b = pop(); 153 | uintptr_t a = pop(); 154 | push(a%b); 155 | push(a/b); 156 | next(); 157 | } 158 | #define defbinary(name, label, op, ty) \ 159 | defcode(name, label) { \ 160 | ty b = (ty) pop(); \ 161 | *dsp = (cell)((ty) *dsp op b); \ 162 | next(); \ 163 | } 164 | defbinary("+", add, +, intptr_t) 165 | defbinary("-", sub, -, intptr_t) 166 | defbinary("*", mul, *, intptr_t) 167 | defbinary("&", and, &, uintptr_t) 168 | defbinary("|", or, |, uintptr_t) 169 | defbinary("^", xor, ^, uintptr_t) 170 | defbinary("<", lt, <, intptr_t) 171 | defbinary("u", ult, <, uintptr_t) 172 | defbinary("=", eq, ==, intptr_t) 173 | defbinary("(", shl, <<, uintptr_t) 174 | defbinary(")", shr, >>, uintptr_t) 175 | defbinary("%", sar, >>, intptr_t) 176 | 177 | /* File IO */ 178 | defcode("(open)", openfile) { 179 | int flags = pop(); 180 | char *name = (char*) pop(); 181 | int fd = open(name, flags, 0644); 182 | push(fd); 183 | next(); 184 | } 185 | defcode("(close)", closefile) { 186 | int fd = pop(); 187 | push(close(fd)); 188 | next(); 189 | } 190 | defcode("(read)", readfile) { 191 | int fd = pop(); 192 | int size = pop(); 193 | char *buf = (char*) pop(); 194 | push(read(fd, buf, size)); 195 | next(); 196 | } 197 | defcode("(write)", writefile) { 198 | int fd = pop(); 199 | int size = pop(); 200 | char *buf = (char*) pop(); 201 | push(write(fd, buf, size)); 202 | next(); 203 | } 204 | defcode("(allocate)", allocate) { 205 | int size = pop(); 206 | void *p = calloc(size, 1); 207 | push((cell) p); 208 | next(); 209 | } 210 | defcode("(free)", free_) { 211 | free((void*) pop()); 212 | next(); 213 | } 214 | 215 | #endif 216 | -------------------------------------------------------------------------------- /others/planck.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # planck - 3 | # Copyright (C) 2021 nineties 4 | # 5 | 6 | import os 7 | import sys 8 | import operator 9 | from ctypes import c_uint32 10 | import platform 11 | from struct import pack_into, unpack_from 12 | 13 | RUNTIME_NAME = "Python {}".format(platform.python_version()) 14 | COPYRIGHT = "Copyright (c) 2021 Koichi Nakamura " 15 | 16 | VERSION = "{}:{}".format(RUNTIME_NAME, COPYRIGHT) 17 | 18 | MEMORY_SIZE = 0x40000 19 | 20 | memory = bytearray(MEMORY_SIZE) 21 | CELL = 4 22 | 23 | STACK_SIZE = 0x400 24 | RSTACK_SIZE = 0x400 25 | 26 | HERE_CELL = 0 27 | LATEST_CELL = CELL 28 | 29 | sp = MEMORY_SIZE 30 | rp = MEMORY_SIZE - STACK_SIZE 31 | ip = 0 32 | np = 0 33 | 34 | ALIGN_MASK = ~(CELL - 1) 35 | def aligned(n): 36 | return (n + CELL - 1) & ALIGN_MASK 37 | 38 | def align(): 39 | write(HERE_CELL, aligned(read(HERE_CELL))) 40 | 41 | def readi(addr): 42 | return unpack_from(' 5 | 00000020: 0000 0000 0000 0000 e_shoff,e_flags 6 | 00000028: 3400 2000 0100 0000 e_ehsize,e_phentsize,e_phnum,e_shentsize 7 | 00000030: 0000 0000 0100 0000 e_shnum,e_shstrndx,p_type=PT_LOAD 8 | 00000038: 0000 0000 0080 0408 p_offset,p_vaddr=0x08048000 9 | 00000040: 0000 0000 0004 0000 p_paddr,p_filesz 10 | 00000048: 0000 2000 0700 0000 p_memsz(128KB),p_flags=PF_X|PF_W|PF_R 11 | 00000050: 0010 0000 0084 0408 p_align, 12 | 00000058: 3882 0408 0000 0000 , 13 | 00000060: c080 0408 f080 0408 key, find 14 | 00000068: fc80 0408 d880 0408 execute, jump 15 | 00000070: f0ff ffff be60 8004 -16, movl $interpreter, %esi 16 | 00000078: 08bd 0080 0608 8925 movl $0x08068000,%ebp; movl %esp,sp0; 17 | 00000080: 5c80 0408 adff 2000 next; 18 | 19 | 00000088: 0000 0000 0151 0000 Q: quit 20 | 00000090: 4482 0408 0000 0000 21 | 00000094: 8880 0408 0143 0000 C: cell 22 | 0000009c: 4c82 0408 0000 0000 23 | 000000a0: 9480 0408 0168 0000 h: &here 24 | 000000a8: 5182 0408 0000 0000 25 | 000000ac: a080 0408 016c 0000 l: &latest 26 | 000000b4: 5982 0408 0000 0000 27 | 000000b8: ac80 0408 016b 0000 k: key 28 | 000000c0: 6182 0408 0000 0000 29 | 000000c4: b880 0408 0174 0000 t: type 30 | 000000cc: 7b82 0408 0000 0000 31 | 000000d0: c480 0408 016a 0000 j: branch 32 | 000000d8: 9182 0408 0000 0000 33 | 000000dc: d080 0408 014a 0000 J: 0branch 34 | 000000e4: 9682 0408 0000 0000 35 | 000000e8: dc80 0408 0166 0000 f: find 36 | 000000f0: 9f82 0408 0000 0000 37 | 000000f4: e880 0408 0178 0000 x: execute 38 | 000000fc: bf82 0408 0000 0000 39 | 00000100: f480 0408 0140 0000 @: fetch 40 | 00000108: c282 0408 0000 0000 41 | 0000010c: 0081 0408 0121 0000 !: store 42 | 00000114: c982 0408 0000 0000 43 | 00000118: 0c81 0408 013f 0000 ?: cfetch 44 | 00000120: d082 0408 0000 0000 45 | 00000124: 1881 0408 0124 0000 $: cstore 46 | 0000012c: d882 0408 0000 0000 47 | 00000130: 2481 0408 0164 0000 d: dfetch 48 | 00000138: df82 0408 0000 0000 49 | 0000013c: 3081 0408 0144 0000 D: dstore 50 | 00000144: e382 0408 0000 0000 51 | 00000148: 3c81 0408 0172 0000 r: rfetch 52 | 00000150: e782 0408 0000 0000 53 | 00000154: 4881 0408 0152 0000 R: rstore 54 | 0000015c: eb82 0408 0000 0000 55 | 00000160: 5481 0408 0169 0000 i: docol 56 | 00000168: fd82 0408 0000 0000 57 | 0000016c: 6081 0408 0165 0000 e: exit 58 | 00000174: 0583 0408 0000 0000 59 | 00000178: 6c81 0408 014c 0000 L: lit 60 | 00000180: 0e83 0408 0000 0000 61 | 00000184: 7881 0408 0153 0000 S: litstring 62 | 0000018c: 1383 0408 0000 0000 63 | 00000190: 8481 0408 012b 0000 +: add 64 | 00000198: 1c83 0408 0000 0000 65 | 0000019c: 9081 0408 012d 0000 -: sub 66 | 000001a4: 2383 0408 0000 0000 67 | 000001a8: 9c81 0408 012a 0000 *: mul 68 | 000001b0: 2a83 0408 0000 0000 69 | 000001b4: a881 0408 012f 0000 /: divmod 70 | 000001bc: 3383 0408 0000 0000 71 | 000001c0: b481 0408 0126 0000 &: and 72 | 000001c8: 3e83 0408 0000 0000 73 | 000001cc: c081 0408 017c 0000 |: or 74 | 000001d4: 4583 0408 0000 0000 75 | 000001d8: cc81 0408 015e 0000 ^: xor 76 | 000001e0: 4c83 0408 0000 0000 77 | 000001e4: d881 0408 013c 0000 <: less 78 | 000001ec: 5383 0408 0000 0000 79 | 000001f0: e481 0408 0175 0000 u: uless (unsigned less) 80 | 000001f8: 6183 0408 0000 0000 81 | 000001fc: f081 0408 013d 0000 =: equal 82 | 00000204: 6f83 0408 0000 0000 83 | 00000208: fc81 0408 0128 0000 (: shl 84 | 00000210: 7d83 0408 0000 0000 85 | 00000214: 0882 0408 0129 0000 ): shr 86 | 0000021c: 8583 0408 0000 0000 87 | 00000220: 1482 0408 0125 0000 %: sar 88 | 00000228: 8d83 0408 0000 0000 89 | 0000022c: 2082 0408 0176 0000 v: argv 90 | 00000234: 9583 0408 0000 0000 91 | 00000238: 2c82 0408 0156 0000 V: version 92 | 00000240: a483 0408 0000 0000 93 | 94 | 00000244: 5bb8 0100 0000 cd80 (quit) popl %ebx; mov $SYS_EXIT,%eax; inx $0x80 95 | 96 | 0000024c: 6a04 adff 2000 0000 (cell) pushl $4; next; 97 | 98 | 00000251: 6854 8004 08ad ff20 (&here) pushl $here; next; 99 | 100 | 00000259: 6858 8004 08ad ff20 (&latest) pushl $latest; next; 101 | 102 | 00000261: 31c0 50ba 0100 0000 (key) xorl %eax,%eax; pushl %eax; movl $1,%edx; 103 | 00000269: 89e1 31db b803 0000 movl %esp,%ecx; xorl %ebx,%ebx (STDIN=0); 104 | 00000271: 00cd 8085 c076 ccad movl $SYS_READ,%eax; int $0x80; test %eax,%eax; 105 | 00000279: ff20 0000 0000 0000 jbe 0x08048244(-52); next; 106 | 107 | 0000027b: ba01 0000 0089 e189 (type) movl $1,%edx; movl %esp,%ecx; 108 | 00000283: d3b8 0400 0000 cd80 movl $1,%ebx (STDOUT=1);movl $SYS_WRITE,%eax; 109 | 0000028b: 83c4 04ad ff20 0000 int $0x80; addl $4,%esp; next; 110 | 111 | 00000291: 0336 adff 2000 0000 (branch) addl (%esi),%esi; next; 112 | 113 | 00000296: 5885 c074 f6ad adff (0branch) popl %eax; test %eax,%eax; 114 | 0000029e: 2000 0000 0000 0000 je 0x08048292(-10); lodsl; next; 115 | 116 | 0000029f: 8a24 24b0 018b 0d58 (find) movb (%esp),%ah;movb $1,%al; 117 | 000002a7: 8004 088b 5904 6639 movl latest,%ecx;<1>movl 4(%ecx),%ebx; 118 | 000002af: c374 048b 09eb f483 cmpw %ax,%bx;je 2f;movl (%ecx),%ecx 119 | 000002b7: c108 890c 24ad ff20 jmp 1b(-12);<2>addl $8,%ecx;movl %ecx,(%esp); next; 120 | 121 | 000002bf: 58ff 2000 0000 0000 (execute) popl %eax; jmp *(%eax) 122 | 123 | 000002c2: 588b 0050 adff 2000 (fetch) popl %eax; movl (%eax),%eax;push %eax; next; 124 | 125 | 000002c9: 585b 8918 adff 2000 (store) popl %eax; popl %ebx; movl %ebx,(%eax); next 126 | 127 | 000002d0: 580f be00 50ad ff20 (cfetch) popl %eax; movsbl (%eax),%eax; next; 128 | 129 | 000002d8: 585b 8818 adff 2000 (cstore) popl %eax; popl %ebx; movb %bl,(%eax); next; 130 | 131 | 000002df: 54ad ff20 0000 0000 (dfetch) movl %esp,%eax; pushl %eax; next; 132 | 133 | 000002e3: 5cad ff20 0000 0000 (dstore) popl %eax; movl %eax,%esp; next; 134 | 135 | 000002e7: 55ad ff20 0000 0000 (rfetch) pushl %ebp; next; 136 | 137 | 000002eb: 5dad ff20 0000 0000 (rstore) popl %ebp; next; 138 | 139 | 000002ef: 8d6d fc89 7500 83c0 rpush %esi; addl $4,%eax 140 | 000002f7: 0489 c6ad ff20 0000 movl %eax,%esi; next; 141 | 142 | 000002fd: 68ef 8204 08ad ff20 (docol) pushl $docol; next; 143 | 144 | 00000305: 8b75 008d 6d04 adff (exit) rpop %esi next; 145 | 0000030d: 2000 0000 0000 0000 146 | 147 | 0000030e: ad50 adff 2000 0000 (lit) lodsl; pushl %eax; next; 148 | 149 | 00000313: ad56 01c6 adff 2000 (litstring)lodsl; pushl %esi; addl %eax,%esi; next; 150 | 151 | 0000031c: 5801 0424 adff 2000 (add) popl %eax; addl %eax,(%esp); next; 152 | 153 | 00000323: 5829 0424 adff 2000 (sub) popl %eax; subl %eax,(%esp); next; 154 | 155 | 0000032a: 585b 0faf c350 adff (mul) popl %eax; popl %ebx; imul %ebx,%eax 156 | 00000332: 2000 0000 0000 0000 pushl %eax; next; 157 | 158 | 00000333: 31d2 5b58 f7fb 5250 (divmod) xorl %edx,%edx; popl %ebx; popl %eax 159 | 0000033b: adff 2000 0000 0000 idiv %ebx; pushl %edx; pushl %eax; next; 160 | 161 | 0000033e: 5821 0424 adff 2000 (and) popl %eax; andl %eax,(%esp); next; 162 | 163 | 00000345: 5809 0424 adff 2000 (or) popl %eax; orl %eax,(%esp); next; 164 | 165 | 0000034c: 5831 0424 adff 2000 (xor) popl %eax; andl %eax,(%esp); next; 166 | 167 | 00000353: 585b 39c3 0f9c c00f (less) popl %eax; popl %ebx; cmpl %eax,%ebx 168 | 0000035b: b6c0 50ad ff20 0000 setl %al; movzbl %al, %eax; pushl %eax; next; 169 | 170 | 00000361: 585b 39c3 0f92 c00f (uless) popl %eax; popl %ebx; cmpl %eax,%ebx 171 | 00000369: b6c0 50ad ff20 0000 setb %al; movzbl %al, %eax; pushl %eax; next; 172 | 173 | 0000036f: 585b 39c3 0f94 c00f (equal) popl %eax; popl %ebx; cmpl %eax,%ebx 174 | 00000377: b6c0 50ad ff20 0000 setl %al; movzbl %al, %eax; pushl %eax; next; 175 | 176 | 0000037d: 5958 d3e0 50ad ff20 (shl) popl %ecx; popl %eax; shll %cl,%eax;next; 177 | 178 | 00000385: 5958 d3e8 50ad ff20 (shr) popl %ecx; popl %eax; shrl %cl,%eax;next; 179 | 180 | 0000038d: 5958 d3f8 50ad ff20 (sar) popl %ecx; popl %eax; sarl %cl,%eax; next; 181 | 182 | 00000395: 8b05 5c80 0408 8d58 (argv) movl sp0,%eax; leal 4(%eax),%ebx 183 | 0000039d: 0453 ff30 adff 2000 pushl %ebx; pushl (%eax); next; 184 | 185 | 000003a4: 68b0 8304 08ad ff20 (version) pushl $version; next 186 | 000003ac: 0000 0000 0000 0000 padding 187 | 188 | 000003b0: 6933 3836 2d6c 696e i386-lin 189 | 000003b8: 7578 2d68 616e 6477 ux-handw 190 | 000003c0: 7269 7474 656e 3a43 ritten:C 191 | 000003c8: 6f70 7972 6967 6874 opyright 192 | 000003d0: 2028 6329 2032 3032 (c) 202 193 | 000003d8: 3120 4b6f 6963 6869 1 Koichi 194 | 000003e0: 204e 616b 616d 7572 Nakamur 195 | 000003e8: 6120 3c6b 6f69 6368 a 198 | -------------------------------------------------------------------------------- /runtests.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | ." Running PlanckForth test programs" cr 8 | 9 | include lib/tester.fs 10 | 11 | include test/core.fs 12 | include test/utilities.fs 13 | include test/coreexttest.fs 14 | include test/fileio.fs 15 | 16 | include test/export.fs 17 | include lib/string.fs 18 | include lib/array.fs 19 | include lib/bitscan.fs 20 | include lib/table.fs 21 | 22 | report-and-exit 23 | -------------------------------------------------------------------------------- /test/core.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | testing core words 8 | hex 9 | 10 | \ ------------------------------------------------------------------------ 11 | testing basic assumptions 12 | 13 | T{ -> }T \ start with clean slate 14 | ( test if any bits are set; answer in base 1 ) 15 | T{ : bitsset? if 0 0 else 0 then ; -> }T 16 | T{ 0 bitsset? -> 0 }T ( zero is all bits clear ) 17 | T{ 1 bitsset? -> 0 0 }T ( other number have at least one bit ) 18 | T{ -1 bitsset? -> 0 0 }T 19 | 20 | \ ------------------------------------------------------------------------ 21 | testing booleans: invert and or xor 22 | 23 | T{ 0 0 and -> 0 }T 24 | T{ 0 1 and -> 0 }T 25 | T{ 1 0 and -> 0 }T 26 | T{ 1 1 and -> 1 }T 27 | 28 | T{ 0 invert 1 and -> 1 }T 29 | T{ 1 invert 1 and -> 0 }T 30 | 31 | 0 constant 0s 32 | 0 invert constant 1s 33 | 34 | T{ 0s invert -> 1s }T 35 | T{ 1s invert -> 0s }T 36 | 37 | T{ 0s 0s and -> 0s }T 38 | T{ 0s 1s and -> 0s }T 39 | T{ 1s 0s and -> 0s }T 40 | T{ 1s 1s and -> 1s }T 41 | 42 | T{ 0s 0s or -> 0s }T 43 | T{ 0s 1s or -> 1s }T 44 | T{ 1s 0s or -> 1s }T 45 | T{ 1s 1s or -> 1s }T 46 | 47 | T{ 0s 0s xor -> 0s }T 48 | T{ 0s 1s xor -> 1s }T 49 | T{ 1s 0s xor -> 1s }T 50 | T{ 1s 1s xor -> 0s }T 51 | 52 | \ ------------------------------------------------------------------------ 53 | testing 2* 2/ lshift rshift 54 | 55 | ( we trust 1s, invert, and bitsset?; we will confirm rshift later ) 56 | 1s 1 rshift invert constant msb 57 | T{ msb bitsset? -> 0 0 }T 58 | 59 | T{ 0s 2* -> 0s }T 60 | T{ 1 2* -> 2 }T 61 | T{ 4000 2* -> 8000 }T 62 | T{ 1s 2* 1 xor -> 1s }T 63 | T{ msb 2* -> 0s }T 64 | 65 | T{ 0s 2/ -> 0s }T 66 | T{ 1 2/ -> 0 }T 67 | T{ 4000 2/ -> 2000 }T 68 | T{ 1s 2/ -> 1s }T \ msb propogated 69 | T{ 1s 1 xor 2/ -> 1s }T 70 | T{ msb 2/ msb and -> msb }T 71 | 72 | T{ 1 0 lshift -> 1 }T 73 | T{ 1 1 lshift -> 2 }T 74 | T{ 1 2 lshift -> 4 }T 75 | T{ 1 f lshift -> 8000 }T \ biggest guaranteed shift 76 | T{ 1s 1 lshift 1 xor -> 1s }T 77 | T{ msb 1 lshift -> 0 }T 78 | 79 | T{ 1 0 rshift -> 1 }T 80 | T{ 1 1 rshift -> 0 }T 81 | T{ 2 1 rshift -> 1 }T 82 | T{ 4 2 rshift -> 1 }T 83 | T{ 8000 f rshift -> 1 }T \ biggest 84 | T{ msb 1 rshift msb and -> 0 }T \ rshift zero fills msbs 85 | T{ msb 1 rshift 2* -> msb }T 86 | 87 | \ ------------------------------------------------------------------------ 88 | testing comparisons: 0= = 0< < > u< min max 89 | 0 invert constant max-uint 90 | 0 invert 1 rshift constant max-int 91 | 0 invert 1 rshift invert constant min-int 92 | 0 invert 1 rshift constant mid-uint 93 | 0 invert 1 rshift invert constant mid-uint+1 94 | 95 | 0 constant 96 | 1 constant 97 | 98 | T{ 0 0= -> }T 99 | T{ 1 0= -> }T 100 | T{ 2 0= -> }T 101 | T{ -1 0= -> }T 102 | T{ max-uint 0= -> }T 103 | T{ min-int 0= -> }T 104 | T{ max-int 0= -> }T 105 | 106 | T{ 0 0 = -> }T 107 | T{ 1 1 = -> }T 108 | T{ -1 -1 = -> }T 109 | T{ 1 0 = -> }T 110 | T{ -1 0 = -> }T 111 | T{ 0 1 = -> }T 112 | T{ 0 -1 = -> }T 113 | 114 | T{ 0 0< -> }T 115 | T{ -1 0< -> }T 116 | T{ min-int 0< -> }T 117 | T{ 1 0< -> }T 118 | T{ max-int 0< -> }T 119 | 120 | T{ 0 1 < -> }T 121 | T{ 1 2 < -> }T 122 | T{ -1 0 < -> }T 123 | T{ -1 1 < -> }T 124 | T{ min-int 0 < -> }T 125 | T{ min-int max-int < -> }T 126 | T{ 0 max-int < -> }T 127 | T{ 0 0 < -> }T 128 | T{ 1 1 < -> }T 129 | T{ 1 0 < -> }T 130 | T{ 2 1 < -> }T 131 | T{ 0 -1 < -> }T 132 | T{ 1 -1 < -> }T 133 | T{ 0 min-int < -> }T 134 | T{ max-int min-int < -> }T 135 | T{ max-int 0 < -> }T 136 | 137 | T{ 0 1 > -> }T 138 | T{ 1 2 > -> }T 139 | T{ -1 0 > -> }T 140 | T{ -1 1 > -> }T 141 | T{ min-int 0 > -> }T 142 | T{ min-int max-int > -> }T 143 | T{ 0 max-int > -> }T 144 | T{ 0 0 > -> }T 145 | T{ 1 1 > -> }T 146 | T{ 1 0 > -> }T 147 | T{ 2 1 > -> }T 148 | T{ 0 -1 > -> }T 149 | T{ 1 -1 > -> }T 150 | T{ 0 min-int > -> }T 151 | T{ max-int min-int > -> }T 152 | T{ max-int 0 > -> }T 153 | 154 | T{ 0 1 u< -> }T 155 | T{ 1 2 u< -> }T 156 | T{ 0 mid-uint u< -> }T 157 | T{ 0 max-uint u< -> }T 158 | T{ mid-uint max-uint u< -> }T 159 | T{ 0 0 u< -> }T 160 | T{ 1 1 u< -> }T 161 | T{ 1 0 u< -> }T 162 | T{ 2 1 u< -> }T 163 | T{ mid-uint 0 u< -> }T 164 | T{ max-uint 0 u< -> }T 165 | T{ max-uint mid-uint u< -> }T 166 | 167 | T{ 0 1 min -> 0 }T 168 | T{ 1 2 min -> 1 }T 169 | T{ -1 0 min -> -1 }T 170 | T{ -1 1 min -> -1 }T 171 | T{ min-int 0 min -> min-int }T 172 | T{ min-int max-int min -> min-int }T 173 | T{ 0 max-int min -> 0 }T 174 | T{ 0 0 min -> 0 }T 175 | T{ 1 1 min -> 1 }T 176 | T{ 1 0 min -> 0 }T 177 | T{ 2 1 min -> 1 }T 178 | T{ 0 -1 min -> -1 }T 179 | T{ 1 -1 min -> -1 }T 180 | T{ 0 min-int min -> min-int }T 181 | T{ max-int min-int min -> min-int }T 182 | T{ max-int 0 min -> 0 }T 183 | 184 | T{ 0 1 max -> 1 }T 185 | T{ 1 2 max -> 2 }T 186 | T{ -1 0 max -> 0 }T 187 | T{ -1 1 max -> 1 }T 188 | T{ min-int 0 max -> 0 }T 189 | T{ min-int max-int max -> max-int }T 190 | T{ 0 max-int max -> max-int }T 191 | T{ 0 0 max -> 0 }T 192 | T{ 1 1 max -> 1 }T 193 | T{ 1 0 max -> 1 }T 194 | T{ 2 1 max -> 2 }T 195 | T{ 0 -1 max -> 0 }T 196 | T{ 1 -1 max -> 1 }T 197 | T{ 0 min-int max -> 0 }T 198 | T{ max-int min-int max -> max-int }T 199 | T{ max-int 0 max -> max-int }T 200 | 201 | \ ------------------------------------------------------------------------ 202 | testing stack ops: 2drop 2dup 2over 2swap ?dup depth drop dup over rot swap 203 | 204 | T{ 1 2 2drop -> }T 205 | T{ 1 2 2dup -> 1 2 1 2 }T 206 | T{ 1 2 3 4 2over -> 1 2 3 4 1 2 }T 207 | T{ 1 2 3 4 2swap -> 3 4 1 2 }T 208 | T{ 0 ?dup -> 0 }T 209 | T{ 1 ?dup -> 1 1 }T 210 | T{ -1 ?dup -> -1 -1 }T 211 | T{ depth -> 0 }T 212 | T{ 0 depth -> 0 1 }T 213 | T{ 0 1 depth -> 0 1 2 }T 214 | T{ 0 drop -> }T 215 | T{ 1 2 drop -> 1 }T 216 | T{ 1 dup -> 1 1 }T 217 | T{ 1 2 over -> 1 2 1 }T 218 | T{ 1 2 3 rot -> 2 3 1 }T 219 | T{ 1 2 swap -> 2 1 }T 220 | 221 | \ ------------------------------------------------------------------------ 222 | testing >r r> r@ 223 | 224 | T{ : gr1 >r r> ; -> }T 225 | T{ : gr2 >r r@ r> drop ; -> }T 226 | T{ 123 gr1 -> 123 }T 227 | T{ 123 gr2 -> 123 }T 228 | T{ 1s gr1 -> 1s }T ( return stack holds cells ) 229 | 230 | \ ------------------------------------------------------------------------ 231 | testing add/subtract: + - 1+ 1- abs negate 232 | 233 | T{ 0 5 + -> 5 }T 234 | T{ 5 0 + -> 5 }T 235 | T{ 0 -5 + -> -5 }T 236 | T{ -5 0 + -> -5 }T 237 | T{ 1 2 + -> 3 }T 238 | T{ 1 -2 + -> -1 }T 239 | T{ -1 2 + -> 1 }T 240 | T{ -1 -2 + -> -3 }T 241 | T{ -1 1 + -> 0 }T 242 | T{ mid-uint 1 + -> mid-uint+1 }T 243 | 244 | T{ 0 5 - -> -5 }T 245 | T{ 5 0 - -> 5 }T 246 | T{ 0 -5 - -> 5 }T 247 | T{ -5 0 - -> -5 }T 248 | T{ 1 2 - -> -1 }T 249 | T{ 1 -2 - -> 3 }T 250 | T{ -1 2 - -> -3 }T 251 | T{ -1 -2 - -> 1 }T 252 | T{ 0 1 - -> -1 }T 253 | T{ mid-uint+1 1 - -> mid-uint }T 254 | 255 | T{ 0 1+ -> 1 }T 256 | T{ -1 1+ -> 0 }T 257 | T{ 1 1+ -> 2 }T 258 | T{ mid-uint 1+ -> mid-uint+1 }T 259 | 260 | T{ 2 1- -> 1 }T 261 | T{ 1 1- -> 0 }T 262 | T{ 0 1- -> -1 }T 263 | T{ mid-uint+1 1- -> mid-uint }T 264 | 265 | T{ 0 negate -> 0 }T 266 | T{ 1 negate -> -1 }T 267 | T{ -1 negate -> 1 }T 268 | T{ 2 negate -> -2 }T 269 | T{ -2 negate -> 2 }T 270 | 271 | T{ 0 abs -> 0 }T 272 | T{ 1 abs -> 1 }T 273 | T{ -1 abs -> 1 }T 274 | T{ min-int abs -> mid-uint+1 }T 275 | 276 | \ ------------------------------------------------------------------------ 277 | testing multiply: s>d * m* um* 278 | 279 | skip T{ 0 s>d -> 0 0 }T 280 | skip T{ 1 s>d -> 1 0 }T 281 | skip T{ 2 s>d -> 2 0 }T 282 | skip T{ -1 s>d -> -1 -1 }T 283 | skip T{ -2 s>d -> -2 -1 }T 284 | skip T{ min-int s>d -> min-int -1 }T 285 | skip T{ max-int s>d -> max-int 0 }T 286 | 287 | skip T{ 0 0 m* -> 0 s>d }T 288 | skip T{ 0 1 m* -> 0 s>d }T 289 | skip T{ 1 0 m* -> 0 s>d }T 290 | skip T{ 1 2 m* -> 2 s>d }T 291 | skip T{ 2 1 m* -> 2 s>d }T 292 | skip T{ 3 3 m* -> 9 s>d }T 293 | skip T{ -3 3 m* -> -9 s>d }T 294 | skip T{ 3 -3 m* -> -9 s>d }T 295 | skip T{ -3 -3 m* -> 9 s>d }T 296 | skip T{ 0 min-int m* -> 0 s>d }T 297 | skip T{ 1 min-int m* -> min-int s>d }T 298 | skip T{ 2 min-int m* -> 0 1s }T 299 | skip T{ 0 max-int m* -> 0 s>d }T 300 | skip T{ 1 max-int m* -> max-int s>d }T 301 | skip T{ 2 max-int m* -> max-int 1 lshift 0 }T 302 | skip T{ min-int min-int m* -> 0 msb 1 rshift }T 303 | skip T{ max-int min-int m* -> msb msb 2/ }T 304 | skip T{ max-int max-int m* -> 1 msb 2/ invert }T 305 | 306 | T{ 0 0 * -> 0 }T \ test identities 307 | T{ 0 1 * -> 0 }T 308 | T{ 1 0 * -> 0 }T 309 | T{ 1 2 * -> 2 }T 310 | T{ 2 1 * -> 2 }T 311 | T{ 3 3 * -> 9 }T 312 | T{ -3 3 * -> -9 }T 313 | T{ 3 -3 * -> -9 }T 314 | T{ -3 -3 * -> 9 }T 315 | 316 | T{ mid-uint+1 1 rshift 2 * -> mid-uint+1 }T 317 | T{ mid-uint+1 2 rshift 4 * -> mid-uint+1 }T 318 | T{ mid-uint+1 1 rshift mid-uint+1 or 2 * -> mid-uint+1 }T 319 | 320 | skip T{ 0 0 um* -> 0 0 }T 321 | skip T{ 0 1 um* -> 0 0 }T 322 | skip T{ 1 0 um* -> 0 0 }T 323 | skip T{ 1 2 um* -> 2 0 }T 324 | skip T{ 2 1 um* -> 2 0 }T 325 | skip T{ 3 3 um* -> 9 0 }T 326 | 327 | skip T{ mid-uint+1 1 rshift 2 um* -> mid-uint+1 0 }T 328 | skip T{ mid-uint+1 2 um* -> 0 1 }T 329 | skip T{ mid-uint+1 4 um* -> 0 2 }T 330 | skip T{ 1s 2 um* -> 1s 1 lshift 1 }T 331 | skip T{ max-uint max-uint um* -> 1 1 invert }T 332 | 333 | \ ------------------------------------------------------------------------ 334 | \ testing divide: fm/mod sm/rem um/mod */ */mod / /mod mod 335 | 336 | skip T{ 0 s>d 1 fm/mod -> 0 0 }T 337 | skip T{ 1 s>d 1 fm/mod -> 0 1 }T 338 | skip T{ 2 s>d 1 fm/mod -> 0 2 }T 339 | skip T{ -1 s>d 1 fm/mod -> 0 -1 }T 340 | skip T{ -2 s>d 1 fm/mod -> 0 -2 }T 341 | skip T{ 0 s>d -1 fm/mod -> 0 0 }T 342 | skip T{ 1 s>d -1 fm/mod -> 0 -1 }T 343 | skip T{ 2 s>d -1 fm/mod -> 0 -2 }T 344 | skip T{ -1 s>d -1 fm/mod -> 0 1 }T 345 | skip T{ -2 s>d -1 fm/mod -> 0 2 }T 346 | skip T{ 2 s>d 2 fm/mod -> 0 1 }T 347 | skip T{ -1 s>d -1 fm/mod -> 0 1 }T 348 | skip T{ -2 s>d -2 fm/mod -> 0 1 }T 349 | skip T{ 7 s>d 3 fm/mod -> 1 2 }T 350 | skip T{ 7 s>d -3 fm/mod -> -2 -3 }T 351 | skip T{ -7 s>d 3 fm/mod -> 2 -3 }T 352 | skip T{ -7 s>d -3 fm/mod -> -1 2 }T 353 | skip T{ max-int s>d 1 fm/mod -> 0 max-int }T 354 | skip T{ min-int s>d 1 fm/mod -> 0 min-int }T 355 | skip T{ max-int s>d max-int fm/mod -> 0 1 }T 356 | skip T{ min-int s>d min-int fm/mod -> 0 1 }T 357 | skip T{ 1s 1 4 fm/mod -> 3 max-int }T 358 | skip T{ 1 min-int m* 1 fm/mod -> 0 min-int }T 359 | skip T{ 1 min-int m* min-int fm/mod -> 0 1 }T 360 | skip T{ 2 min-int m* 2 fm/mod -> 0 min-int }T 361 | skip T{ 2 min-int m* min-int fm/mod -> 0 2 }T 362 | skip T{ 1 max-int m* 1 fm/mod -> 0 max-int }T 363 | skip T{ 1 max-int m* max-int fm/mod -> 0 1 }T 364 | skip T{ 2 max-int m* 2 fm/mod -> 0 max-int }T 365 | skip T{ 2 max-int m* max-int fm/mod -> 0 2 }T 366 | skip T{ min-int min-int m* min-int fm/mod -> 0 min-int }T 367 | skip T{ min-int max-int m* min-int fm/mod -> 0 max-int }T 368 | skip T{ min-int max-int m* max-int fm/mod -> 0 min-int }T 369 | skip T{ max-int max-int m* max-int fm/mod -> 0 max-int }T 370 | 371 | skip T{ 0 s>d 1 sm/rem -> 0 0 }T 372 | skip T{ 1 s>d 1 sm/rem -> 0 1 }T 373 | skip T{ 2 s>d 1 sm/rem -> 0 2 }T 374 | skip T{ -1 s>d 1 sm/rem -> 0 -1 }T 375 | skip T{ -2 s>d 1 sm/rem -> 0 -2 }T 376 | skip T{ 0 s>d -1 sm/rem -> 0 0 }T 377 | skip T{ 1 s>d -1 sm/rem -> 0 -1 }T 378 | skip T{ 2 s>d -1 sm/rem -> 0 -2 }T 379 | skip T{ -1 s>d -1 sm/rem -> 0 1 }T 380 | skip T{ -2 s>d -1 sm/rem -> 0 2 }T 381 | skip T{ 2 s>d 2 sm/rem -> 0 1 }T 382 | skip T{ -1 s>d -1 sm/rem -> 0 1 }T 383 | skip T{ -2 s>d -2 sm/rem -> 0 1 }T 384 | skip T{ 7 s>d 3 sm/rem -> 1 2 }T 385 | skip T{ 7 s>d -3 sm/rem -> 1 -2 }T 386 | skip T{ -7 s>d 3 sm/rem -> -1 -2 }T 387 | skip T{ -7 s>d -3 sm/rem -> -1 2 }T 388 | skip T{ max-int s>d 1 sm/rem -> 0 max-int }T 389 | skip T{ min-int s>d 1 sm/rem -> 0 min-int }T 390 | skip T{ max-int s>d max-int sm/rem -> 0 1 }T 391 | skip T{ min-int s>d min-int sm/rem -> 0 1 }T 392 | skip T{ 1s 1 4 sm/rem -> 3 max-int }T 393 | skip T{ 2 min-int m* 2 sm/rem -> 0 min-int }T 394 | skip T{ 2 min-int m* min-int sm/rem -> 0 2 }T 395 | skip T{ 2 max-int m* 2 sm/rem -> 0 max-int }T 396 | skip T{ 2 max-int m* max-int sm/rem -> 0 2 }T 397 | skip T{ min-int min-int m* min-int sm/rem -> 0 min-int }T 398 | skip T{ min-int max-int m* min-int sm/rem -> 0 max-int }T 399 | skip T{ min-int max-int m* max-int sm/rem -> 0 min-int }T 400 | skip T{ max-int max-int m* max-int sm/rem -> 0 max-int }T 401 | 402 | skip T{ 0 0 1 um/mod -> 0 0 }T 403 | skip T{ 1 0 1 um/mod -> 0 1 }T 404 | skip T{ 1 0 2 um/mod -> 1 0 }T 405 | skip T{ 3 0 2 um/mod -> 1 1 }T 406 | skip T{ max-uint 2 um* 2 um/mod -> 0 max-uint }T 407 | skip T{ max-uint 2 um* max-uint um/mod -> 0 2 }T 408 | skip T{ max-uint max-uint um* max-uint um/mod -> 0 max-uint }T 409 | 410 | \ : iffloored [ -3 2 / -2 = invert ] literal if postpone \ then ; 411 | \ : ifsym [ -3 2 / -1 = invert ] literal if postpone \ then ; 412 | 413 | \ the system might do either floored or symmetric division. 414 | \ since we have already tested m*, fm/mod, and sm/rem we can use them in test. 415 | 416 | skip iffloored : t/mod >r s>d r> fm/mod ; 417 | skip iffloored : t/ t/mod swap drop ; 418 | skip iffloored : tmod t/mod drop ; 419 | skip iffloored : t*/mod >r m* r> fm/mod ; 420 | skip iffloored : t*/ t*/mod swap drop ; 421 | skip ifsym : t/mod >r s>d r> sm/rem ; 422 | skip ifsym : t/ t/mod swap drop ; 423 | skip ifsym : tmod t/mod drop ; 424 | skip ifsym : t*/mod >r m* r> sm/rem ; 425 | skip ifsym : t*/ t*/mod swap drop ; 426 | 427 | skip T{ 0 1 /mod -> 0 1 t/mod }T 428 | skip T{ 1 1 /mod -> 1 1 t/mod }T 429 | skip T{ 2 1 /mod -> 2 1 t/mod }T 430 | skip T{ -1 1 /mod -> -1 1 t/mod }T 431 | skip T{ -2 1 /mod -> -2 1 t/mod }T 432 | skip T{ 0 -1 /mod -> 0 -1 t/mod }T 433 | skip T{ 1 -1 /mod -> 1 -1 t/mod }T 434 | skip T{ 2 -1 /mod -> 2 -1 t/mod }T 435 | skip T{ -1 -1 /mod -> -1 -1 t/mod }T 436 | skip T{ -2 -1 /mod -> -2 -1 t/mod }T 437 | skip T{ 2 2 /mod -> 2 2 t/mod }T 438 | skip T{ -1 -1 /mod -> -1 -1 t/mod }T 439 | skip T{ -2 -2 /mod -> -2 -2 t/mod }T 440 | skip T{ 7 3 /mod -> 7 3 t/mod }T 441 | skip T{ 7 -3 /mod -> 7 -3 t/mod }T 442 | skip T{ -7 3 /mod -> -7 3 t/mod }T 443 | skip T{ -7 -3 /mod -> -7 -3 t/mod }T 444 | skip T{ max-int 1 /mod -> max-int 1 t/mod }T 445 | skip T{ min-int 1 /mod -> min-int 1 t/mod }T 446 | skip T{ max-int max-int /mod -> max-int max-int t/mod }T 447 | skip T{ min-int min-int /mod -> min-int min-int t/mod }T 448 | 449 | skip T{ 0 1 / -> 0 1 t/ }T 450 | skip T{ 1 1 / -> 1 1 t/ }T 451 | skip T{ 2 1 / -> 2 1 t/ }T 452 | skip T{ -1 1 / -> -1 1 t/ }T 453 | skip T{ -2 1 / -> -2 1 t/ }T 454 | skip T{ 0 -1 / -> 0 -1 t/ }T 455 | skip T{ 1 -1 / -> 1 -1 t/ }T 456 | skip T{ 2 -1 / -> 2 -1 t/ }T 457 | skip T{ -1 -1 / -> -1 -1 t/ }T 458 | skip T{ -2 -1 / -> -2 -1 t/ }T 459 | skip T{ 2 2 / -> 2 2 t/ }T 460 | skip T{ -1 -1 / -> -1 -1 t/ }T 461 | skip T{ -2 -2 / -> -2 -2 t/ }T 462 | skip T{ 7 3 / -> 7 3 t/ }T 463 | skip T{ 7 -3 / -> 7 -3 t/ }T 464 | skip T{ -7 3 / -> -7 3 t/ }T 465 | skip T{ -7 -3 / -> -7 -3 t/ }T 466 | skip T{ max-int 1 / -> max-int 1 t/ }T 467 | skip T{ min-int 1 / -> min-int 1 t/ }T 468 | skip T{ max-int max-int / -> max-int max-int t/ }T 469 | skip T{ min-int min-int / -> min-int min-int t/ }T 470 | 471 | skip T{ 0 1 mod -> 0 1 tmod }T 472 | skip T{ 1 1 mod -> 1 1 tmod }T 473 | skip T{ 2 1 mod -> 2 1 tmod }T 474 | skip T{ -1 1 mod -> -1 1 tmod }T 475 | skip T{ -2 1 mod -> -2 1 tmod }T 476 | skip T{ 0 -1 mod -> 0 -1 tmod }T 477 | skip T{ 1 -1 mod -> 1 -1 tmod }T 478 | skip T{ 2 -1 mod -> 2 -1 tmod }T 479 | skip T{ -1 -1 mod -> -1 -1 tmod }T 480 | skip T{ -2 -1 mod -> -2 -1 tmod }T 481 | skip T{ 2 2 mod -> 2 2 tmod }T 482 | skip T{ -1 -1 mod -> -1 -1 tmod }T 483 | skip T{ -2 -2 mod -> -2 -2 tmod }T 484 | skip T{ 7 3 mod -> 7 3 tmod }T 485 | skip T{ 7 -3 mod -> 7 -3 tmod }T 486 | skip T{ -7 3 mod -> -7 3 tmod }T 487 | skip T{ -7 -3 mod -> -7 -3 tmod }T 488 | skip T{ max-int 1 mod -> max-int 1 tmod }T 489 | skip T{ min-int 1 mod -> min-int 1 tmod }T 490 | skip T{ max-int max-int mod -> max-int max-int tmod }T 491 | skip T{ min-int min-int mod -> min-int min-int tmod }T 492 | 493 | skip T{ 0 2 1 */ -> 0 2 1 t*/ }T 494 | skip T{ 1 2 1 */ -> 1 2 1 t*/ }T 495 | skip T{ 2 2 1 */ -> 2 2 1 t*/ }T 496 | skip T{ -1 2 1 */ -> -1 2 1 t*/ }T 497 | skip T{ -2 2 1 */ -> -2 2 1 t*/ }T 498 | skip T{ 0 2 -1 */ -> 0 2 -1 t*/ }T 499 | skip T{ 1 2 -1 */ -> 1 2 -1 t*/ }T 500 | skip T{ 2 2 -1 */ -> 2 2 -1 t*/ }T 501 | skip T{ -1 2 -1 */ -> -1 2 -1 t*/ }T 502 | skip T{ -2 2 -1 */ -> -2 2 -1 t*/ }T 503 | skip T{ 2 2 2 */ -> 2 2 2 t*/ }T 504 | skip T{ -1 2 -1 */ -> -1 2 -1 t*/ }T 505 | skip T{ -2 2 -2 */ -> -2 2 -2 t*/ }T 506 | skip T{ 7 2 3 */ -> 7 2 3 t*/ }T 507 | skip T{ 7 2 -3 */ -> 7 2 -3 t*/ }T 508 | skip T{ -7 2 3 */ -> -7 2 3 t*/ }T 509 | skip T{ -7 2 -3 */ -> -7 2 -3 t*/ }T 510 | skip T{ max-int 2 max-int */ -> max-int 2 max-int t*/ }T 511 | skip T{ min-int 2 min-int */ -> min-int 2 min-int t*/ }T 512 | 513 | skip T{ 0 2 1 */mod -> 0 2 1 t*/mod }T 514 | skip T{ 1 2 1 */mod -> 1 2 1 t*/mod }T 515 | skip T{ 2 2 1 */mod -> 2 2 1 t*/mod }T 516 | skip T{ -1 2 1 */mod -> -1 2 1 t*/mod }T 517 | skip T{ -2 2 1 */mod -> -2 2 1 t*/mod }T 518 | skip T{ 0 2 -1 */mod -> 0 2 -1 t*/mod }T 519 | skip T{ 1 2 -1 */mod -> 1 2 -1 t*/mod }T 520 | skip T{ 2 2 -1 */mod -> 2 2 -1 t*/mod }T 521 | skip T{ -1 2 -1 */mod -> -1 2 -1 t*/mod }T 522 | skip T{ -2 2 -1 */mod -> -2 2 -1 t*/mod }T 523 | skip T{ 2 2 2 */mod -> 2 2 2 t*/mod }T 524 | skip T{ -1 2 -1 */mod -> -1 2 -1 t*/mod }T 525 | skip T{ -2 2 -2 */mod -> -2 2 -2 t*/mod }T 526 | skip T{ 7 2 3 */mod -> 7 2 3 t*/mod }T 527 | skip T{ 7 2 -3 */mod -> 7 2 -3 t*/mod }T 528 | skip T{ -7 2 3 */mod -> -7 2 3 t*/mod }T 529 | skip T{ -7 2 -3 */mod -> -7 2 -3 t*/mod }T 530 | skip T{ max-int 2 max-int */mod -> max-int 2 max-int t*/mod }T 531 | skip T{ min-int 2 min-int */mod -> min-int 2 min-int t*/mod }T 532 | 533 | \ ------------------------------------------------------------------------ 534 | testing here , @ ! cell+ cells c, c@ c! chars 2@ 2! align aligned +! allot 535 | 536 | here 1 allot 537 | here 538 | constant 2nda 539 | constant 1sta 540 | T{ 1sta 2nda u< -> }T \ here must grow with allot 541 | T{ 1sta 1+ -> 2nda }T \ ... by one address unit 542 | ( missing test: negative allot ) 543 | 544 | \ Added by GWJ so that align can be used before , (comma) is tested 545 | 1 aligned constant almnt \ -- 1|2|4|8 for 8|16|32|64 bit alignment 546 | align 547 | T{ here 1 allot align here swap - almnt = -> }T 548 | \ End of extra test 549 | 550 | here 1 , 551 | here 2 , 552 | constant 2nd 553 | constant 1st 554 | T{ 1st 2nd u< -> }T \ here must grow with allot 555 | T{ 1st cell+ -> 2nd }T \ ... by one cell 556 | T{ 1st 1 cells + -> 2nd }T 557 | T{ 1st @ 2nd @ -> 1 2 }T 558 | T{ 5 1st ! -> }T 559 | T{ 1st @ 2nd @ -> 5 2 }T 560 | T{ 6 2nd ! -> }T 561 | T{ 1st @ 2nd @ -> 5 6 }T 562 | skip T{ 1st 2@ -> 6 5 }T 563 | skip T{ 2 1 1st 2! -> }T 564 | skip T{ 1st 2@ -> 2 1 }T 565 | T{ 1s 1st ! 1st @ -> 1s }T \ can store cell-wide value 566 | 567 | here 1 c, 568 | here 2 c, 569 | constant 2ndc 570 | constant 1stc 571 | T{ 1stc 2ndc u< -> }T \ here must grow with allot 572 | T{ 1stc char+ -> 2ndc }T \ ... by one char 573 | T{ 1stc 1 chars + -> 2ndc }T 574 | T{ 1stc c@ 2ndc c@ -> 1 2 }T 575 | T{ 3 1stc c! -> }T 576 | T{ 1stc c@ 2ndc c@ -> 3 2 }T 577 | T{ 4 2ndc c! -> }T 578 | T{ 1stc c@ 2ndc c@ -> 3 4 }T 579 | 580 | align 1 allot here align here 3 cells allot 581 | constant a-addr constant ua-addr 582 | T{ ua-addr aligned -> a-addr }T 583 | T{ 1 a-addr c! a-addr c@ -> 1 }T 584 | T{ 1234 a-addr ! a-addr @ -> 1234 }T 585 | skip T{ 123 456 a-addr 2! a-addr 2@ -> 123 456 }T 586 | T{ 2 a-addr char+ c! a-addr char+ c@ -> 2 }T 587 | T{ 3 a-addr cell+ c! a-addr cell+ c@ -> 3 }T 588 | T{ 1234 a-addr cell+ ! a-addr cell+ @ -> 1234 }T 589 | skip T{ 123 456 a-addr cell+ 2! a-addr cell+ 2@ -> 123 456 }T 590 | 591 | : bits ( x -- u ) 592 | 0 swap begin dup while dup msb and if >r 1+ r> then 2* repeat drop ; 593 | ( characters >= 1 au, <= size of cell, >= 8 bits ) 594 | T{ 1 chars 1 < -> }T 595 | T{ 1 chars 1 cells > -> }T 596 | ( tbd: how to find number of bits? ) 597 | 598 | ( cells >= 1 au, integral multiple of char size, >= 16 bits ) 599 | T{ 1 cells 1 < -> }T 600 | T{ 1 cells 1 chars mod -> 0 }T 601 | T{ 1s bits 10 < -> }T 602 | 603 | T{ 0 1st ! -> }T 604 | T{ 1 1st +! -> }T 605 | T{ 1st @ -> 1 }T 606 | T{ -1 1st +! 1st @ -> 0 }T 607 | 608 | \ ------------------------------------------------------------------------ 609 | testing char [char] [ ] bl s" 610 | 611 | T{ bl -> 20 }T 612 | T{ char X -> 58 }T 613 | T{ char HELLO -> 48 }T 614 | T{ '\n' -> 0xa }T 615 | T{ '\0' -> 0 }T 616 | T{ 'a' -> 61 }T 617 | T{ '"' -> 22 }T 618 | T{ '\"' -> 22 }T 619 | T{ '\'' -> 27 }T 620 | T{ : gc1 [char] X ; -> }T 621 | T{ : gc2 [char] HELLO ; -> }T 622 | T{ gc1 -> 58 }T 623 | T{ gc2 -> 48 }T 624 | T{ : gc3 [ gc1 ] literal ; -> }T 625 | T{ gc3 -> 58 }T 626 | T{ : gc4 s" XY" ; -> }T 627 | 628 | T{ gc4 strlen -> 2 }T 629 | T{ gc4 dup c@ swap char+ c@ -> 58 59 }T 630 | 631 | skip T{ gc4 swap drop -> 2 }T 632 | skip T{ gc4 drop dup c@ swap char+ c@ -> 58 59 }T 633 | 634 | \ ------------------------------------------------------------------------ 635 | testing ' ['] find execute immediate count literal postpone state 636 | 637 | T{ : gt1 123 ; -> }T 638 | T{ ' gt1 execute -> 123 }T 639 | T{ : gt2 ['] gt1 ; immediate -> }T 640 | T{ gt2 execute -> 123 }T 641 | here char g c, char t c, char 1 c, 0 c, constant gt1string 642 | here char g c, char t c, char 2 c, 0 c, constant gt2string 643 | skip here 3 c, char g c, char t c, char 1 c, constant gt1string 644 | skip here 3 c, char g c, char t c, char 2 c, constant gt2string 645 | T{ gt1string find >cfa -> ' gt1 }T 646 | T{ gt2string find >cfa -> ' gt2 }T 647 | ( how to search for non-existent word? ) 648 | T{ : gt3 gt2 literal ; -> }T 649 | T{ gt3 -> ' gt1 }T 650 | skip T{ gt1string count -> gt1string char+ 3 }T 651 | 652 | skip T{ : gt4 postpone gt1 ; immediate -> }T 653 | skip T{ : gt5 gt4 ; -> }T 654 | skip T{ gt5 -> 123 }T 655 | skip T{ : gt6 345 ; immediate -> }T 656 | skip T{ : gt7 postpone gt6 ; -> }T 657 | skip T{ gt7 -> 345 }T 658 | 659 | T{ : gt8 state @ ; immediate -> }T 660 | T{ gt8 -> 0 }T 661 | T{ : gt9 gt8 literal ; -> }T 662 | T{ gt9 0= -> }T 663 | 664 | \ ------------------------------------------------------------------------ 665 | testing if else then begin while repeat until recurse 666 | 667 | T{ : gi1 if 123 then ; -> }T 668 | T{ : gi2 if 123 else 234 then ; -> }T 669 | T{ 0 gi1 -> }T 670 | T{ 1 gi1 -> 123 }T 671 | T{ -1 gi1 -> 123 }T 672 | T{ 0 gi2 -> 234 }T 673 | T{ 1 gi2 -> 123 }T 674 | T{ -1 gi1 -> 123 }T 675 | 676 | T{ : gi3 begin dup 5 < while dup 1+ repeat ; -> }T 677 | T{ 0 gi3 -> 0 1 2 3 4 5 }T 678 | T{ 4 gi3 -> 4 5 }T 679 | T{ 5 gi3 -> 5 }T 680 | T{ 6 gi3 -> 6 }T 681 | 682 | T{ : gi4 begin dup 1+ dup 5 > until ; -> }T 683 | T{ 3 gi4 -> 3 4 5 6 }T 684 | T{ 5 gi4 -> 5 6 }T 685 | T{ 6 gi4 -> 6 7 }T 686 | 687 | T{ : gi5 begin dup 2 > 688 | while dup 5 < while dup 1+ repeat 123 else 345 then ; -> }T 689 | T{ 1 gi5 -> 1 345 }T 690 | T{ 2 gi5 -> 2 345 }T 691 | T{ 3 gi5 -> 3 4 5 123 }T 692 | T{ 4 gi5 -> 4 5 123 }T 693 | T{ 5 gi5 -> 5 123 }T 694 | 695 | T{ : gi6 ( n -- 0,1,..n ) dup if dup >r 1- recurse r> then ; -> }T 696 | T{ 0 gi6 -> 0 }T 697 | T{ 1 gi6 -> 0 1 }T 698 | T{ 2 gi6 -> 0 1 2 }T 699 | T{ 3 gi6 -> 0 1 2 3 }T 700 | T{ 4 gi6 -> 0 1 2 3 4 }T 701 | 702 | \ ------------------------------------------------------------------------ 703 | testing do loop +loop i j unloop leave exit 704 | 705 | T{ : gd1 do i loop ; -> }T 706 | T{ 4 1 gd1 -> 1 2 3 }T 707 | T{ 2 -1 gd1 -> -1 0 1 }T 708 | T{ mid-uint+1 mid-uint gd1 -> mid-uint }T 709 | 710 | T{ : gd2 do i -1 +loop ; -> }T 711 | T{ 1 4 gd2 -> 4 3 2 1 }T 712 | T{ -1 2 gd2 -> 2 1 0 -1 }T 713 | T{ mid-uint mid-uint+1 gd2 -> mid-uint+1 mid-uint }T 714 | 715 | T{ : gd3 do 1 0 do j loop loop ; -> }T 716 | T{ 4 1 gd3 -> 1 2 3 }T 717 | T{ 2 -1 gd3 -> -1 0 1 }T 718 | T{ mid-uint+1 mid-uint gd3 -> mid-uint }T 719 | 720 | T{ : gd4 do 1 0 do j loop -1 +loop ; -> }T 721 | T{ 1 4 gd4 -> 4 3 2 1 }T 722 | T{ -1 2 gd4 -> 2 1 0 -1 }T 723 | T{ mid-uint mid-uint+1 gd4 -> mid-uint+1 mid-uint }T 724 | 725 | T{ : gd5 123 swap 0 do i 4 > if drop 234 leave then loop ; -> }T 726 | T{ 1 gd5 -> 123 }T 727 | T{ 5 gd5 -> 123 }T 728 | T{ 6 gd5 -> 234 }T 729 | 730 | T{ : gd6 ( pat: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 731 | 0 swap 0 do 732 | i 1+ 0 do i j + 3 = if i unloop i unloop exit then 1+ loop 733 | loop ; -> }T 734 | T{ 1 gd6 -> 1 }T 735 | T{ 2 gd6 -> 3 }T 736 | T{ 3 gd6 -> 4 1 2 }T 737 | 738 | \ ------------------------------------------------------------------------ 739 | testing defining words: : ; constant variable create does> >body 740 | 741 | T{ 123 constant x123 -> }T 742 | T{ x123 -> 123 }T 743 | T{ : equ constant ; -> }T 744 | T{ x123 equ y123 -> }T 745 | T{ y123 -> 123 }T 746 | 747 | T{ variable v1 -> }T 748 | T{ 123 v1 ! -> }T 749 | T{ v1 @ -> 123 }T 750 | 751 | skip T{ : nop : postpone ; ; -> }T 752 | skip T{ nop nop1 nop nop2 -> }T 753 | skip T{ nop1 -> }T 754 | skip T{ nop2 -> }T 755 | 756 | T{ : does1 does> @ 1 + ; -> }T 757 | T{ : does2 does> @ 2 + ; -> }T 758 | T{ create cr1 -> }T 759 | T{ cr1 -> here }T 760 | T{ ' cr1 >body -> here }T 761 | T{ 1 , -> }T 762 | T{ cr1 @ -> 1 }T 763 | T{ does1 -> }T 764 | T{ cr1 -> 2 }T 765 | T{ does2 -> }T 766 | T{ cr1 -> 3 }T 767 | 768 | T{ : weird: create does> 1 + does> 2 + ; -> }T 769 | T{ weird: w1 -> }T 770 | T{ ' w1 >body -> here }T 771 | T{ w1 -> here 1 + }T 772 | T{ w1 -> here 2 + }T 773 | 774 | \ ------------------------------------------------------------------------ 775 | testing evaluate 776 | 777 | : ge1 s" 123" ; immediate 778 | : ge2 s" 123 1+" ; immediate 779 | : ge3 s" : ge4 345 ;" ; 780 | \ : ge5 evaluate ; immediate 781 | 782 | skip T{ ge1 evaluate -> 123 }T ( test evaluate in interp. state ) 783 | skip T{ ge2 evaluate -> 124 }T 784 | skip T{ ge3 evaluate -> }T 785 | skip T{ ge4 -> 345 }T 786 | 787 | skip T{ : ge6 ge1 ge5 ; -> }T ( test evaluate in compile state ) 788 | skip T{ ge6 -> 123 }T 789 | skip T{ : ge7 ge2 ge5 ; -> }T 790 | skip T{ ge7 -> 124 }T 791 | 792 | \ ------------------------------------------------------------------------ 793 | testing source >in word 794 | 795 | \ : gs1 s" source" 2dup evaluate 796 | \ >r swap >r = r> r> = ; 797 | skip T{ gs1 -> }T 798 | 799 | variable scans 800 | : rescan? -1 scans +! scans @ if 0 >in ! then ; 801 | 802 | T{ 2 scans ! 803 | 345 rescan? 804 | -> 345 345 }T 805 | 806 | \ : gs2 5 scans ! s" 123 rescan?" evaluate ; 807 | skip T{ gs2 -> 123 123 123 123 123 }T 808 | 809 | \ : gs3 word count swap c@ ; 810 | skip T{ bl gs3 hello -> 5 char h }T 811 | skip T{ char " gs3 goodbye" -> 7 char g }T 812 | skip T{ bl gs3 drop -> 0 }T \ blank line return zero-length string 813 | 814 | \ : gs4 source >in ! drop ; 815 | \ T{ gs4 123 456 816 | \ -> }T 817 | 818 | testing sourcefilename 819 | T{ sourcefilename s" test/core.fs" streq -> }T 820 | 821 | \ ------------------------------------------------------------------------ 822 | testing <# # #s #> hold sign base >number hex decimal 823 | 824 | \ : s= \ ( addr1 c1 addr2 c2 -- t/f ) compare two strings. 825 | \ >r swap r@ = if \ make sure strings have same length 826 | \ r> ?dup if \ if non-empty strings 827 | \ 0 do 828 | \ over c@ over c@ - if 2drop unloop exit then 829 | \ swap char+ swap char+ 830 | \ loop 831 | \ then 832 | \ 2drop \ if we get here, strings match 833 | \ else 834 | \ r> drop 2drop \ lengths mismatch 835 | \ then ; 836 | 837 | \ : gp1 <# 41 hold 42 hold 0 0 #> s" ba" s= ; 838 | skip T{ gp1 -> }T 839 | 840 | \ : gp2 <# -1 sign 0 sign -1 sign 0 0 #> s" --" s= ; 841 | skip T{ gp2 -> }T 842 | 843 | \ : gp3 <# 1 0 # # #> s" 01" s= ; 844 | skip T{ gp3 -> }T 845 | 846 | \ : gp4 <# 1 0 #s #> s" 1" s= ; 847 | skip T{ gp4 -> }T 848 | 849 | \ 24 constant max-base \ base 2 .. 36 850 | \ : count-bits 851 | \ 0 0 invert begin dup while >r 1+ r> 2* repeat drop ; 852 | \ count-bits 2* constant #bits-ud \ number of bits in ud 853 | 854 | \ : gp5 855 | \ base @ 856 | \ max-base 1+ 2 do \ for each possible base 857 | \ i base ! \ tbd: assumes base works 858 | \ i 0 <# #s #> s" 10" s= and 859 | \ loop 860 | \ swap base ! ; 861 | skip T{ gp5 -> }T 862 | 863 | \ : gp6 864 | \ base @ >r 2 base ! 865 | \ max-uint max-uint <# #s #> \ maximum ud to binary 866 | \ r> base ! \ s: c-addr u 867 | \ dup #bits-ud = swap 868 | \ 0 do \ s: c-addr flag 869 | \ over c@ [char] 1 = and \ all ones 870 | \ >r char+ r> 871 | \ loop swap drop ; 872 | skip T{ gp6 -> }T 873 | 874 | \ : gp7 875 | \ base @ >r max-base base ! 876 | \ 877 | \ a 0 do 878 | \ i 0 <# #s #> 879 | \ 1 = swap c@ i 30 + = and and 880 | \ loop 881 | \ max-base a do 882 | \ i 0 <# #s #> 883 | \ 1 = swap c@ 41 i a - + = and and 884 | \ loop 885 | \ r> base ! ; 886 | 887 | skip T{ gp7 -> }T 888 | 889 | \ >number tests 890 | \ create gn-buf 0 c, 891 | \ : gn-string gn-buf 1 ; 892 | \ : gn-consumed gn-buf char+ 0 ; 893 | \ : gn' [char] ' word char+ c@ gn-buf c! gn-string ; 894 | 895 | skip T{ 0 0 gn' 0' >number -> 0 0 gn-consumed }T 896 | skip T{ 0 0 gn' 1' >number -> 1 0 gn-consumed }T 897 | skip T{ 1 0 gn' 1' >number -> base @ 1+ 0 gn-consumed }T 898 | skip T{ 0 0 gn' -' >number -> 0 0 gn-string }T \ should fail to convert these 899 | skip T{ 0 0 gn' +' >number -> 0 0 gn-string }T 900 | skip T{ 0 0 gn' .' >number -> 0 0 gn-string }T 901 | 902 | \ : >number-based 903 | \ base @ >r base ! >number r> base ! ; 904 | 905 | skip T{ 0 0 gn' 2' 10 >number-based -> 2 0 gn-consumed }T 906 | skip T{ 0 0 gn' 2' 2 >number-based -> 0 0 gn-string }T 907 | skip T{ 0 0 gn' f' 10 >number-based -> f 0 gn-consumed }T 908 | skip T{ 0 0 gn' g' 10 >number-based -> 0 0 gn-string }T 909 | skip T{ 0 0 gn' g' max-base >number-based -> 10 0 gn-consumed }T 910 | skip T{ 0 0 gn' z' max-base >number-based -> 23 0 gn-consumed }T 911 | 912 | \ : gn1 \ ( ud base -- ud' len ) ud should equal ud' and len should be zero. 913 | \ base @ >r base ! 914 | \ <# #s #> 915 | \ 0 0 2swap >number swap drop \ return length only 916 | \ r> base ! ; 917 | skip T{ 0 0 2 gn1 -> 0 0 0 }T 918 | skip T{ max-uint 0 2 gn1 -> max-uint 0 0 }T 919 | skip T{ max-uint dup 2 gn1 -> max-uint dup 0 }T 920 | skip T{ 0 0 max-base gn1 -> 0 0 0 }T 921 | skip T{ max-uint 0 max-base gn1 -> max-uint 0 0 }T 922 | skip T{ max-uint dup max-base gn1 -> max-uint dup 0 }T 923 | 924 | \ : gn2 \ ( -- 16 10 ) 925 | \ base @ >r hex base @ decimal base @ r> base ! ; 926 | skip T{ gn2 -> 10 a }T 927 | 928 | \ ------------------------------------------------------------------------ 929 | testing fill move 930 | 931 | \ create fbuf 00 c, 00 c, 00 c, 932 | \ create sbuf 12 c, 34 c, 56 c, 933 | \ : seebuf fbuf c@ fbuf char+ c@ fbuf char+ char+ c@ ; 934 | 935 | skip T{ fbuf 0 20 fill -> }T 936 | skip T{ seebuf -> 00 00 00 }T 937 | 938 | skip T{ fbuf 1 20 fill -> }T 939 | skip T{ seebuf -> 20 00 00 }T 940 | 941 | skip T{ fbuf 3 20 fill -> }T 942 | skip T{ seebuf -> 20 20 20 }T 943 | 944 | skip T{ fbuf fbuf 3 chars move -> }T \ bizarre special case 945 | skip T{ seebuf -> 20 20 20 }T 946 | 947 | skip T{ sbuf fbuf 0 chars move -> }T 948 | skip T{ seebuf -> 20 20 20 }T 949 | 950 | skip T{ sbuf fbuf 1 chars move -> }T 951 | skip T{ seebuf -> 12 20 20 }T 952 | 953 | skip T{ sbuf fbuf 3 chars move -> }T 954 | skip T{ seebuf -> 12 34 56 }T 955 | 956 | skip T{ fbuf fbuf char+ 2 chars move -> }T 957 | skip T{ seebuf -> 12 12 34 }T 958 | 959 | skip T{ fbuf char+ fbuf 2 chars move -> }T 960 | skip T{ seebuf -> 12 34 34 }T 961 | 962 | \ ------------------------------------------------------------------------ 963 | testing output: . ." cr emit space spaces type u. 964 | 965 | : output-test 966 | cr 967 | ." you should see the standard graphic characters:" cr 968 | 41 bl do i emit loop cr 969 | 61 41 do i emit loop cr 970 | 7f 61 do i emit loop cr 971 | ." you should see 0-9 separated by a space:" cr 972 | 9 1+ 0 do i . loop cr 973 | ." you should see 0-9 (with no spaces):" cr 974 | [char] 9 1+ [char] 0 do i 0 spaces emit loop cr 975 | ." you should see a-g separated by a space:" cr 976 | [char] g 1+ [char] a do i emit space loop cr 977 | ." you should see 0-5 separated by two spaces:" cr 978 | 5 1+ 0 do i [char] 0 + emit 2 spaces loop cr 979 | ." you should see two separate lines:" cr 980 | s" line 1" type cr s" line 2" type cr 981 | ." you should see the number ranges of signed and unsigned numbers:" cr 982 | ." signed: " min-int . max-int . cr 983 | ." unsigned: " 0 u. max-uint u. cr 984 | ; 985 | 986 | T{ output-test -> }T 987 | 988 | 989 | \ ------------------------------------------------------------------------ 990 | testing input: accept 991 | 992 | create abuf 50 chars allot 993 | 994 | \ : accept-test 995 | \ cr ." please type up to 80 characters:" cr 996 | \ abuf 50 accept 997 | \ cr ." received: " [char] " emit 998 | \ abuf swap type [char] " emit cr 999 | \ ; 1000 | 1001 | skip T{ accept-test -> }T 1002 | 1003 | \ ------------------------------------------------------------------------ 1004 | testing dictionary search rules 1005 | 1006 | T{ : gdx 123 ; : gdx gdx 234 ; -> }T 1007 | 1008 | T{ gdx -> 123 234 }T 1009 | 1010 | cr ." End of Core word set tests" cr 1011 | 1012 | \ ------------------------------------------------------------------------ 1013 | testing cons, car and cdr 1014 | 1015 | 0 1 cons constant cons0 1016 | 1017 | T{ cons0 car -> 0 }T 1018 | T{ cons0 cdr -> 1 }T 1019 | 1020 | cons0 free 1021 | 1022 | \ ------------------------------------------------------------------------ 1023 | testing enum 1024 | 1025 | T{ 0 enum e0 enum e1 enum e2 drop -> }T 1026 | T{ e0 -> 0 }T 1027 | T{ e1 -> 1 }T 1028 | T{ e2 -> 2 }T 1029 | -------------------------------------------------------------------------------- /test/coreexttest.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | testing Core Extension words 8 | 9 | decimal 10 | 11 | testing true false 12 | 13 | T{ true -> 1 }T 14 | T{ false -> 0 }T 15 | 16 | \ ----------------------------------------------------------------------------- 17 | testing <> u> (contributed by James Bowman) 18 | 19 | T{ 0 0 <> -> false }T 20 | T{ 1 1 <> -> false }T 21 | T{ -1 -1 <> -> false }T 22 | T{ 1 0 <> -> true }T 23 | T{ -1 0 <> -> true }T 24 | T{ 0 1 <> -> true }T 25 | T{ 0 -1 <> -> true }T 26 | 27 | T{ 0 1 u> -> false }T 28 | T{ 1 2 u> -> false }T 29 | T{ 0 mid-uint u> -> false }T 30 | T{ 0 max-uint u> -> false }T 31 | T{ mid-uint max-uint u> -> false }T 32 | T{ 0 0 u> -> false }T 33 | T{ 1 1 u> -> false }T 34 | T{ 1 0 u> -> true }T 35 | T{ 2 1 u> -> true }T 36 | T{ mid-uint 0 u> -> true }T 37 | T{ max-uint 0 u> -> true }T 38 | T{ max-uint mid-uint u> -> true }T 39 | 40 | \ ----------------------------------------------------------------------------- 41 | testing 0<> 0> (contributed by James Bowman) 42 | 43 | T{ 0 0<> -> false }T 44 | T{ 1 0<> -> true }T 45 | T{ 2 0<> -> true }T 46 | T{ -1 0<> -> true }T 47 | T{ max-uint 0<> -> true }T 48 | T{ min-int 0<> -> true }T 49 | T{ max-int 0<> -> true }T 50 | 51 | T{ 0 0> -> false }T 52 | T{ -1 0> -> false }T 53 | T{ min-int 0> -> false }T 54 | T{ 1 0> -> true }T 55 | T{ max-int 0> -> true }T 56 | 57 | \ ----------------------------------------------------------------------------- 58 | testing nip tuck roll pick (contributed by James Bowman) 59 | 60 | T{ 1 2 nip -> 2 }T 61 | T{ 1 2 3 nip -> 1 3 }T 62 | 63 | T{ 1 2 tuck -> 2 1 2 }T 64 | T{ 1 2 3 tuck -> 1 3 2 3 }T 65 | 66 | T{ : RO5 100 200 300 400 500 ; -> }T 67 | T{ RO5 3 roll -> 100 300 400 500 200 }T 68 | T{ RO5 2 roll -> RO5 rot }T 69 | T{ RO5 1 roll -> RO5 swap }T 70 | T{ RO5 0 roll -> RO5 }T 71 | 72 | T{ RO5 2 pick -> 100 200 300 400 500 300 }T 73 | T{ RO5 1 pick -> RO5 over }T 74 | T{ RO5 0 pick -> RO5 dup }T 75 | 76 | \ ----------------------------------------------------------------------------- 77 | testing 2>r 2r@ 2r> (contributed by James Bowman) 78 | 79 | skip T{ : RR0 2>r 100 r> r> ; -> }T 80 | skip T{ 300 400 RR0 -> 100 400 300 }T 81 | skip T{ 200 300 400 RR0 -> 200 100 400 300 }T 82 | 83 | skip T{ : RR1 2>r 100 2r@ r> r> ; -> }T 84 | skip T{ 300 400 RR1 -> 100 300 400 400 300 }T 85 | skip T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T 86 | skip 87 | skip T{ : RR2 2>r 100 2r> ; -> }T 88 | skip T{ 300 400 RR2 -> 100 300 400 }T 89 | skip T{ 200 300 400 RR2 -> 200 100 300 400 }T 90 | 91 | \ ----------------------------------------------------------------------------- 92 | testing hex (contributed by James Bowman) 93 | 94 | T{ base @ hex base @ decimal base @ - swap base ! -> 6 }T 95 | 96 | \ ----------------------------------------------------------------------------- 97 | testing within (contributed by James Bowman) 98 | 99 | T{ 0 0 0 within -> false }T 100 | T{ 0 0 mid-uint within -> true }T 101 | T{ 0 0 mid-uint+1 within -> true }T 102 | T{ 0 0 max-uint within -> true }T 103 | T{ 0 mid-uint 0 within -> false }T 104 | T{ 0 mid-uint mid-uint within -> false }T 105 | T{ 0 mid-uint mid-uint+1 within -> false }T 106 | T{ 0 mid-uint max-uint within -> false }T 107 | T{ 0 mid-uint+1 0 within -> false }T 108 | T{ 0 mid-uint+1 mid-uint within -> true }T 109 | T{ 0 mid-uint+1 mid-uint+1 within -> false }T 110 | T{ 0 mid-uint+1 max-uint within -> false }T 111 | T{ 0 max-uint 0 within -> false }T 112 | T{ 0 max-uint mid-uint within -> true }T 113 | T{ 0 max-uint mid-uint+1 within -> true }T 114 | T{ 0 max-uint max-uint within -> false }T 115 | T{ mid-uint 0 0 within -> false }T 116 | T{ mid-uint 0 mid-uint within -> false }T 117 | T{ mid-uint 0 mid-uint+1 within -> true }T 118 | T{ mid-uint 0 max-uint within -> true }T 119 | T{ mid-uint mid-uint 0 within -> true }T 120 | T{ mid-uint mid-uint mid-uint within -> false }T 121 | T{ mid-uint mid-uint mid-uint+1 within -> true }T 122 | T{ mid-uint mid-uint max-uint within -> true }T 123 | T{ mid-uint mid-uint+1 0 within -> false }T 124 | T{ mid-uint mid-uint+1 mid-uint within -> false }T 125 | T{ mid-uint mid-uint+1 mid-uint+1 within -> false }T 126 | T{ mid-uint mid-uint+1 max-uint within -> false }T 127 | T{ mid-uint max-uint 0 within -> false }T 128 | T{ mid-uint max-uint mid-uint within -> false }T 129 | T{ mid-uint max-uint mid-uint+1 within -> true }T 130 | T{ mid-uint max-uint max-uint within -> false }T 131 | T{ mid-uint+1 0 0 within -> false }T 132 | T{ mid-uint+1 0 mid-uint within -> false }T 133 | T{ mid-uint+1 0 mid-uint+1 within -> false }T 134 | T{ mid-uint+1 0 max-uint within -> true }T 135 | T{ mid-uint+1 mid-uint 0 within -> true }T 136 | T{ mid-uint+1 mid-uint mid-uint within -> false }T 137 | T{ mid-uint+1 mid-uint mid-uint+1 within -> false }T 138 | T{ mid-uint+1 mid-uint max-uint within -> true }T 139 | T{ mid-uint+1 mid-uint+1 0 within -> true }T 140 | T{ mid-uint+1 mid-uint+1 mid-uint within -> true }T 141 | T{ mid-uint+1 mid-uint+1 mid-uint+1 within -> false }T 142 | T{ mid-uint+1 mid-uint+1 max-uint within -> true }T 143 | T{ mid-uint+1 max-uint 0 within -> false }T 144 | T{ mid-uint+1 max-uint mid-uint within -> false }T 145 | T{ mid-uint+1 max-uint mid-uint+1 within -> false }T 146 | T{ mid-uint+1 max-uint max-uint within -> false }T 147 | T{ max-uint 0 0 within -> false }T 148 | T{ max-uint 0 mid-uint within -> false }T 149 | T{ max-uint 0 mid-uint+1 within -> false }T 150 | T{ max-uint 0 max-uint within -> false }T 151 | T{ max-uint mid-uint 0 within -> true }T 152 | T{ max-uint mid-uint mid-uint within -> false }T 153 | T{ max-uint mid-uint mid-uint+1 within -> false }T 154 | T{ max-uint mid-uint max-uint within -> false }T 155 | T{ max-uint mid-uint+1 0 within -> true }T 156 | T{ max-uint mid-uint+1 mid-uint within -> true }T 157 | T{ max-uint mid-uint+1 mid-uint+1 within -> false }T 158 | T{ max-uint mid-uint+1 max-uint within -> false }T 159 | T{ max-uint max-uint 0 within -> true }T 160 | T{ max-uint max-uint mid-uint within -> true }T 161 | T{ max-uint max-uint mid-uint+1 within -> true }T 162 | T{ max-uint max-uint max-uint within -> false }T 163 | 164 | T{ min-int min-int min-int within -> false }T 165 | T{ min-int min-int 0 within -> true }T 166 | T{ min-int min-int 1 within -> true }T 167 | T{ min-int min-int max-int within -> true }T 168 | T{ min-int 0 min-int within -> false }T 169 | T{ min-int 0 0 within -> false }T 170 | T{ min-int 0 1 within -> false }T 171 | T{ min-int 0 max-int within -> false }T 172 | T{ min-int 1 min-int within -> false }T 173 | T{ min-int 1 0 within -> true }T 174 | T{ min-int 1 1 within -> false }T 175 | T{ min-int 1 max-int within -> false }T 176 | T{ min-int max-int min-int within -> false }T 177 | T{ min-int max-int 0 within -> true }T 178 | T{ min-int max-int 1 within -> true }T 179 | T{ min-int max-int max-int within -> false }T 180 | T{ 0 min-int min-int within -> false }T 181 | T{ 0 min-int 0 within -> false }T 182 | T{ 0 min-int 1 within -> true }T 183 | T{ 0 min-int max-int within -> true }T 184 | T{ 0 0 min-int within -> true }T 185 | T{ 0 0 0 within -> false }T 186 | T{ 0 0 1 within -> true }T 187 | T{ 0 0 max-int within -> true }T 188 | T{ 0 1 min-int within -> false }T 189 | T{ 0 1 0 within -> false }T 190 | T{ 0 1 1 within -> false }T 191 | T{ 0 1 max-int within -> false }T 192 | T{ 0 max-int min-int within -> false }T 193 | T{ 0 max-int 0 within -> false }T 194 | T{ 0 max-int 1 within -> true }T 195 | T{ 0 max-int max-int within -> false }T 196 | T{ 1 min-int min-int within -> false }T 197 | T{ 1 min-int 0 within -> false }T 198 | T{ 1 min-int 1 within -> false }T 199 | T{ 1 min-int max-int within -> true }T 200 | T{ 1 0 min-int within -> true }T 201 | T{ 1 0 0 within -> false }T 202 | T{ 1 0 1 within -> false }T 203 | T{ 1 0 max-int within -> true }T 204 | T{ 1 1 min-int within -> true }T 205 | T{ 1 1 0 within -> true }T 206 | T{ 1 1 1 within -> false }T 207 | T{ 1 1 max-int within -> true }T 208 | T{ 1 max-int min-int within -> false }T 209 | T{ 1 max-int 0 within -> false }T 210 | T{ 1 max-int 1 within -> false }T 211 | T{ 1 max-int max-int within -> false }T 212 | T{ max-int min-int min-int within -> false }T 213 | T{ max-int min-int 0 within -> false }T 214 | T{ max-int min-int 1 within -> false }T 215 | T{ max-int min-int max-int within -> false }T 216 | T{ max-int 0 min-int within -> true }T 217 | T{ max-int 0 0 within -> false }T 218 | T{ max-int 0 1 within -> false }T 219 | T{ max-int 0 max-int within -> false }T 220 | T{ max-int 1 min-int within -> true }T 221 | T{ max-int 1 0 within -> true }T 222 | T{ max-int 1 1 within -> false }T 223 | T{ max-int 1 max-int within -> false }T 224 | T{ max-int max-int min-int within -> true }T 225 | T{ max-int max-int 0 within -> true }T 226 | T{ max-int max-int 1 within -> true }T 227 | T{ max-int max-int max-int within -> false }T 228 | 229 | \ ----------------------------------------------------------------------------- 230 | testing unused (contributed by James Bowman & Peter Knaggs) 231 | 232 | variable unused0 233 | skip T{ unused drop -> }T 234 | skip T{ align unused unused0 ! 0 , unused CELL+ unused0 @ = -> true }T 235 | skip T{ unused unused0 ! 0 C, unused char+ unused0 @ = -> true }T \ aligned -> unaligned 236 | skip T{ unused unused0 ! 0 C, unused char+ unused0 @ = -> true }T \ unaligned -> ? 237 | 238 | \ ----------------------------------------------------------------------------- 239 | testing again (contributed by James Bowman) 240 | 241 | T{ : AG0 701 begin dup 7 mod 0= if exit then 1+ again ; -> }T 242 | T{ AG0 -> 707 }T 243 | 244 | \ ----------------------------------------------------------------------------- 245 | testing marker (contributed by James Bowman) 246 | 247 | T{ : MA? word throw find 0<> ; -> }T 248 | T{ marker MA0 -> }T 249 | T{ : MA1 111 ; -> }T 250 | T{ marker MA2 -> }T 251 | T{ : MA1 222 ; -> }T 252 | T{ MA? MA0 MA? MA1 MA? MA2 -> true true true }T 253 | T{ MA1 MA2 MA1 -> 222 111 }T 254 | T{ MA? MA0 MA? MA1 MA? MA2 -> true true false }T 255 | T{ MA0 -> }T 256 | T{ MA? MA0 MA? MA1 MA? MA2 -> false false false }T 257 | 258 | \ ----------------------------------------------------------------------------- 259 | testing ?do 260 | 261 | : QD ?do i loop ; 262 | T{ 789 789 QD -> }T 263 | T{ -9876 -9876 QD -> }T 264 | T{ 5 0 QD -> 0 1 2 3 4 }T 265 | 266 | : QD1 ?do i 10 +loop ; 267 | T{ 50 1 QD1 -> 1 11 21 31 41 }T 268 | T{ 50 0 QD1 -> 0 10 20 30 40 }T 269 | 270 | : QD2 ?do i 3 > if leave else i then loop ; 271 | T{ 5 -1 QD2 -> -1 0 1 2 3 }T 272 | 273 | : QD3 ?do i 1 +loop ; 274 | T{ 4 4 QD3 -> }T 275 | T{ 4 1 QD3 -> 1 2 3 }T 276 | T{ 2 -1 QD3 -> -1 0 1 }T 277 | 278 | : QD4 ?do i -1 +loop ; 279 | T{ 4 4 QD4 -> }T 280 | T{ 1 4 QD4 -> 4 3 2 1 }T 281 | T{ -1 2 QD4 -> 2 1 0 -1 }T 282 | 283 | : QD5 ?do i -10 +loop ; 284 | T{ 1 50 QD5 -> 50 40 30 20 10 }T 285 | T{ 0 50 QD5 -> 50 40 30 20 10 0 }T 286 | T{ -25 10 QD5 -> 10 0 -10 -20 }T 287 | 288 | variable ITERS 289 | variable INcrMNT 290 | 291 | : QD6 ( limit start increment -- ) 292 | INcrMNT ! 293 | 0 ITERS ! 294 | ?do 295 | 1 ITERS +! 296 | i 297 | ITERS @ 6 = if leave then 298 | INcrMNT @ 299 | +loop ITERS @ 300 | ; 301 | 302 | T{ 4 4 -1 QD6 -> 0 }T 303 | T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T 304 | T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T 305 | T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T 306 | T{ 0 0 0 QD6 -> 0 }T 307 | T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T 308 | T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T 309 | T{ 4 1 1 QD6 -> 1 2 3 3 }T 310 | T{ 4 4 1 QD6 -> 0 }T 311 | T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T 312 | T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T 313 | T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T 314 | T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T 315 | T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T 316 | T{ 2 -1 1 QD6 -> -1 0 1 3 }T 317 | 318 | \ ----------------------------------------------------------------------------- 319 | testing buffer: 320 | 321 | skip T{ 8 buffer: BUF:test -> }T 322 | skip T{ BUF:test dup ALIGNED = -> true }T 323 | skip T{ 111 BUF:test ! 222 BUF:test CELL+ ! -> }T 324 | skip T{ BUF:test @ BUF:test CELL+ @ -> 111 222 }T 325 | 326 | \ ----------------------------------------------------------------------------- 327 | testing value to 328 | 329 | T{ 111 value VAL1 -999 value VAL2 -> }T 330 | T{ VAL1 -> 111 }T 331 | T{ VAL2 -> -999 }T 332 | T{ 222 to VAL1 -> }T 333 | T{ VAL1 -> 222 }T 334 | T{ : VD1 VAL1 ; -> }T 335 | T{ VD1 -> 222 }T 336 | T{ : VD2 to VAL2 ; -> }T 337 | T{ VAL2 -> -999 }T 338 | T{ -333 VD2 -> }T 339 | T{ VAL2 -> -333 }T 340 | T{ VAL1 -> 222 }T 341 | T{ 123 value VAL3 immediate VAL3 -> 123 }T 342 | T{ : VD3 VAL3 literal ; VD3 -> 123 }T 343 | 344 | \ ----------------------------------------------------------------------------- 345 | testing case of endof endcase 346 | 347 | : CS1 case 1 of 111 endof 348 | 2 of 222 endof 349 | 3 of 333 endof 350 | >r 999 r> 351 | endcase 352 | ; 353 | 354 | T{ 1 CS1 -> 111 }T 355 | T{ 2 CS1 -> 222 }T 356 | T{ 3 CS1 -> 333 }T 357 | T{ 4 CS1 -> 999 }T 358 | 359 | \ Nested case's 360 | 361 | : CS2 >r case -1 of case r@ 1 of 100 endof 362 | 2 of 200 endof 363 | >r -300 r> 364 | endcase 365 | endof 366 | -2 of case r@ 1 of -99 endof 367 | >r -199 r> 368 | endcase 369 | endof 370 | >r 299 r> 371 | endcase r> drop 372 | ; 373 | 374 | T{ -1 1 CS2 -> 100 }T 375 | T{ -1 2 CS2 -> 200 }T 376 | T{ -1 3 CS2 -> -300 }T 377 | T{ -2 1 CS2 -> -99 }T 378 | T{ -2 2 CS2 -> -199 }T 379 | T{ 0 2 CS2 -> 299 }T 380 | 381 | \ Boolean short circuiting using case 382 | 383 | : CS3 ( N1 -- N2 ) 384 | case 1- false of 11 endof 385 | 1- false of 22 endof 386 | 1- false of 33 endof 387 | 44 swap 388 | endcase 389 | ; 390 | 391 | T{ 1 CS3 -> 11 }T 392 | T{ 2 CS3 -> 22 }T 393 | T{ 3 CS3 -> 33 }T 394 | T{ 9 CS3 -> 44 }T 395 | 396 | \ Empty case statements with/without default 397 | 398 | T{ : CS4 case endcase ; 1 CS4 -> }T 399 | T{ : CS5 case 2 swap endcase ; 1 CS5 -> 2 }T 400 | T{ : CS6 case 1 of endof 2 endcase ; 1 CS6 -> }T 401 | T{ : CS7 case 3 of endof 2 endcase ; 1 CS7 -> 1 }T 402 | 403 | \ ----------------------------------------------------------------------------- 404 | testing :noname recurse 405 | 406 | variable NN1 407 | variable NN2 408 | :noname 1234 ; NN1 ! 409 | :noname 9876 ; NN2 ! 410 | T{ NN1 @ execute -> 1234 }T 411 | T{ NN2 @ execute -> 9876 }T 412 | 413 | T{ :noname ( n -- 0,1,..n ) dup if dup >r 1- recurse r> then ; 414 | constant RN1 -> }T 415 | T{ 0 RN1 execute -> 0 }T 416 | T{ 4 RN1 execute -> 0 1 2 3 4 }T 417 | 418 | :noname ( n -- n1 ) \ Multiple RECURSEs in one definition 419 | 1- dup 420 | case 0 of exit endof 421 | 1 of 11 swap recurse endof 422 | 2 of 22 swap recurse endof 423 | 3 of 33 swap recurse endof 424 | drop abs recurse exit 425 | endcase 426 | ; constant RN2 427 | 428 | T{ 1 RN2 execute -> 0 }T 429 | T{ 2 RN2 execute -> 11 0 }T 430 | T{ 4 RN2 execute -> 33 22 11 0 }T 431 | T{ 25 RN2 execute -> 33 22 11 0 }T 432 | 433 | \ ----------------------------------------------------------------------------- 434 | testing C" 435 | 436 | skip T{ : CQ1 C" 123" ; -> }T 437 | skip T{ CQ1 count evaluate -> 123 }T 438 | skip T{ : CQ2 C" " ; -> }T 439 | skip T{ CQ2 count evaluate -> }T 440 | skip T{ : CQ3 C" 2345"count evaluate ; CQ3 -> 2345 }T 441 | 442 | \ ----------------------------------------------------------------------------- 443 | testing compile, 444 | 445 | :noname dup + ; constant dup+ 446 | T{ : Q dup+ compile, ; -> }T 447 | T{ : AS1 [ Q ] ; -> }T 448 | T{ 123 AS1 -> 246 }T 449 | 450 | \ ----------------------------------------------------------------------------- 451 | \ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source 452 | 453 | testing SAVE-INPUT and RESTORE-INPUT with a string source 454 | 455 | variable SI_INC 0 SI_INC ! 456 | 457 | : SI1 458 | SI_INC @ >in +! 459 | 15 SI_INC ! 460 | ; 461 | 462 | : s$ s" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; 463 | 464 | skip T{ s$ evaluate SI_INC @ -> 0 2345 15 }T 465 | 466 | \ ----------------------------------------------------------------------------- 467 | testing .( 468 | 469 | cr cr .( Output from .() 470 | T{ cr .( You should see -9876: ) -9876 . -> }T 471 | T{ cr .( and again: ).( -9876)cr -> }T 472 | 473 | cr cr .( On the next 2 lines you should see First then Second messages:) 474 | T{ : DOTP cr ." Second message via ." [char] " emit \ Check .( is immediate 475 | [ cr ] .( First message via .( ) ; DOTP -> }T 476 | cr cr 477 | skip T{ : IMM? word throw find nip ; IMM? .( -> 1 }T 478 | 479 | \ ----------------------------------------------------------------------------- 480 | testing .r and u.r - has to handle different cell sizes 481 | 482 | \ Create some large integers just below/above MAX and Min INTs 483 | \ max-int 73 79 */ constant LI1 484 | \ min-int 71 73 */ constant LI2 485 | \ 486 | \ LI1 0 <# #S #> nip constant LENLI1 487 | 488 | \ : (.r&u.r) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation 489 | \ tuck + >r 490 | \ LI1 over SPACES . cr r@ LI1 swap .r cr 491 | \ LI2 over SPACES . cr r@ 1+ LI2 swap .r cr 492 | \ LI1 over SPACES u. cr r@ LI1 swap u.r cr 493 | \ LI2 swap SPACES u. cr r> LI2 swap u.r cr 494 | \ ; 495 | \ 496 | \ : .r&u.r ( -- ) 497 | \ cr ." You should see lines duplicated:" cr 498 | \ ." indented by 0 spaces" cr 0 0 (.r&u.r) cr 499 | \ ." indented by 0 spaces" cr LENLI1 0 (.r&u.r) cr \ Just fits required width 500 | \ ." indented by 5 spaces" cr LENLI1 5 (.r&u.r) cr 501 | \ ; 502 | \ 503 | \ cr cr .( Output from .r and u.r) 504 | skip T{ .r&u.r -> }T 505 | 506 | \ ----------------------------------------------------------------------------- 507 | testing pad erase 508 | \ Must handle different size characters i.e. 1 chars >= 1 509 | 510 | 84 constant chars/pad \ Minimum size of pad in chars 511 | chars/pad chars constant AUS/pad 512 | : checkpad ( caddr u ch -- f ) \ f = true if u chars = ch 513 | swap 0 514 | ?do 515 | over i chars + c@ over <> 516 | if 2drop unloop false exit then 517 | loop 518 | 2drop true 519 | ; 520 | 521 | skip T{ pad drop -> }T 522 | skip T{ 0 invert pad C! -> }T 523 | skip T{ pad c@ constant MAXCHAR -> }T 524 | skip T{ pad chars/pad 2DUP MAXCHAR FILL MAXCHAR checkpad -> true }T 525 | skip T{ pad chars/pad 2DUP chars erase 0 checkpad -> true }T 526 | skip T{ pad chars/pad 2DUP MAXCHAR FILL pad 0 erase MAXCHAR checkpad -> true }T 527 | skip T{ pad 43 chars + 9 chars erase -> }T 528 | skip T{ pad 43 MAXCHAR checkpad -> true }T 529 | skip T{ pad 43 chars + 9 0 checkpad -> true }T 530 | skip T{ pad 52 chars + chars/pad 52 - MAXCHAR checkpad -> true }T 531 | 532 | \ Check that use of word and pictured numeric output do not corrupt pad 533 | \ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively 534 | \ where n is number of bits per cell 535 | 536 | \ pad chars/pad erase 537 | \ 2 base ! 538 | \ max-uint max-uint <# #S char 1 dup hold hold #> 2drop 539 | \ decimal 540 | \ bl word 12345678123456781234567812345678 drop 541 | skip T{ pad chars/pad 0 checkpad -> true }T 542 | 543 | \ ----------------------------------------------------------------------------- 544 | testing parse 545 | 546 | skip T{ char | parse 1234| dup rot rot evaluate -> 4 1234 }T 547 | skip T{ char ^ parse 23 45 ^ dup rot rot evaluate -> 7 23 45 }T 548 | \ : PA1 [char] $ parse dup >r pad swap chars MOVE pad r> ; 549 | skip T{ PA1 3456 550 | skip dup rot rot evaluate -> 4 3456 }T 551 | skip T{ char A parse A swap drop -> 0 }T 552 | skip T{ char Z parse 553 | skip swap drop -> 0 }T 554 | skip T{ char " parse 4567 "dup rot rot evaluate -> 5 4567 }T 555 | 556 | \ ----------------------------------------------------------------------------- 557 | testing parse-name (Forth 2012) 558 | \ Adapted from the parse-name RfD tests 559 | 560 | skip T{ parse-name abcd STR1 S= -> true }T \ No leading spaces 561 | skip T{ parse-name abcde STR2 S= -> true }T \ Leading spaces 562 | 563 | \ Test empty parse area, new lines are necessary 564 | skip T{ parse-name 565 | skip nip -> 0 }T 566 | \ Empty parse area with spaces after parse-name 567 | skip T{ parse-name 568 | skip nip -> 0 }T 569 | 570 | skip T{ : parse-name-test ( "name1" "name2" -- n ) 571 | skip parse-name parse-name S= ; -> }T 572 | skip T{ parse-name-test abcd abcd -> true }T 573 | skip T{ parse-name-test abcd abcd -> true }T \ Leading spaces 574 | skip T{ parse-name-test abcde abcdf -> false }T 575 | skip T{ parse-name-test abcdf abcde -> false }T 576 | skip T{ parse-name-test abcde abcde 577 | skip -> true }T \ Parse to end of line 578 | skip T{ parse-name-test abcde abcde 579 | skip -> true }T \ Leading and trailing spaces 580 | 581 | \ ----------------------------------------------------------------------------- 582 | testing defer defer@ defer! is action-of (Forth 2012) 583 | \ Adapted from the Forth 200X RfD tests 584 | 585 | skip T{ defer defer1 -> }T 586 | skip T{ : MY-defer defer ; -> }T 587 | skip T{ : is-defer1 is defer1 ; -> }T 588 | skip T{ : action-defer1 action-of defer1 ; -> }T 589 | skip T{ : DEF! defer! ; -> }T 590 | skip T{ : DEF@ defer@ ; -> }T 591 | 592 | skip T{ ' * ' defer1 defer! -> }T 593 | skip T{ 2 3 defer1 -> 6 }T 594 | skip T{ ' defer1 defer@ -> ' * }T 595 | skip T{ ' defer1 DEF@ -> ' * }T 596 | skip T{ action-of defer1 -> ' * }T 597 | skip T{ action-defer1 -> ' * }T 598 | skip T{ ' + is defer1 -> }T 599 | skip T{ 1 2 defer1 -> 3 }T 600 | skip T{ ' defer1 defer@ -> ' + }T 601 | skip T{ ' defer1 DEF@ -> ' + }T 602 | skip T{ action-of defer1 -> ' + }T 603 | skip T{ action-defer1 -> ' + }T 604 | skip T{ ' - is-defer1 -> }T 605 | skip T{ 1 2 defer1 -> -1 }T 606 | skip T{ ' defer1 defer@ -> ' - }T 607 | skip T{ ' defer1 DEF@ -> ' - }T 608 | skip T{ action-of defer1 -> ' - }T 609 | skip T{ action-defer1 -> ' - }T 610 | 611 | skip T{ MY-defer defer2 -> }T 612 | skip T{ ' dup is defer2 -> }T 613 | skip T{ 1 defer2 -> 1 1 }T 614 | 615 | \ ----------------------------------------------------------------------------- 616 | testing holds (Forth 2012) 617 | 618 | : htest s" Testing holds" ; 619 | : htest2 s" works" ; 620 | : htest3 s" Testing holds works 123" ; 621 | skip T{ 0 0 <# htest holds #> htest S= -> true }T 622 | skip T{ 123 0 <# #S bl hold htest2 holds bl hold htest holds #> 623 | skip htest3 S= -> true }T 624 | skip T{ : HLD holds ; -> }T 625 | skip T{ 0 0 <# htest HLD #> htest S= -> true }T 626 | 627 | \ ----------------------------------------------------------------------------- 628 | testing refill source-id 629 | \ refill and source-id from the user input device can't be tested from a file, 630 | \ can only be tested from a string via evaluate 631 | 632 | skip T{ : RF1 s" refill" evaluate ; RF1 -> false }T 633 | skip T{ : SID1 s" source-id" evaluate ; SID1 -> -1 }T 634 | 635 | \ ------------------------------------------------------------------------------ 636 | testing s\" (Forth 2012 compilation mode) 637 | \ Extended the Forth 200X RfD tests 638 | \ Note this tests the Core Ext definition of s\" which has unedfined 639 | \ interpretation semantics. s\" in interpretation mode is tested in the tests on 640 | \ the File-Access word set 641 | 642 | skip T{ : SSQ1 s\" abc" s" abc" S= ; -> }T \ No escapes 643 | skip T{ SSQ1 -> true }T 644 | skip T{ : SSQ2 s\" " ; SSQ2 swap drop -> 0 }T \ Empty string 645 | 646 | skip T{ : SSQ3 s\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T 647 | skip T{ SSQ3 swap drop -> 20 }T \ String length 648 | skip T{ SSQ3 drop c@ -> 7 }T \ \a BEL Bell 649 | skip T{ SSQ3 drop 1 chars + c@ -> 8 }T \ \b BS Backspace 650 | skip T{ SSQ3 drop 2 chars + c@ -> 27 }T \ \e ESC Escape 651 | skip T{ SSQ3 drop 3 chars + c@ -> 12 }T \ \f FF Form feed 652 | skip T{ SSQ3 drop 4 chars + c@ -> 10 }T \ \l LF Line feed 653 | skip T{ SSQ3 drop 5 chars + c@ -> 13 }T \ \m cr of cr/LF pair 654 | skip T{ SSQ3 drop 6 chars + c@ -> 10 }T \ LF of cr/LF pair 655 | skip T{ SSQ3 drop 7 chars + c@ -> 34 }T \ \q " Double Quote 656 | skip T{ SSQ3 drop 8 chars + c@ -> 13 }T \ \r cr Carriage Return 657 | skip T{ SSQ3 drop 9 chars + c@ -> 9 }T \ \t TAB Horizontal Tab 658 | skip T{ SSQ3 drop 10 chars + c@ -> 11 }T \ \v VT Vertical Tab 659 | skip T{ SSQ3 drop 11 chars + c@ -> 15 }T \ \x0F Given Char 660 | skip T{ SSQ3 drop 12 chars + c@ -> 48 }T \ 0 0 Digit follow on 661 | skip T{ SSQ3 drop 13 chars + c@ -> 31 }T \ \x1F Given Char 662 | skip T{ SSQ3 drop 14 chars + c@ -> 97 }T \ a a Hex follow on 663 | skip T{ SSQ3 drop 15 chars + c@ -> 171 }T \ \xaB Insensitive Given Char 664 | skip T{ SSQ3 drop 16 chars + c@ -> 120 }T \ x x Non hex follow on 665 | skip T{ SSQ3 drop 17 chars + c@ -> 0 }T \ \z NUL No Character 666 | skip T{ SSQ3 drop 18 chars + c@ -> 34 }T \ \" " Double Quote 667 | skip T{ SSQ3 drop 19 chars + c@ -> 92 }T \ \\ \ Back Slash 668 | 669 | \ The above does not test \n as this is a system dependent value. 670 | \ Check it displays a new line 671 | cr .( The next test should display:) 672 | cr .( One line...) 673 | cr .( another line) 674 | skip T{ : SSQ4 s\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T 675 | 676 | skip \ Test bare escapable characters appear as themselves 677 | skip T{ : SSQ5 s\" abeflmnqrtvxz" s" abeflmnqrtvxz" S= ; SSQ5 -> true }T 678 | 679 | skip T{ : SSQ6 s\" a\""2drop 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour 680 | 681 | skip T{ : SSQ7 s\" 111 : SSQ8 S\\\" 222\" evaluate ; SSQ8 333" evaluate ; -> }T 682 | skip T{ SSQ7 -> 111 222 333 }T 683 | skip T{ : SSQ9 s\" 11 : SSQ10 S\\\" \\x32\\x32\" evaluate ; SSQ10 33" evaluate ; -> }T 684 | skip T{ SSQ9 -> 11 22 33 }T 685 | 686 | \ ----------------------------------------------------------------------------- 687 | 688 | cr .( End of Core Extension word tests) cr 689 | 690 | 691 | -------------------------------------------------------------------------------- /test/coreplustest.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | decimal 8 | 9 | testing do +loop with run-time increment, negative increment, infinite loop 10 | \ Contributed by Reinhold Straub 11 | 12 | variable iterations 13 | variable increment 14 | : gd7 ( limit start increment -- ) 15 | increment ! 16 | 0 iterations ! 17 | do 18 | 1 iterations +! 19 | i 20 | iterations @ 6 = if leave then 21 | increment @ 22 | +loop iterations @ 23 | ; 24 | 25 | T{ 4 4 -1 gd7 -> 4 1 }T 26 | T{ 1 4 -1 gd7 -> 4 3 2 1 4 }T 27 | T{ 4 1 -1 gd7 -> 1 0 -1 -2 -3 -4 6 }T 28 | T{ 4 1 0 gd7 -> 1 1 1 1 1 1 6 }T 29 | T{ 0 0 0 gd7 -> 0 0 0 0 0 0 6 }T 30 | T{ 1 4 0 gd7 -> 4 4 4 4 4 4 6 }T 31 | T{ 1 4 1 gd7 -> 4 5 6 7 8 9 6 }T 32 | T{ 4 1 1 gd7 -> 1 2 3 3 }T 33 | T{ 4 4 1 gd7 -> 4 5 6 7 8 9 6 }T 34 | T{ 2 -1 -1 gd7 -> -1 -2 -3 -4 -5 -6 6 }T 35 | T{ -1 2 -1 gd7 -> 2 1 0 -1 4 }T 36 | T{ 2 -1 0 gd7 -> -1 -1 -1 -1 -1 -1 6 }T 37 | T{ -1 2 0 gd7 -> 2 2 2 2 2 2 6 }T 38 | T{ -1 2 1 gd7 -> 2 3 4 5 6 7 6 }T 39 | T{ 2 -1 1 gd7 -> -1 0 1 3 }T 40 | T{ -20 30 -10 gd7 -> 30 20 10 0 -10 -20 6 }T 41 | T{ -20 31 -10 gd7 -> 31 21 11 1 -9 -19 6 }T 42 | T{ -20 29 -10 gd7 -> 29 19 9 -1 -11 5 }T 43 | 44 | \ ------------------------------------------------------------------------------ 45 | testing do +loop with large and small increments 46 | 47 | \ Contributed by Andrew Haley 48 | 49 | max-uint 8 rshift 1+ constant ustep 50 | ustep negate constant -ustep 51 | max-int 7 rshift 1+ constant step 52 | step negate constant -step 53 | 54 | variable bump 55 | 56 | T{ : gd8 bump ! do 1+ bump @ +loop ; -> }T 57 | T{ 0 max-uint 0 ustep gd8 -> 256 }T 58 | T{ 0 0 max-uint -ustep gd8 -> 256 }T 59 | 60 | T{ 0 max-int min-int step gd8 -> 256 }T 61 | T{ 0 min-int max-int -step gd8 -> 256 }T 62 | 63 | \ Two's complement arithmetic, wraps around modulo wordsize 64 | \ Only tested if the Forth system does wrap around, use of conditional 65 | \ compilation deliberately avoided 66 | 67 | max-int 1+ min-int = constant +wrap? 68 | min-int 1- max-int = constant -wrap? 69 | max-uint 1+ 0= constant +uwrap? 70 | 0 1- max-uint = constant -uwrap? 71 | 72 | : gd9 ( n limit start step f result -- ) 73 | >r if gd8 else 2drop 2drop r@ then -> r> }T 74 | ; 75 | 76 | T{ 0 0 0 ustep +uwrap? 256 gd9 77 | T{ 0 0 0 -ustep -uwrap? 1 gd9 78 | T{ 0 min-int max-int step +wrap? 1 gd9 79 | T{ 0 max-int min-int -step -wrap? 1 gd9 80 | 81 | \ ------------------------------------------------------------------------------ 82 | testing do +loop with maximum and minimum increments 83 | 84 | : (-mi) max-int dup negate + 0= if max-int negate else -32767 then ; 85 | (-mi) constant -max-int 86 | 87 | T{ 0 1 0 max-int gd8 -> 1 }T 88 | T{ 0 -max-int negate -max-int over gd8 -> 2 }T 89 | 90 | T{ 0 max-int 0 max-int gd8 -> 1 }T 91 | T{ 0 max-int 1 max-int gd8 -> 1 }T 92 | T{ 0 max-int -1 max-int gd8 -> 2 }T 93 | T{ 0 max-int dup 1- max-int gd8 -> 1 }T 94 | 95 | T{ 0 min-int 1+ 0 min-int gd8 -> 1 }T 96 | T{ 0 min-int 1+ -1 min-int gd8 -> 1 }T 97 | T{ 0 min-int 1+ 1 min-int gd8 -> 2 }T 98 | T{ 0 min-int 1+ dup min-int gd8 -> 1 }T 99 | 100 | \ ------------------------------------------------------------------------------ 101 | \ testing +loop Setting i to an arbitrary value 102 | 103 | \ The specification for +loop permits the loop index i to be set to any value 104 | \ including a value outside the range given to the corresponding do. 105 | 106 | \ set-i is a helper to set i in a do ... +loop to a given value 107 | \ n2 is the value of i in a do ... +loop 108 | \ n3 is a test value 109 | \ If n2=n3 then return n1-n2 else return 1 110 | : set-i ( n1 n2 n3 -- n1-n2 | 1 ) 111 | over = if - else 2drop 1 then 112 | ; 113 | 114 | : -set-i ( n1 n2 n3 -- n1-n2 | -1 ) 115 | set-i dup 1 = if negate then 116 | ; 117 | 118 | : pl1 20 1 do i 18 i 3 set-i +loop ; 119 | T{ pl1 -> 1 2 3 18 19 }T 120 | : pl2 20 1 do i 20 i 2 set-i +loop ; 121 | T{ pl2 -> 1 2 }T 122 | : pl3 20 5 do i 19 i 2 set-i dup 1 = if drop 0 i 6 set-i then +loop ; 123 | T{ pl3 -> 5 6 0 1 2 19 }T 124 | : pl4 20 1 do i max-int i 4 set-i +loop ; 125 | T{ pl4 -> 1 2 3 4 }T 126 | : pl5 -20 -1 do i -19 i -3 -set-i +loop ; 127 | T{ pl5 -> -1 -2 -3 -19 -20 }T 128 | : pl6 -20 -1 do i -21 i -4 -set-i +loop ; 129 | T{ pl6 -> -1 -2 -3 -4 }T 130 | : pl7 -20 -1 do i min-int i -5 -set-i +loop ; 131 | T{ pl7 -> -1 -2 -3 -4 -5 }T 132 | : pl8 -20 -5 do i -20 i -2 -set-i dup -1 = if drop 0 i -6 -set-i then +loop ; 133 | T{ pl8 -> -5 -6 0 -1 -2 -20 }T 134 | 135 | \ ------------------------------------------------------------------------------ 136 | testing multiple recurses in one colon definition 137 | 138 | : ack ( M N -- U ) \ Ackermann function, from Rosetta Code 139 | over 0= if nip 1+ exit then \ ack(0, n) = n+1 140 | swap 1- swap ( -- m-1 n ) 141 | dup 0= if 1+ recurse exit then \ ack(m, 0) = ack(m-1, 1) 142 | 1- over 1+ swap recurse recurse \ ack(m, n) = ack(m-1, ack(m,n-1)) 143 | ; 144 | 145 | T{ 0 0 ack -> 1 }T 146 | T{ 3 0 ack -> 5 }T 147 | T{ 2 4 ack -> 11 }T 148 | 149 | \ ------------------------------------------------------------------------------ 150 | testing multiple else's in an if statement 151 | \ Discussed on comp.lang.forth and accepted as valid ANS Forth 152 | 153 | : melse if 1 else 2 else 3 else 4 else 5 then ; 154 | T{ 0 melse -> 2 4 }T 155 | T{ -1 melse -> 1 3 5 }T 156 | 157 | \ ------------------------------------------------------------------------------ 158 | testing manipulation of >in in interpreter mode 159 | 160 | T{ 12345 depth over 9 < 32 * + 3 + >in ! -> 12345 2345 345 45 5 }T 161 | T{ 14145 8115 ?dup 0= 33 * >in +! tuck mod 14 >in ! gcd calculation -> 15 }T 162 | 163 | \ ------------------------------------------------------------------------------ 164 | testing immediate with constant variable and create [ ... does> ] 165 | 166 | T{ 123 constant iw1 immediate iw1 -> 123 }T 167 | T{ : iw2 iw1 literal ; iw2 -> 123 }T 168 | T{ variable iw3 immediate 234 iw3 ! iw3 @ -> 234 }T 169 | T{ : iw4 iw3 [ @ ] literal ; iw4 -> 234 }T 170 | T{ :noname [ 345 ] iw3 [ ! ] ; drop iw3 @ -> 345 }T 171 | T{ create iw5 456 , immediate -> }T 172 | T{ :noname iw5 [ @ iw3 ! ] ; drop iw3 @ -> 456 }T 173 | T{ : iw6 create , immediate does> @ 1+ ; -> }T 174 | T{ 111 iw6 iw7 iw7 -> 112 }T 175 | T{ : iw8 iw7 literal 1+ ; iw8 -> 113 }T 176 | T{ : iw9 create , does> @ 2 + immediate ; -> }T 177 | \ : find-iw bl word find nip ; ( -- 0 | 1 | -1 ) 178 | skip T{ 222 iw9 iw10 find-iw iw10 -> -1 }T \ iw10 IS NOT IMMEDIATE 179 | skip T{ iw10 find-iw iw10 -> 224 1 }T \ iw10 BECOMES IMMEDIATE 180 | 181 | \ ------------------------------------------------------------------------------ 182 | testing that immediate doesn't toggle a flag 183 | 184 | variable it1 0 it1 ! 185 | : it2 1234 it1 ! ; immediate immediate 186 | T{ : it3 it2 ; it1 @ -> 1234 }T 187 | 188 | \ ------------------------------------------------------------------------------ 189 | testing parsing behaviour of s" ." and ( 190 | \ which should parse to just beyond the terminating character no space needed 191 | 192 | T{ : gc5 s" A string"drop ; gc5 -> }T 193 | T{ ( A comment)1234 -> 1234 }T 194 | T{ : pb1 cr ." You should see 2345: "." 2345"( A comment) cr ; pb1 -> }T 195 | 196 | \ ------------------------------------------------------------------------------ 197 | testing number prefixes # $ % and 'c' character input 198 | \ Adapted from the Forth 200X Draft 14.5 document 199 | 200 | variable old-base 201 | decimal base @ old-base ! 202 | T{ #1289 -> 1289 }T 203 | T{ #-1289 -> -1289 }T 204 | T{ $12eF -> 4847 }T 205 | T{ $-12eF -> -4847 }T 206 | T{ %10010110 -> 150 }T 207 | T{ %-10010110 -> -150 }T 208 | T{ 'z' -> 122 }T 209 | T{ 'Z' -> 90 }T 210 | \ Check base is unchanged 211 | T{ base @ old-base @ = -> }T 212 | 213 | \ rEPEAT IN hEX MODE 214 | 16 old-base ! 16 base ! 215 | T{ #1289 -> 509 }T 216 | T{ #-1289 -> -509 }T 217 | T{ $12eF -> 12ef }T 218 | T{ $-12eF -> -12ef }T 219 | T{ %10010110 -> 96 }T 220 | T{ %-10010110 -> -96 }T 221 | T{ 'z' -> 7A }T 222 | T{ 'Z' -> 5A }T 223 | \ Check BASE is unchanged 224 | T{ base @ old-base @ = -> }T \ 2 225 | 226 | decimal 227 | \ Check number prefixes in compile mode 228 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T 229 | 230 | \ ------------------------------------------------------------------------------ 231 | testing definition names 232 | \ should support {1..31} graphical characters 233 | : !"#$%&'()*+,-./0123456789:;<=>? 1 ; 234 | T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T 235 | : @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; 236 | T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T 237 | : _`abcdefghijklmnopqrstuvwxyz{|} 3 ; 238 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 239 | : _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different 240 | T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T 241 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 242 | 243 | \ ------------------------------------------------------------------------------ 244 | testing find with a zero length string and a non-existent word 245 | 246 | \ create emptystring 0 c, 247 | \ : emptystring-find-check ( C-ADDR 0 | XT 1 | XT -1 -- T|F ) 248 | \ dup if ." FIND returns a TRUE value for an empty string!" cr then 249 | \ 0= swap emptystring = = ; 250 | skip T{ emptystring find emptystring-find-check -> }T 251 | 252 | \ create non-existent-word \ Same as in exceptiontest.fth 253 | \ 15 c, char $ c, char $ c, char q c, char w c, char e c, char q c, 254 | \ char w c, char e c, char q c, char w c, char e c, char r c, char t c, 255 | \ char $ c, char $ c, 256 | skip T{ non-existent-word find -> non-existent-word 0 }T 257 | 258 | \ ------------------------------------------------------------------------------ 259 | testing if ... begin ... repeat (unstructured) 260 | 261 | T{ : uns1 dup 0 > if 9 swap begin 1+ dup 3 > if exit then repeat ; -> }T 262 | T{ -6 uns1 -> -6 }T 263 | T{ 1 uns1 -> 9 4 }T 264 | 265 | \ ------------------------------------------------------------------------------ 266 | testing does> doesn't cause a problem with a created address 267 | 268 | \ : make-2const does> 2@ ; 269 | skip T{ create 2k 3 , 2k , make-2const 2k -> ' 2k >body 3 }T 270 | 271 | \ ------------------------------------------------------------------------------ 272 | testing allot ( n -- ) where n <= 0 273 | 274 | T{ here 5 allot -5 allot here = -> }T 275 | T{ here 0 allot here = -> }T 276 | 277 | \ ------------------------------------------------------------------------------ 278 | 279 | cr ." End of additional Core tests" cr 280 | -------------------------------------------------------------------------------- /test/export.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | testing private and export 5 | 6 | : f1 ; 7 | private{ 8 | 9 | : f2 ; 10 | 11 | T{ defined? f1 -> true }T 12 | T{ defined? f2 -> true }T 13 | 14 | private{ 15 | 16 | : f3 ; 17 | 18 | T{ defined? f2 -> true }T 19 | T{ defined? f3 -> true }T 20 | 21 | }private 22 | 23 | T{ defined? f1 -> true }T 24 | T{ defined? f2 -> true }T 25 | T{ defined? f3 -> false }T 26 | 27 | }private 28 | 29 | T{ defined? f1 -> true }T 30 | T{ defined? f2 -> false }T 31 | T{ defined? f3 -> false }T 32 | -------------------------------------------------------------------------------- /test/fileio-test0.txt: -------------------------------------------------------------------------------- 1 | ABCDEFGHIJKLMNOPQRSTUVWXYZ 2 | -------------------------------------------------------------------------------- /test/fileio.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | testing file I/O 5 | 6 | T{ 7 | s" test/fileio-test0.txt" R/O open-file throw 8 | constant FILE0 -> 9 | }T 10 | T{ 32 allocate throw constant BUF -> }T 11 | T{ BUF 32 FILE0 read-file throw -> 27 }T 12 | T{ s" ABCDEFGHIJKLMNOPQRSTUVWXYZ\n" BUF 27 strneq -> true }T 13 | T{ FILE0 close-file throw -> }T 14 | T{ BUF free -> }T 15 | -------------------------------------------------------------------------------- /test/utilities.fs: -------------------------------------------------------------------------------- 1 | \ planckforth - 2 | \ Copyright (C) 2021 nineties 3 | 4 | \ test/tester.fs and test codes are base on 5 | \ https://github.com/gerryjackson/forth2012-test-suite 6 | 7 | decimal 8 | 9 | ( First a definition to see if a word is already defined. Note that ) 10 | ( [defined] [if] [else] and [then] are in the optional Programming Tools ) 11 | ( word set. ) 12 | 13 | variable (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = 1 ) 14 | 15 | ( [?def] followed by [?if] cannot be used again until after [then] ) 16 | : [?def] ( "name" -- ) 17 | word throw find 0= (\?) ! 18 | ; 19 | 20 | \ Test [?def] 21 | T{ 0 (\?) ! [?def] ?deftest1 (\?) @ -> 1 }T 22 | : ?deftest1 1 ; 23 | T{ -1 (\?) ! [?def] ?deftest1 (\?) @ -> 0 }T 24 | 25 | : [?undef] [?def] (\?) @ 0= (\?) ! ; 26 | 27 | \ Equivalents of [if] [else] [then], these must not be nested 28 | : [?if] ( f -- ) (\?) ! ; immediate 29 | : [?else] ( -- ) (\?) @ 0= (\?) ! ; immediate 30 | : [?then] ( -- ) 0 (\?) ! ; immediate 31 | 32 | ( A conditional comment and \ will be defined. Note that these definitions ) 33 | ( are inadequate for use in Forth blocks. If needed in the blocks test ) 34 | ( program they will need to be modified here or redefined there ) 35 | 36 | ( \? is a conditional comment ) 37 | : \? ( "..." -- ) (\?) @ if exit then source strlen >in ! ; immediate 38 | 39 | \ Test \? 40 | T{ [?def] ?deftest1 \? : ?deftest1 2 ; \ Should not be redefined 41 | ?deftest1 -> 1 }T 42 | T{ [?def] ?deftest2 \? : ?deftest1 2 ; \ Should be redefined 43 | ?deftest1 -> 2 }T 44 | 45 | [?def] true \? 1 constant true 46 | [?def] false \? 0 constant false 47 | [?def] nip \? : nip swap drop ; 48 | [?def] tuck \? : tuck swap over ; 49 | 50 | ( source R:c ) 51 | [?def] parse 52 | \? : parse ( ch "ccc" -- caddr u ) 53 | \? >r source >in @ + ( start ) 54 | \? dup r> swap >r >r ( start, R: start ch ) 55 | \? begin 56 | \? dup c@ 57 | \? while 58 | \? dup c@ r@ <> 59 | \? while 60 | \? 1+ 61 | \? repeat 62 | \? dup source - 1+ >in ! 63 | \? r> drop r> tuck - 1 / 64 | \? ; 65 | 66 | [?def] .( \? : .( [char] ) parse typen ; immediate 67 | 68 | \ \ s= to compare (case sensitive) two strings to avoid use of COMPARE from 69 | \ \ the String word set. It is defined in core.fr and conditionally defined 70 | \ \ here if core.fr has not been included by the user 71 | \ 72 | \ [?def] s= 73 | \ \? : s= ( caddr1 u1 caddr2 u2 -- f ) \ f = true if strings are equal 74 | \ \? rot over = 0= if drop 2drop false exit then 75 | \ \? dup 0= if drop 2drop true exit then 76 | \ \? 0 do 77 | \ \? over c@ over c@ = 0= if 2drop false unloop exit then 78 | \ \? char+ swap char+ 79 | \ \? loop 2drop true 80 | \ \? ; 81 | \ 82 | \ \ Buffer for strings in interpretive mode since s" only valid in compilation 83 | \ \ mode when File-Access word set is defined 84 | \ 85 | \ 64 constant sbuf-size 86 | \ create sbuf1 sbuf-size chars allot 87 | \ create sbuf2 sbuf-size chars allot 88 | \ 89 | \ \ ($") saves string at (caddr) 90 | \ : ($") ( caddr "ccc" -- caddr' ) 91 | \ [char] " parse rot 2dup c! ( -- ca2 u2 ca) 92 | \ char+ swap 2dup 2>r chars move ( -- ) ( R: -- ca' u2 ) 93 | \ 2r> 94 | \ ; 95 | \ 96 | \ : $" ( "ccc" -- caddr u ) sbuf1 ($") ; 97 | \ : $2" ( "ccc" -- caddr u ) sbuf2 ($") ; 98 | \ : $clear ( caddr -- ) sbuf-size bl fill ; 99 | \ : clear-sbufs ( -- ) sbuf1 $clear sbuf2 $clear ; 100 | \ 101 | \ \ More definitions in core.fr used in other test programs, conditionally 102 | \ \ defined here if core.fr has not been loaded 103 | \ 104 | \ [?def] max-uint \? 0 invert constant max-uint 105 | \ [?def] max-int \? 0 invert 1 rshift constant max-int 106 | \ [?def] min-int \? 0 invert 1 rshift invert constant min-int 107 | \ [?def] mid-uint \? 0 invert 1 rshift constant mid-uint 108 | \ [?def] mid-uint+1 \? 0 invert 1 rshift invert constant mid-uint+1 109 | \ 110 | \ [?def] 2constant \? : 2constant create , , does> 2@ ; 111 | \ 112 | \ base @ 2 base ! -1 0 <# #S #> swap drop constant bits/cell base ! 113 | \ 114 | \ 115 | \ \ ------------------------------------------------------------------------------ 116 | \ \ Tests 117 | \ 118 | \ : str1 s" abcd" ; : str2 s" abcde" ; 119 | \ : str3 s" abCd" ; : str4 s" wbcd" ; 120 | \ : s"" s" " ; 121 | \ 122 | \ T{ str1 2dup s= -> true }T 123 | \ T{ str2 2dup s= -> true }T 124 | \ T{ s"" 2dup s= -> true }T 125 | \ T{ str1 str2 s= -> false }T 126 | \ T{ str1 str3 s= -> false }T 127 | \ T{ str1 str4 s= -> false }T 128 | \ 129 | \ T{ clear-sbufs -> }T 130 | \ T{ $" abcdefghijklm" sbuf1 count s= -> true }T 131 | \ T{ $" nopqrstuvwxyz" sbuf2 over s= -> false }T 132 | \ T{ $2" abcdefghijklm" sbuf1 count s= -> false }T 133 | \ T{ $2" nopqrstuvwxyz" sbuf1 count s= -> true }T 134 | \ 135 | \ \ ------------------------------------------------------------------------------ 136 | \ 137 | \ CR $" Test utilities loaded" type CR 138 | --------------------------------------------------------------------------------