├── .gitignore ├── README.md ├── build.sh ├── image-files ├── coreext.frt ├── coretest.frt ├── cpp.frt ├── stage1.frt ├── test.c └── test.frt ├── run.sh └── stage0.s /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | gen 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 2K Linux 2 | 3 | A Linux distribution that was supposed to bootstrap from a 2 kilobyte binary (and a pile of source code). 4 | 5 | Current status: a Forth system that reads its source from FAT32, and chunks of 6 | a C preprocessor. 7 | 8 | ## Deprecation warning 9 | 10 | After a while, I realized that this approach is not ideal, because while 11 | booting from source code fully automatically makes for a nice demo, it doesn't 12 | have any way of inspecting what happens along the way, which is the reason 13 | bootstrapping is appealing. 14 | 15 | I am currently approaching this problem from another angle with 16 | [miniforth](https://github.com/NieDzejkob/miniforth), which has the added benefit 17 | of a seed binary that's only 512 bytes, and enables interactive development with 18 | nothing else on disk. 19 | 20 | ## Testing 21 | 22 | You'll need: 23 | - `yasm` or `nasm` 24 | - `mtools` 25 | - `bash` 26 | - `sfdisk` 27 | - GNU coreutils 28 | - an emulator like QEMU or bochs if you are not brave enough to run it on hardware. 29 | 30 | Run the `build.sh` script to generate a disk image called `gen/2klinux.img`. You can use the `run.sh` script to test it under QEMU. 31 | 32 | ## The Forth system 33 | 34 | The Forth implemented in 2K Linux is not fully ANS compliant. This section aims to list all places where the implementation diverges from this standard. 35 | 36 | - This Forth is not interactive. All input is read from a file on the installation media. 37 | - Input is not read line by line, but in 512-byte sectors. The input buffer might be refilled in the middle of reading a word. 38 | - `HERE` does not behave like a `VALUE`, but like a `VARIABLE`. 39 | - `WORD` does not take a separator on the stack. Instead, words may be separated by any whitespace character, i. e. anything with an ASCII value <= 32. 40 | - `ABORT` is an unconditional "print message and halt". No error code is used. 41 | - `."` during interpretation will print a message. 42 | - `[COMPILE]` is only available before `POSTPONE` is implemented. 43 | - The following `CORE` and `CORE EXT` words are not implemented: 44 | - `<#` 45 | - `#` 46 | - `#S` 47 | - `#>` 48 | - `2!` 49 | - `2@` 50 | - `>BODY` 51 | - `>NUMBER` 52 | - `ABORT"` 53 | - `ACCEPT` 54 | - `ALIGN` 55 | - `ALIGNED` 56 | - `BASE` 57 | - `CHAR+` 58 | - `CHARS` 59 | - `DECIMAL` 60 | - `DOES>` 61 | - `ENVIRONMENT?` 62 | - `EVALUATE` 63 | - `HOLD` 64 | - `MOVE` 65 | - `QUIT` 66 | - `S>D` 67 | - `SIGN` 68 | - `SOURCE` 69 | - `.(` 70 | - `ACTION-OF` 71 | - `BUFFER:` 72 | - `C"` 73 | - `COMPILE,` (replaced by `,`) 74 | - `DEFER!` 75 | - `DEFER@` 76 | - `ERASE` 77 | - `HEX` 78 | - `HOLDS` 79 | - `MARKER` 80 | - `PAD` 81 | - `PARSE` 82 | - `PARSE-NAME` 83 | - `REFILL` 84 | - `RESTORE-INPUT` 85 | - `S\"` 86 | - `SAVE-INPUT` 87 | - `SOURCE-ID` 88 | - `TO` 89 | - `UNUSED` 90 | - `VALUE` 91 | - There aren't really any blocks to deal with, but a similar wordset is used to deal with 512 byte sectors on the installation media. 92 | - There is only one block buffer 93 | - The only word from the block wordset that carries the standard semantics is `BLK` 94 | - `LOAD` just updates `BLK` and loads a sector from the disk into the buffer, current input won't be restored on EOF and the data will only be interpreted as Forth only if the control is returned to the interpreter. When using `LOAD`, care must be taken to make sure `>IN` and `LENGTH` reflect the reality. 95 | - `FILE` is a word that takes a pointer to a filename and its length, finds the file on disk and LOADs its first sector. The currently loaded sector is used as the current directory. 96 | - `ROOT` loads the root directory, to be followed by `FILE`. 97 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Exit on first error 3 | set -e 4 | 5 | # Use tput if available 6 | if command -v tput >/dev/null; then 7 | TPUT=tput 8 | else 9 | TPUT=: 10 | fi 11 | 12 | # Colored output helpers 13 | error(){ $TPUT bold; $TPUT setaf 1; echo "$*"; $TPUT sgr0; exit 1; } 14 | info(){ $TPUT setaf 4; echo "$*"; $TPUT sgr0; } 15 | infon(){ $TPUT setaf 4; echo -n "$*"; $TPUT sgr0; } 16 | accent(){ $TPUT setaf 5; echo "$*"; $TPUT sgr0; } 17 | 18 | # Some utilities are put in /sbin even if they have a use for a normal user. Make sure sh can find them 19 | PATH=$PATH:/sbin 20 | 21 | # Choose an assembler 22 | if command -v yasm >/dev/null; then 23 | ASM=yasm 24 | elif command -v nasm >/dev/null; then 25 | ASM=nasm 26 | else 27 | error "Can't find a suitable assembler. Install yasm or nasm and try again." 28 | fi 29 | 30 | infon "Assembling stage0... " 31 | mkdir -p gen 32 | rm -rf gen/* 33 | $ASM stage0.s -o gen/stage0.bin -l gen/stage0.lst 34 | MBRFREE="$(hexdump -e '"%d\n"' -s446 -n2 gen/stage0.bin)" 35 | RESTFREE="$(hexdump -e '"%d\n"' -s448 -n2 gen/stage0.bin)" 36 | accent "$MBRFREE + $RESTFREE = $(($MBRFREE + $RESTFREE)) bytes free" 37 | 38 | # If you find a way to create only one 64 megabyte file without using loop devices, hit me up 39 | info "Creating the partition image..." 40 | truncate -s 64M gen/fs.img 41 | 42 | info "Creating a FAT32 filesystem..." 43 | echo "You probably used fs.img instead of 2klinux.img. Read the goddamn manual." | mkfs.fat -m - -F 32 -S 512 gen/fs.img >/dev/null 44 | mcopy -i gen/fs.img image-files/* :: 45 | mcopy -i gen/fs.img gen/stage0.bin :: 46 | 47 | info "Creating the disk image..." 48 | truncate -s $(($(stat -c %s gen/fs.img) + 512)) gen/2klinux.img 49 | 50 | info "Filling the partition table..." 51 | sfdisk --quiet --no-reread --no-tell-kernel gen/2klinux.img < and with FALSE and TRUE to avoid 16 | \ dependence on Core tests 17 | \ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth 18 | \ Use of 2VARIABLE (from optional wordset) replaced with CREATE. 19 | \ Minor lower to upper case conversions. 20 | \ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use 21 | \ of a word from an optional word set. 22 | \ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an 23 | \ implementation has the data stack sharing unused dataspace. 24 | \ Double number input dependency removed from the HOLDS tests. 25 | \ Minor case sensitivities removed in definition names. 26 | \ 0.11 25 April 2015 27 | \ Added tests for PARSE-NAME HOLDS BUFFER: 28 | \ S\" tests added 29 | \ DEFER IS ACTION-OF DEFER! DEFER@ tests added 30 | \ Empty CASE statement test added 31 | \ [COMPILE] tests removed because it is obsolescent in Forth 2012 32 | \ 0.10 1 August 2014 33 | \ Added tests contributed by James Bowman for: 34 | \ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> 35 | \ HEX WITHIN UNUSED AGAIN MARKER 36 | \ Added tests for: 37 | \ .R U.R ERASE PAD REFILL SOURCE-ID 38 | \ Removed ABORT from NeverExecuted to enable Win32 39 | \ to continue after failure of RESTORE-INPUT. 40 | \ Removed max-intx which is no longer used. 41 | \ 0.7 6 June 2012 Extra CASE test added 42 | \ 0.6 1 April 2012 Tests placed in the public domain. 43 | \ SAVE-INPUT & RESTORE-INPUT tests, position 44 | \ of T{ moved so that tests work with ttester.fs 45 | \ CONVERT test deleted - obsolete word removed from Forth 200X 46 | \ IMMEDIATE VALUEs tested 47 | \ RECURSE with :NONAME tested 48 | \ PARSE and .( tested 49 | \ Parsing behaviour of C" added 50 | \ 0.5 14 September 2011 Removed the double [ELSE] from the 51 | \ initial SAVE-INPUT & RESTORE-INPUT test 52 | \ 0.4 30 November 2009 max-int replaced with max-intx to 53 | \ avoid redefinition warnings. 54 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 55 | \ CONVERT test now independent of cell size 56 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 57 | \ Tests qd3 to qd6 by Reinhold Straub 58 | \ 0.1 Oct 2006 First version released 59 | \ ----------------------------------------------------------------------------- 60 | \ The tests are based on John Hayes test program for the core word set 61 | 62 | \ Words tested in this file are: 63 | \ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE 64 | \ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL 65 | \ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED 66 | \ VALUE WITHIN [COMPILE] 67 | 68 | \ Words not tested or partially tested: 69 | \ \ because it has been extensively used already and is, hence, unnecessary 70 | \ REFILL and SOURCE-ID from the user input device which are not possible 71 | \ when testing from a file such as this one 72 | \ UNUSED (partially tested) as the value returned is system dependent 73 | \ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been 74 | \ removed from the Forth 2012 standard 75 | 76 | \ Results from words that output to the user output device have to visually 77 | \ checked for correctness. These are .R U.R .( 78 | 79 | \ ----------------------------------------------------------------------------- 80 | \ Assumptions & dependencies: 81 | \ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been 82 | \ included prior to this file 83 | \ - the Core word set available 84 | \ ----------------------------------------------------------------------------- 85 | TESTING Core Extension words 86 | 87 | TESTING TRUE FALSE 88 | 89 | T{ TRUE -> 0 INVERT }T 90 | T{ FALSE -> 0 }T 91 | 92 | \ ----------------------------------------------------------------------------- 93 | TESTING <> U> (contributed by James Bowman) 94 | 95 | T{ 0 0 <> -> FALSE }T 96 | T{ 1 1 <> -> FALSE }T 97 | T{ -1 -1 <> -> FALSE }T 98 | T{ 1 0 <> -> TRUE }T 99 | T{ -1 0 <> -> TRUE }T 100 | T{ 0 1 <> -> TRUE }T 101 | T{ 0 -1 <> -> TRUE }T 102 | 103 | T{ 0 1 U> -> FALSE }T 104 | T{ 1 2 U> -> FALSE }T 105 | T{ 0 MID-UINT U> -> FALSE }T 106 | T{ 0 MAX-UINT U> -> FALSE }T 107 | T{ MID-UINT MAX-UINT U> -> FALSE }T 108 | T{ 0 0 U> -> FALSE }T 109 | T{ 1 1 U> -> FALSE }T 110 | T{ 1 0 U> -> TRUE }T 111 | T{ 2 1 U> -> TRUE }T 112 | T{ MID-UINT 0 U> -> TRUE }T 113 | T{ MAX-UINT 0 U> -> TRUE }T 114 | T{ MAX-UINT MID-UINT U> -> TRUE }T 115 | 116 | \ ----------------------------------------------------------------------------- 117 | TESTING 0<> 0> (contributed by James Bowman) 118 | 119 | T{ 0 0<> -> FALSE }T 120 | T{ 1 0<> -> TRUE }T 121 | T{ 2 0<> -> TRUE }T 122 | T{ -1 0<> -> TRUE }T 123 | T{ MAX-UINT 0<> -> TRUE }T 124 | T{ MIN-INT 0<> -> TRUE }T 125 | T{ MAX-INT 0<> -> TRUE }T 126 | 127 | T{ 0 0> -> FALSE }T 128 | T{ -1 0> -> FALSE }T 129 | T{ MIN-INT 0> -> FALSE }T 130 | T{ 1 0> -> TRUE }T 131 | T{ MAX-INT 0> -> TRUE }T 132 | 133 | \ ----------------------------------------------------------------------------- 134 | TESTING NIP TUCK ROLL PICK (contributed by James Bowman) 135 | 136 | T{ 1 2 NIP -> 2 }T 137 | T{ 1 2 3 NIP -> 1 3 }T 138 | 139 | T{ 1 2 TUCK -> 2 1 2 }T 140 | T{ 1 2 3 TUCK -> 1 3 2 3 }T 141 | 142 | T{ : RO5 100 200 300 400 500 ; -> }T 143 | T{ RO5 3 ROLL -> 100 300 400 500 200 }T 144 | T{ RO5 2 ROLL -> RO5 ROT }T 145 | T{ RO5 1 ROLL -> RO5 SWAP }T 146 | T{ RO5 0 ROLL -> RO5 }T 147 | 148 | T{ RO5 2 PICK -> 100 200 300 400 500 300 }T 149 | T{ RO5 1 PICK -> RO5 OVER }T 150 | T{ RO5 0 PICK -> RO5 DUP }T 151 | 152 | \ ----------------------------------------------------------------------------- 153 | TESTING 2>R 2R@ 2R> (contributed by James Bowman) 154 | 155 | T{ : RR0 2>R 100 R> R> ; -> }T 156 | T{ 300 400 RR0 -> 100 400 300 }T 157 | T{ 200 300 400 RR0 -> 200 100 400 300 }T 158 | 159 | T{ : RR1 2>R 100 2R@ R> R> ; -> }T 160 | T{ 300 400 RR1 -> 100 300 400 400 300 }T 161 | T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T 162 | 163 | T{ : RR2 2>R 100 2R> ; -> }T 164 | T{ 300 400 RR2 -> 100 300 400 }T 165 | T{ 200 300 400 RR2 -> 200 100 300 400 }T 166 | 167 | \ ----------------------------------------------------------------------------- 168 | TESTING WITHIN (contributed by James Bowman) 169 | 170 | T{ 0 0 0 WITHIN -> FALSE }T 171 | T{ 0 0 MID-UINT WITHIN -> TRUE }T 172 | T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T 173 | T{ 0 0 MAX-UINT WITHIN -> TRUE }T 174 | T{ 0 MID-UINT 0 WITHIN -> FALSE }T 175 | T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T 176 | T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 177 | T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T 178 | T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T 179 | T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 180 | T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 181 | T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 182 | T{ 0 MAX-UINT 0 WITHIN -> FALSE }T 183 | T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T 184 | T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 185 | T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T 186 | T{ MID-UINT 0 0 WITHIN -> FALSE }T 187 | T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T 188 | T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T 189 | T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T 190 | T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T 191 | T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 192 | T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T 193 | T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T 194 | T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T 195 | T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T 196 | T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 197 | T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 198 | T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T 199 | T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T 200 | T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 201 | T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 202 | T{ MID-UINT+1 0 0 WITHIN -> FALSE }T 203 | T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T 204 | T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T 205 | T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T 206 | T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T 207 | T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T 208 | T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 209 | T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T 210 | T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T 211 | T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 212 | T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 213 | T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T 214 | T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T 215 | T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T 216 | T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T 217 | T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T 218 | T{ MAX-UINT 0 0 WITHIN -> FALSE }T 219 | T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T 220 | T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T 221 | T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T 222 | T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T 223 | T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 224 | T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T 225 | T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T 226 | T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T 227 | T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T 228 | T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 229 | T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 230 | T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T 231 | T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T 232 | T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 233 | T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 234 | 235 | T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T 236 | T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T 237 | T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T 238 | T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T 239 | T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T 240 | T{ MIN-INT 0 0 WITHIN -> FALSE }T 241 | T{ MIN-INT 0 1 WITHIN -> FALSE }T 242 | T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T 243 | T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T 244 | T{ MIN-INT 1 0 WITHIN -> TRUE }T 245 | T{ MIN-INT 1 1 WITHIN -> FALSE }T 246 | T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T 247 | T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T 248 | T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T 249 | T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T 250 | T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T 251 | T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T 252 | T{ 0 MIN-INT 0 WITHIN -> FALSE }T 253 | T{ 0 MIN-INT 1 WITHIN -> TRUE }T 254 | T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T 255 | T{ 0 0 MIN-INT WITHIN -> TRUE }T 256 | T{ 0 0 0 WITHIN -> FALSE }T 257 | T{ 0 0 1 WITHIN -> TRUE }T 258 | T{ 0 0 MAX-INT WITHIN -> TRUE }T 259 | T{ 0 1 MIN-INT WITHIN -> FALSE }T 260 | T{ 0 1 0 WITHIN -> FALSE }T 261 | T{ 0 1 1 WITHIN -> FALSE }T 262 | T{ 0 1 MAX-INT WITHIN -> FALSE }T 263 | T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T 264 | T{ 0 MAX-INT 0 WITHIN -> FALSE }T 265 | T{ 0 MAX-INT 1 WITHIN -> TRUE }T 266 | T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T 267 | T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T 268 | T{ 1 MIN-INT 0 WITHIN -> FALSE }T 269 | T{ 1 MIN-INT 1 WITHIN -> FALSE }T 270 | T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T 271 | T{ 1 0 MIN-INT WITHIN -> TRUE }T 272 | T{ 1 0 0 WITHIN -> FALSE }T 273 | T{ 1 0 1 WITHIN -> FALSE }T 274 | T{ 1 0 MAX-INT WITHIN -> TRUE }T 275 | T{ 1 1 MIN-INT WITHIN -> TRUE }T 276 | T{ 1 1 0 WITHIN -> TRUE }T 277 | T{ 1 1 1 WITHIN -> FALSE }T 278 | T{ 1 1 MAX-INT WITHIN -> TRUE }T 279 | T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T 280 | T{ 1 MAX-INT 0 WITHIN -> FALSE }T 281 | T{ 1 MAX-INT 1 WITHIN -> FALSE }T 282 | T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T 283 | T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T 284 | T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T 285 | T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T 286 | T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T 287 | T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T 288 | T{ MAX-INT 0 0 WITHIN -> FALSE }T 289 | T{ MAX-INT 0 1 WITHIN -> FALSE }T 290 | T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T 291 | T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T 292 | T{ MAX-INT 1 0 WITHIN -> TRUE }T 293 | T{ MAX-INT 1 1 WITHIN -> FALSE }T 294 | T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T 295 | T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T 296 | T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T 297 | T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T 298 | T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T 299 | 300 | \ ----------------------------------------------------------------------------- 301 | TESTING AGAIN (contributed by James Bowman) 302 | ( changed from mod 7 to mod 8 for 2klinux ) 303 | 304 | T{ : AG0 701 BEGIN DUP 7 AND 0= IF EXIT THEN 1+ AGAIN ; -> }T 305 | T{ AG0 -> 704 }T 306 | 307 | \ ----------------------------------------------------------------------------- 308 | TESTING ?DO 309 | 310 | : QD ?DO I LOOP ; 311 | T{ 789 789 QD -> }T 312 | T{ -9876 -9876 QD -> }T 313 | T{ 5 0 QD -> 0 1 2 3 4 }T 314 | 315 | : QD1 ?DO I 10 +LOOP ; 316 | T{ 50 1 QD1 -> 1 11 21 31 41 }T 317 | T{ 50 0 QD1 -> 0 10 20 30 40 }T 318 | 319 | : QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; 320 | T{ 5 -1 QD2 -> -1 0 1 2 3 }T 321 | 322 | : QD3 ?DO I 1 +LOOP ; 323 | T{ 4 4 QD3 -> }T 324 | T{ 4 1 QD3 -> 1 2 3 }T 325 | T{ 2 -1 QD3 -> -1 0 1 }T 326 | 327 | : QD4 ?DO I -1 +LOOP ; 328 | T{ 4 4 QD4 -> }T 329 | T{ 1 4 QD4 -> 4 3 2 1 }T 330 | T{ -1 2 QD4 -> 2 1 0 -1 }T 331 | 332 | : QD5 ?DO I -10 +LOOP ; 333 | T{ 1 50 QD5 -> 50 40 30 20 10 }T 334 | T{ 0 50 QD5 -> 50 40 30 20 10 0 }T 335 | T{ -25 10 QD5 -> 10 0 -10 -20 }T 336 | 337 | VARIABLE ITERS 338 | VARIABLE INCRMNT 339 | 340 | : QD6 ( limit start increment -- ) 341 | INCRMNT ! 342 | 0 ITERS ! 343 | ?DO 344 | 1 ITERS +! 345 | I 346 | ITERS @ 6 = IF LEAVE THEN 347 | INCRMNT @ 348 | +LOOP ITERS @ 349 | ; 350 | 351 | T{ 4 4 -1 QD6 -> 0 }T 352 | T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T 353 | T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T 354 | T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T 355 | T{ 0 0 0 QD6 -> 0 }T 356 | T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T 357 | T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T 358 | T{ 4 1 1 QD6 -> 1 2 3 3 }T 359 | T{ 4 4 1 QD6 -> 0 }T 360 | T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T 361 | T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T 362 | T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T 363 | T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T 364 | T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T 365 | T{ 2 -1 1 QD6 -> -1 0 1 3 }T 366 | 367 | \ ----------------------------------------------------------------------------- 368 | TESTING CASE OF ENDOF ENDCASE 369 | 370 | : CS1 CASE 1 OF 111 ENDOF 371 | 2 OF 222 ENDOF 372 | 3 OF 333 ENDOF 373 | >R 999 R> 374 | ENDCASE 375 | ; 376 | 377 | T{ 1 CS1 -> 111 }T 378 | T{ 2 CS1 -> 222 }T 379 | T{ 3 CS1 -> 333 }T 380 | T{ 4 CS1 -> 999 }T 381 | 382 | \ Nested CASE's 383 | 384 | : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF 385 | 2 OF 200 ENDOF 386 | >R -300 R> 387 | ENDCASE 388 | ENDOF 389 | -2 OF CASE R@ 1 OF -99 ENDOF 390 | >R -199 R> 391 | ENDCASE 392 | ENDOF 393 | >R 299 R> 394 | ENDCASE R> DROP 395 | ; 396 | 397 | T{ -1 1 CS2 -> 100 }T 398 | T{ -1 2 CS2 -> 200 }T 399 | T{ -1 3 CS2 -> -300 }T 400 | T{ -2 1 CS2 -> -99 }T 401 | T{ -2 2 CS2 -> -199 }T 402 | T{ 0 2 CS2 -> 299 }T 403 | 404 | \ Boolean short circuiting using CASE 405 | 406 | : CS3 ( N1 -- N2 ) 407 | CASE 1- FALSE OF 11 ENDOF 408 | 1- FALSE OF 22 ENDOF 409 | 1- FALSE OF 33 ENDOF 410 | 44 SWAP 411 | ENDCASE 412 | ; 413 | 414 | T{ 1 CS3 -> 11 }T 415 | T{ 2 CS3 -> 22 }T 416 | T{ 3 CS3 -> 33 }T 417 | T{ 9 CS3 -> 44 }T 418 | 419 | \ Empty CASE statements with/without default 420 | 421 | T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T 422 | T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T 423 | T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T 424 | T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T 425 | 426 | \ ----------------------------------------------------------------------------- 427 | TESTING :NONAME RECURSE 428 | 429 | VARIABLE NN1 430 | VARIABLE NN2 431 | :NONAME 1234 ; NN1 ! 432 | :NONAME 9876 ; NN2 ! 433 | T{ NN1 @ EXECUTE -> 1234 }T 434 | T{ NN2 @ EXECUTE -> 9876 }T 435 | 436 | T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; 437 | CONSTANT RN1 -> }T 438 | T{ 0 RN1 EXECUTE -> 0 }T 439 | T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T 440 | 441 | :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition 442 | 1- DUP 443 | CASE 0 OF EXIT ENDOF 444 | 1 OF 11 SWAP RECURSE ENDOF 445 | 2 OF 22 SWAP RECURSE ENDOF 446 | 3 OF 33 SWAP RECURSE ENDOF 447 | DROP ABS RECURSE EXIT 448 | ENDCASE 449 | ; CONSTANT RN2 450 | 451 | T{ 1 RN2 EXECUTE -> 0 }T 452 | T{ 2 RN2 EXECUTE -> 11 0 }T 453 | T{ 4 RN2 EXECUTE -> 33 22 11 0 }T 454 | T{ 25 RN2 EXECUTE -> 33 22 11 0 }T 455 | 456 | \ ----------------------------------------------------------------------------- 457 | TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) 458 | \ Adapted from the Forth 200X RfD tests 459 | 460 | T{ DEFER DEFER1 -> }T 461 | T{ : MY-DEFER DEFER ; -> }T 462 | T{ : IS-DEFER1 IS DEFER1 ; -> }T 463 | T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T 464 | T{ : DEF! DEFER! ; -> }T 465 | T{ : DEF@ DEFER@ ; -> }T 466 | 467 | T{ ' XOR ' DEFER1 DEFER! -> }T 468 | T{ 2 7 DEFER1 -> 5 }T 469 | T{ ' DEFER1 DEFER@ -> ' XOR }T 470 | T{ ' DEFER1 DEF@ -> ' XOR }T 471 | T{ ACTION-OF DEFER1 -> ' XOR }T 472 | T{ ACTION-DEFER1 -> ' XOR }T 473 | T{ ' + IS DEFER1 -> }T 474 | T{ 1 2 DEFER1 -> 3 }T 475 | T{ ' DEFER1 DEFER@ -> ' + }T 476 | T{ ' DEFER1 DEF@ -> ' + }T 477 | T{ ACTION-OF DEFER1 -> ' + }T 478 | T{ ACTION-DEFER1 -> ' + }T 479 | T{ ' - IS-DEFER1 -> }T 480 | T{ 1 2 DEFER1 -> -1 }T 481 | T{ ' DEFER1 DEFER@ -> ' - }T 482 | T{ ' DEFER1 DEF@ -> ' - }T 483 | T{ ACTION-OF DEFER1 -> ' - }T 484 | T{ ACTION-DEFER1 -> ' - }T 485 | 486 | T{ MY-DEFER DEFER2 -> }T 487 | T{ ' DUP IS DEFER2 -> }T 488 | T{ 1 DEFER2 -> 1 1 }T 489 | -------------------------------------------------------------------------------- /image-files/coretest.frt: -------------------------------------------------------------------------------- 1 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 2 | \ VERSION 1.2 3 | \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. 4 | \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE 5 | \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND 6 | \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. 7 | \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... 8 | \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... 9 | \ Modified for 2K Linux 10 | 11 | TESTING CORE WORDS 12 | 13 | \ ------------------------------------------------------------------------ 14 | TESTING BASIC ASSUMPTIONS 15 | 16 | T{ DEPTH -> 0 }T \ START WITH CLEAN SLATE 17 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 18 | T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T 19 | T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) 20 | T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 21 | T{ -1 BITSSET? -> 0 0 }T 22 | 23 | \ ------------------------------------------------------------------------ 24 | TESTING BOOLEANS: INVERT AND OR XOR 25 | 26 | T{ 0 0 AND -> 0 }T 27 | T{ 0 1 AND -> 0 }T 28 | T{ 1 0 AND -> 0 }T 29 | T{ 1 1 AND -> 1 }T 30 | 31 | T{ 0 INVERT 1 AND -> 1 }T 32 | T{ 1 INVERT 1 AND -> 0 }T 33 | 34 | 0 CONSTANT 0S 35 | 0 INVERT CONSTANT 1S 36 | 37 | T{ 0S INVERT -> 1S }T 38 | T{ 1S INVERT -> 0S }T 39 | 40 | T{ 0S 0S AND -> 0S }T 41 | T{ 0S 1S AND -> 0S }T 42 | T{ 1S 0S AND -> 0S }T 43 | T{ 1S 1S AND -> 1S }T 44 | 45 | T{ 0S 0S OR -> 0S }T 46 | T{ 0S 1S OR -> 1S }T 47 | T{ 1S 0S OR -> 1S }T 48 | T{ 1S 1S OR -> 1S }T 49 | 50 | T{ 0S 0S XOR -> 0S }T 51 | T{ 0S 1S XOR -> 1S }T 52 | T{ 1S 0S XOR -> 1S }T 53 | T{ 1S 1S XOR -> 0S }T 54 | 55 | \ ------------------------------------------------------------------------ 56 | TESTING 2* 2/ LSHIFT RSHIFT 57 | 58 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 59 | 1S 1 RSHIFT INVERT CONSTANT MSB 60 | T{ MSB BITSSET? -> 0 0 }T 61 | 62 | T{ 0S 2* -> 0S }T 63 | T{ 1 2* -> 2 }T 64 | T{ $4000 2* -> $8000 }T 65 | T{ 1S 2* 1 XOR -> 1S }T 66 | T{ MSB 2* -> 0S }T 67 | 68 | T{ 0S 2/ -> 0S }T 69 | T{ 1 2/ -> 0 }T 70 | T{ $4000 2/ -> $2000 }T 71 | T{ 1S 2/ -> 1S }T \ MSB PROPOGATED 72 | T{ 1S 1 XOR 2/ -> 1S }T 73 | T{ MSB 2/ MSB AND -> MSB }T 74 | 75 | T{ 1 0 LSHIFT -> 1 }T 76 | T{ 1 1 LSHIFT -> 2 }T 77 | T{ 1 2 LSHIFT -> 4 }T 78 | T{ 1 15 LSHIFT -> $8000 }T \ BIGGEST GUARANTEED SHIFT 79 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 80 | T{ MSB 1 LSHIFT -> 0 }T 81 | 82 | T{ 1 0 RSHIFT -> 1 }T 83 | T{ 1 1 RSHIFT -> 0 }T 84 | T{ 2 1 RSHIFT -> 1 }T 85 | T{ 4 2 RSHIFT -> 1 }T 86 | T{ $8000 15 RSHIFT -> 1 }T \ BIGGEST 87 | T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS 88 | T{ MSB 1 RSHIFT 2* -> MSB }T 89 | 90 | \ ------------------------------------------------------------------------ 91 | TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 92 | 0 INVERT CONSTANT MAX-UINT 93 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT 94 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 95 | 0 INVERT 1 RSHIFT CONSTANT MID-UINT 96 | 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 97 | 98 | 0S CONSTANT 99 | 1S CONSTANT 100 | 101 | T{ 0 0= -> }T 102 | T{ 1 0= -> }T 103 | T{ 2 0= -> }T 104 | T{ -1 0= -> }T 105 | T{ MAX-UINT 0= -> }T 106 | T{ MIN-INT 0= -> }T 107 | T{ MAX-INT 0= -> }T 108 | 109 | T{ 0 0 = -> }T 110 | T{ 1 1 = -> }T 111 | T{ -1 -1 = -> }T 112 | T{ 1 0 = -> }T 113 | T{ -1 0 = -> }T 114 | T{ 0 1 = -> }T 115 | T{ 0 -1 = -> }T 116 | 117 | T{ 0 0< -> }T 118 | T{ -1 0< -> }T 119 | T{ MIN-INT 0< -> }T 120 | T{ 1 0< -> }T 121 | T{ MAX-INT 0< -> }T 122 | 123 | T{ 0 1 < -> }T 124 | T{ 1 2 < -> }T 125 | T{ -1 0 < -> }T 126 | T{ -1 1 < -> }T 127 | T{ MIN-INT 0 < -> }T 128 | T{ MIN-INT MAX-INT < -> }T 129 | T{ 0 MAX-INT < -> }T 130 | T{ 0 0 < -> }T 131 | T{ 1 1 < -> }T 132 | T{ 1 0 < -> }T 133 | T{ 2 1 < -> }T 134 | T{ 0 -1 < -> }T 135 | T{ 1 -1 < -> }T 136 | T{ 0 MIN-INT < -> }T 137 | T{ MAX-INT MIN-INT < -> }T 138 | T{ MAX-INT 0 < -> }T 139 | 140 | T{ 0 1 > -> }T 141 | T{ 1 2 > -> }T 142 | T{ -1 0 > -> }T 143 | T{ -1 1 > -> }T 144 | T{ MIN-INT 0 > -> }T 145 | T{ MIN-INT MAX-INT > -> }T 146 | T{ 0 MAX-INT > -> }T 147 | T{ 0 0 > -> }T 148 | T{ 1 1 > -> }T 149 | T{ 1 0 > -> }T 150 | T{ 2 1 > -> }T 151 | T{ 0 -1 > -> }T 152 | T{ 1 -1 > -> }T 153 | T{ 0 MIN-INT > -> }T 154 | T{ MAX-INT MIN-INT > -> }T 155 | T{ MAX-INT 0 > -> }T 156 | 157 | T{ 0 1 U< -> }T 158 | T{ 1 2 U< -> }T 159 | T{ 0 MID-UINT U< -> }T 160 | T{ 0 MAX-UINT U< -> }T 161 | T{ MID-UINT MAX-UINT U< -> }T 162 | T{ 0 0 U< -> }T 163 | T{ 1 1 U< -> }T 164 | T{ 1 0 U< -> }T 165 | T{ 2 1 U< -> }T 166 | T{ MID-UINT 0 U< -> }T 167 | T{ MAX-UINT 0 U< -> }T 168 | T{ MAX-UINT MID-UINT U< -> }T 169 | 170 | T{ 0 1 MIN -> 0 }T 171 | T{ 1 2 MIN -> 1 }T 172 | T{ -1 0 MIN -> -1 }T 173 | T{ -1 1 MIN -> -1 }T 174 | T{ MIN-INT 0 MIN -> MIN-INT }T 175 | T{ MIN-INT MAX-INT MIN -> MIN-INT }T 176 | T{ 0 MAX-INT MIN -> 0 }T 177 | T{ 0 0 MIN -> 0 }T 178 | T{ 1 1 MIN -> 1 }T 179 | T{ 1 0 MIN -> 0 }T 180 | T{ 2 1 MIN -> 1 }T 181 | T{ 0 -1 MIN -> -1 }T 182 | T{ 1 -1 MIN -> -1 }T 183 | T{ 0 MIN-INT MIN -> MIN-INT }T 184 | T{ MAX-INT MIN-INT MIN -> MIN-INT }T 185 | T{ MAX-INT 0 MIN -> 0 }T 186 | 187 | T{ 0 1 MAX -> 1 }T 188 | T{ 1 2 MAX -> 2 }T 189 | T{ -1 0 MAX -> 0 }T 190 | T{ -1 1 MAX -> 1 }T 191 | T{ MIN-INT 0 MAX -> 0 }T 192 | T{ MIN-INT MAX-INT MAX -> MAX-INT }T 193 | T{ 0 MAX-INT MAX -> MAX-INT }T 194 | T{ 0 0 MAX -> 0 }T 195 | T{ 1 1 MAX -> 1 }T 196 | T{ 1 0 MAX -> 1 }T 197 | T{ 2 1 MAX -> 2 }T 198 | T{ 0 -1 MAX -> 0 }T 199 | T{ 1 -1 MAX -> 1 }T 200 | T{ 0 MIN-INT MAX -> 0 }T 201 | T{ MAX-INT MIN-INT MAX -> MAX-INT }T 202 | T{ MAX-INT 0 MAX -> MAX-INT }T 203 | 204 | \ ------------------------------------------------------------------------ 205 | TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP 206 | 207 | T{ 1 2 2DROP -> }T 208 | T{ 1 2 2DUP -> 1 2 1 2 }T 209 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 210 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 211 | T{ 0 ?DUP -> 0 }T 212 | T{ 1 ?DUP -> 1 1 }T 213 | T{ -1 ?DUP -> -1 -1 }T 214 | T{ DEPTH -> 0 }T 215 | T{ 0 DEPTH -> 0 1 }T 216 | T{ 0 1 DEPTH -> 0 1 2 }T 217 | T{ 0 DROP -> }T 218 | T{ 1 2 DROP -> 1 }T 219 | T{ 1 DUP -> 1 1 }T 220 | T{ 1 2 OVER -> 1 2 1 }T 221 | T{ 1 2 3 ROT -> 2 3 1 }T 222 | T{ 1 2 SWAP -> 2 1 }T 223 | 224 | \ ------------------------------------------------------------------------ 225 | TESTING >R R> R@ 226 | 227 | T{ : GR1 >R R> ; -> }T 228 | T{ : GR2 >R R@ R> DROP ; -> }T 229 | T{ 123 GR1 -> 123 }T 230 | T{ 123 GR2 -> 123 }T 231 | T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) 232 | 233 | \ ------------------------------------------------------------------------ 234 | TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE 235 | 236 | T{ 0 5 + -> 5 }T 237 | T{ 5 0 + -> 5 }T 238 | T{ 0 -5 + -> -5 }T 239 | T{ -5 0 + -> -5 }T 240 | T{ 1 2 + -> 3 }T 241 | T{ 1 -2 + -> -1 }T 242 | T{ -1 2 + -> 1 }T 243 | T{ -1 -2 + -> -3 }T 244 | T{ -1 1 + -> 0 }T 245 | T{ MID-UINT 1 + -> MID-UINT+1 }T 246 | 247 | T{ 0 5 - -> -5 }T 248 | T{ 5 0 - -> 5 }T 249 | T{ 0 -5 - -> 5 }T 250 | T{ -5 0 - -> -5 }T 251 | T{ 1 2 - -> -1 }T 252 | T{ 1 -2 - -> 3 }T 253 | T{ -1 2 - -> -3 }T 254 | T{ -1 -2 - -> 1 }T 255 | T{ 0 1 - -> -1 }T 256 | T{ MID-UINT+1 1 - -> MID-UINT }T 257 | 258 | T{ 0 1+ -> 1 }T 259 | T{ -1 1+ -> 0 }T 260 | T{ 1 1+ -> 2 }T 261 | T{ MID-UINT 1+ -> MID-UINT+1 }T 262 | 263 | T{ 2 1- -> 1 }T 264 | T{ 1 1- -> 0 }T 265 | T{ 0 1- -> -1 }T 266 | T{ MID-UINT+1 1- -> MID-UINT }T 267 | 268 | T{ 0 NEGATE -> 0 }T 269 | T{ 1 NEGATE -> -1 }T 270 | T{ -1 NEGATE -> 1 }T 271 | T{ 2 NEGATE -> -2 }T 272 | T{ -2 NEGATE -> 2 }T 273 | 274 | T{ 0 ABS -> 0 }T 275 | T{ 1 ABS -> 1 }T 276 | T{ -1 ABS -> 1 }T 277 | T{ MIN-INT ABS -> MID-UINT+1 }T 278 | 279 | \ ------------------------------------------------------------------------ 280 | TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT 281 | 282 | HERE 1 ALLOT 283 | HERE 284 | CONSTANT 2NDA 285 | CONSTANT 1STA 286 | T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT 287 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 288 | ( MISSING TEST: NEGATIVE ALLOT ) 289 | 290 | \ Added by GWJ so that ALIGN can be used before , (comma) is tested 291 | 1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment 292 | ALIGN 293 | T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T 294 | \ End of extra test 295 | 296 | HERE 1 , 297 | HERE 2 , 298 | CONSTANT 2ND 299 | CONSTANT 1ST 300 | T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT 301 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 302 | T{ 1ST 1 CELLS + -> 2ND }T 303 | T{ 1ST @ 2ND @ -> 1 2 }T 304 | T{ 5 1ST ! -> }T 305 | T{ 1ST @ 2ND @ -> 5 2 }T 306 | T{ 6 2ND ! -> }T 307 | T{ 1ST @ 2ND @ -> 5 6 }T 308 | T{ 1ST 2@ -> 6 5 }T 309 | T{ 2 1 1ST 2! -> }T 310 | T{ 1ST 2@ -> 2 1 }T 311 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 312 | 313 | HERE 1 C, 314 | HERE 2 C, 315 | CONSTANT 2NDC 316 | CONSTANT 1STC 317 | T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT 318 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 319 | T{ 1STC 1 CHARS + -> 2NDC }T 320 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 321 | T{ 3 1STC C! -> }T 322 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 323 | T{ 4 2NDC C! -> }T 324 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 325 | 326 | ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 327 | CONSTANT A-ADDR CONSTANT UA-ADDR 328 | T{ UA-ADDR ALIGNED -> A-ADDR }T 329 | T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T 330 | T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T 331 | T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T 332 | T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T 333 | T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T 334 | T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T 335 | T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T 336 | 337 | : BITS ( X -- U ) 338 | 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; 339 | ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) 340 | T{ 1 CHARS 1 < -> }T 341 | T{ 1 CHARS 1 CELLS > -> }T 342 | ( TBD: HOW TO FIND NUMBER OF BITS? ) 343 | 344 | ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) 345 | T{ 1 CELLS 1 < -> }T 346 | T{ 1S BITS $10 < -> }T 347 | 348 | T{ 0 1ST ! -> }T 349 | T{ 1 1ST +! -> }T 350 | T{ 1ST @ -> 1 }T 351 | T{ -1 1ST +! 1ST @ -> 0 }T 352 | 353 | \ ------------------------------------------------------------------------ 354 | TESTING CHAR [CHAR] [ ] BL S" 355 | 356 | T{ BL -> $20 }T 357 | T{ CHAR X -> $58 }T 358 | T{ CHAR HELLO -> $48 }T 359 | T{ : GC1 [CHAR] X ; -> }T 360 | T{ : GC2 [CHAR] HELLO ; -> }T 361 | T{ GC1 -> $58 }T 362 | T{ GC2 -> $48 }T 363 | T{ : GC3 [ GC1 ] LITERAL ; -> }T 364 | T{ GC3 -> $58 }T 365 | T{ : GC4 S" XY" ; -> }T 366 | T{ GC4 SWAP DROP -> 2 }T 367 | T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> $58 $59 }T 368 | 369 | \ ------------------------------------------------------------------------ 370 | TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE 371 | 372 | T{ : GT1 123 ; -> }T 373 | T{ ' GT1 EXECUTE -> 123 }T 374 | T{ : GT2 ['] GT1 ; IMMEDIATE -> }T 375 | T{ GT2 EXECUTE -> 123 }T 376 | HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING 377 | HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING 378 | T{ : GT3 GT2 LITERAL ; -> }T 379 | T{ GT3 -> ' GT1 }T 380 | T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T 381 | 382 | T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T 383 | T{ : GT5 GT4 ; -> }T 384 | T{ GT5 -> 123 }T 385 | T{ : GT6 345 ; IMMEDIATE -> }T 386 | T{ : GT7 POSTPONE GT6 ; -> }T 387 | T{ GT7 -> 345 }T 388 | 389 | T{ : GT8 STATE @ ; IMMEDIATE -> }T 390 | T{ GT8 -> 0 }T 391 | T{ : GT9 GT8 LITERAL ; -> }T 392 | T{ GT9 0= -> }T 393 | 394 | \ ------------------------------------------------------------------------ 395 | TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE 396 | 397 | T{ : GI1 IF 123 THEN ; -> }T 398 | T{ : GI2 IF 123 ELSE 234 THEN ; -> }T 399 | T{ 0 GI1 -> }T 400 | T{ 1 GI1 -> 123 }T 401 | T{ -1 GI1 -> 123 }T 402 | T{ 0 GI2 -> 234 }T 403 | T{ 1 GI2 -> 123 }T 404 | T{ -1 GI1 -> 123 }T 405 | 406 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 407 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 408 | T{ 4 GI3 -> 4 5 }T 409 | T{ 5 GI3 -> 5 }T 410 | T{ 6 GI3 -> 6 }T 411 | 412 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 413 | T{ 3 GI4 -> 3 4 5 6 }T 414 | T{ 5 GI4 -> 5 6 }T 415 | T{ 6 GI4 -> 6 7 }T 416 | 417 | T{ : GI5 BEGIN DUP 2 > 418 | WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T 419 | T{ 1 GI5 -> 1 345 }T 420 | T{ 2 GI5 -> 2 345 }T 421 | T{ 3 GI5 -> 3 4 5 123 }T 422 | T{ 4 GI5 -> 4 5 123 }T 423 | T{ 5 GI5 -> 5 123 }T 424 | 425 | T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T 426 | T{ 0 GI6 -> 0 }T 427 | T{ 1 GI6 -> 0 1 }T 428 | T{ 2 GI6 -> 0 1 2 }T 429 | T{ 3 GI6 -> 0 1 2 3 }T 430 | T{ 4 GI6 -> 0 1 2 3 4 }T 431 | 432 | \ ------------------------------------------------------------------------ 433 | TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT 434 | 435 | T{ : GD1 DO I LOOP ; -> }T 436 | T{ 4 1 GD1 -> 1 2 3 }T 437 | T{ 2 -1 GD1 -> -1 0 1 }T 438 | T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T 439 | 440 | T{ : GD2 DO I -1 +LOOP ; -> }T 441 | T{ 1 4 GD2 -> 4 3 2 1 }T 442 | T{ -1 2 GD2 -> 2 1 0 -1 }T 443 | T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T 444 | 445 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 446 | T{ 4 1 GD3 -> 1 2 3 }T 447 | T{ 2 -1 GD3 -> -1 0 1 }T 448 | T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T 449 | 450 | T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T 451 | T{ 1 4 GD4 -> 4 3 2 1 }T 452 | T{ -1 2 GD4 -> 2 1 0 -1 }T 453 | T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T 454 | 455 | T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T 456 | T{ 1 GD5 -> 123 }T 457 | T{ 5 GD5 -> 123 }T 458 | T{ 6 GD5 -> 234 }T 459 | 460 | T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 461 | 0 SWAP 0 DO 462 | I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP 463 | LOOP ; -> }T 464 | T{ 1 GD6 -> 1 }T 465 | T{ 2 GD6 -> 3 }T 466 | T{ 3 GD6 -> 4 1 2 }T 467 | 468 | \ ------------------------------------------------------------------------ 469 | TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY 470 | 471 | T{ 123 CONSTANT X123 -> }T 472 | T{ X123 -> 123 }T 473 | T{ : EQU CONSTANT ; -> }T 474 | T{ X123 EQU Y123 -> }T 475 | T{ Y123 -> 123 }T 476 | 477 | T{ VARIABLE V1 -> }T 478 | T{ 123 V1 ! -> }T 479 | T{ V1 @ -> 123 }T 480 | 481 | T{ : NOP : POSTPONE ; ; -> }T 482 | T{ NOP NOP1 NOP NOP2 -> }T 483 | T{ NOP1 -> }T 484 | T{ NOP2 -> }T 485 | 486 | \ ------------------------------------------------------------------------ 487 | TESTING FILL MOVE 488 | 489 | CREATE FBUF 00 C, 00 C, 00 C, 490 | CREATE SBUF 12 C, 34 C, 56 C, 491 | : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; 492 | 493 | T{ FBUF 0 20 FILL -> }T 494 | T{ SEEBUF -> 00 00 00 }T 495 | 496 | T{ FBUF 1 20 FILL -> }T 497 | T{ SEEBUF -> 20 00 00 }T 498 | 499 | T{ FBUF 3 20 FILL -> }T 500 | T{ SEEBUF -> 20 20 20 }T 501 | 502 | T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE 503 | T{ SEEBUF -> 20 20 20 }T 504 | 505 | T{ SBUF FBUF 0 CHARS MOVE -> }T 506 | T{ SEEBUF -> 20 20 20 }T 507 | 508 | T{ SBUF FBUF 1 CHARS MOVE -> }T 509 | T{ SEEBUF -> 12 20 20 }T 510 | 511 | T{ SBUF FBUF 3 CHARS MOVE -> }T 512 | T{ SEEBUF -> 12 34 56 }T 513 | 514 | T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T 515 | T{ SEEBUF -> 12 12 34 }T 516 | 517 | T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T 518 | T{ SEEBUF -> 12 34 34 }T 519 | 520 | \ ------------------------------------------------------------------------ 521 | TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. 522 | 523 | : OUTPUT-TEST 524 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 525 | $41 BL DO I EMIT LOOP CR 526 | $61 $41 DO I EMIT LOOP CR 527 | $7F $61 DO I EMIT LOOP CR 528 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 529 | 9 1+ 0 DO I . LOOP CR 530 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 531 | [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR 532 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 533 | [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR 534 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 535 | 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR 536 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 537 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 538 | ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR 539 | ." SIGNED: " MIN-INT . MAX-INT . CR 540 | ." UNSIGNED: " 0 U. MAX-UINT U. CR 541 | ; 542 | 543 | T{ OUTPUT-TEST -> }T 544 | 545 | \ ------------------------------------------------------------------------ 546 | TESTING DICTIONARY SEARCH RULES 547 | 548 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 549 | 550 | T{ GDX -> 123 234 }T 551 | 552 | CONCLUDE" COREEXT.FRT" 553 | -------------------------------------------------------------------------------- /image-files/cpp.frt: -------------------------------------------------------------------------------- 1 | ( 2 | The entries in the include stack look as follows: 3 | 4 | 0 - 12 Saved FILENAME (counted string) 5 | 13 - 16 Saved LINE 6 | 17 - 20 Saved >IN 7 | 21 - 24 Saved LENGTH 8 | 25 - 28 Saved BLK 9 | ) 10 | 11 | 64 CONSTANT INCSTK-SIZE 12 | 25 CONSTANT INCSTK-ESIZE 13 | VARIABLE INCSTK-DEPTH 14 | CREATE INCSTK INCSTK-SIZE INCSTK-ESIZE * ALLOT 15 | 0 INCSTK-DEPTH ! 16 | : INCSTK-CURR ( -- include-stack-pointer ) INCSTK INCSTK-ESIZE INCSTK-DEPTH @ * + ; 17 | 18 | VARIABLE LINE 19 | DEFER MAIN-EOF 20 | CREATE FILENAME 13 ALLOT 21 | 22 | : PRINT-LOC 23 | FILENAME COUNT TYPE 24 | ." :" 25 | LINE @ .X 26 | ." : " 27 | ; 28 | 29 | : QUOTE-TILL-EOL CR BEGIN KEY DUP #CR <> WHILE EMIT REPEAT DROP ; 30 | 31 | : SAVE-LOC ( -- ) 32 | INCSTK-DEPTH @ INCSTK-SIZE >= IF 33 | PRINT-LOC ." include stack overflow" ABORT 34 | THEN 35 | 36 | INCSTK-CURR 37 | FILENAME OVER 13 CMOVE 13 + 38 | LINE @ OVER ! CELL+ 39 | >IN @ OVER ! CELL+ 40 | LENGTH @ OVER ! CELL+ 41 | BLK @ SWAP ! 42 | 1 INCSTK-DEPTH +! 43 | ; 44 | 45 | : RESTORE-LOC 46 | INCSTK-DEPTH @ 0= IF 47 | MAIN-EOF 48 | ELSE 49 | 1 INCSTK-DEPTH -! 50 | INCSTK-CURR 51 | DUP FILENAME 13 CMOVE 13 + 52 | DUP @ LINE ! CELL+ 53 | DUP @ >IN ! CELL+ 54 | DUP @ LENGTH ! CELL+ 55 | @ LOAD 56 | THEN 57 | ; 58 | 59 | : PEEK KEY UNGETC ; 60 | 61 | : UNGETC 62 | UNGETC 63 | PEEK #CR = IF 64 | 1 LINE -! 65 | THEN 66 | ; 67 | 68 | : KEY 69 | KEY 70 | DUP #CR = IF 71 | 1 LINE +! 72 | THEN 73 | 74 | DUP 0= IF 75 | DROP #CR RESTORE-LOC 76 | THEN 77 | ; 78 | 79 | HIDE KEY-NOEOF 80 | 81 | : OPEN-FILE ( filename length -- ) 82 | FILENAME 13 0 FILL 83 | DUP FILENAME C! 84 | FILENAME 1+ SWAP CMOVE 85 | ROOT 86 | FILENAME COUNT FILE 87 | 1 LINE ! 88 | ; 89 | 90 | : IDENT? DUP [CHAR] _ = SWAP ALNUM? OR ; 91 | 92 | : SKIP-LINE BEGIN KEY #CR = UNTIL ; 93 | : SKIP-WHITE BEGIN KEY BL > UNTIL UNGETC ; 94 | : SKIP-WHITE-ONE-LINE BEGIN KEY DUP BL > SWAP #CR = OR UNTIL UNGETC ; 95 | 96 | : ASSERT-CR 97 | SKIP-WHITE-ONE-LINE 98 | KEY #CR <> IF 99 | PRINT-LOC ." expected newline, got:" UNGETC QUOTE-TILL-EOL 100 | ABORT 101 | THEN 102 | ; 103 | 104 | : PARSE-IDENT 105 | HERE 106 | BEGIN 107 | KEY DUP IDENT? 108 | WHILE 109 | C, 110 | REPEAT 111 | DROP UNGETC 112 | HERE OVER - 113 | OVER HERE! 114 | ; 115 | 116 | 0 CONSTANT DIR-NONE 117 | 1 CONSTANT DIR-IF 118 | 2 CONSTANT DIR-IFDEF 119 | 3 CONSTANT DIR-IFNDEF 120 | 4 CONSTANT DIR-ELSE 121 | 5 CONSTANT DIR-ELIF 122 | 6 CONSTANT DIR-ENDIF 123 | 7 CONSTANT DIR-INCLUDE 124 | 8 CONSTANT DIR-DEFINE 125 | 9 CONSTANT DIR-UNDEF 126 | 10 CONSTANT DIR-LINE 127 | 11 CONSTANT DIR-ERROR 128 | 12 CONSTANT DIR-PRAGMA 129 | 130 | : GET-DIRECTIVE 131 | SKIP-WHITE-ONE-LINE 132 | PARSE-IDENT 133 | SCASE 134 | S" if" SOF DIR-IF SENDOF 135 | S" ifdef" SOF DIR-IFDEF SENDOF 136 | S" ifndef" SOF DIR-IFNDEF SENDOF 137 | S" else" SOF DIR-ELSE SENDOF 138 | S" elif" SOF DIR-ELIF SENDOF 139 | S" endif" SOF DIR-ENDIF SENDOF 140 | S" include" SOF DIR-INCLUDE SENDOF 141 | S" define" SOF DIR-DEFINE SENDOF 142 | S" undef" SOF DIR-UNDEF SENDOF 143 | S" line" SOF DIR-LINE SENDOF 144 | S" error" SOF DIR-ERROR SENDOF 145 | S" pragma" SOF DIR-PRAGMA SENDOF 146 | CR PRINT-LOC ." unknown preprocessor directive: " TYPE ABORT 147 | SENDCASE 148 | ; 149 | 150 | : SKIP-TILL-ENDIF 151 | BEGIN 152 | KEY [CHAR] # = IF 153 | GET-DIRECTIVE DIR-ENDIF = IF EXIT THEN 154 | THEN 155 | SKIP-LINE 156 | AGAIN 157 | ; 158 | 159 | DEFER HANDLE-IFCOND 160 | 161 | : FIND-OTHER-IF-BRANCH 162 | BEGIN 163 | KEY [CHAR] # = IF 164 | GET-DIRECTIVE CASE 165 | DIR-ELSE OF ASSERT-CR EXIT ENDOF 166 | DIR-ELIF OF HANDLE-IFCOND EXIT ENDOF 167 | DIR-IF OF HANDLE-IFCOND EXIT ENDOF 168 | DIR-IFDEF OF SKIP-TILL-ENDIF EXIT ENDOF 169 | DIR-IFNDEF OF SKIP-TILL-ENDIF EXIT ENDOF 170 | ENDCASE 171 | THEN 172 | AGAIN 173 | ; 174 | 175 | :NONAME 176 | SKIP-WHITE-ONE-LINE PARSE-IDENT S" TRUE" S= SKIP-LINE ( TODO: EVALUATE CONDITION ) 177 | INVERT IF FIND-OTHER-IF-BRANCH THEN 178 | ; IS HANDLE-IFCOND 179 | 180 | : MAYBE-HANDLE-DIR 181 | KEY [CHAR] # <> IF UNGETC EXIT THEN 182 | GET-DIRECTIVE CASE 183 | DIR-NONE OF EXIT ENDOF 184 | DIR-IF OF HANDLE-IFCOND ENDOF 185 | DIR-IFDEF OF SKIP-TILL-ENDIF ENDOF 186 | DIR-IFNDEF OF SKIP-TILL-ENDIF ENDOF 187 | 188 | ( If you encounter else or elif in this state, it means you've just finished the branch you aren't 189 | supposed to ignore, and therefore, you want to ignore all other branches of the conditional ) 190 | DIR-ELSE OF ASSERT-CR SKIP-TILL-ENDIF ENDOF 191 | DIR-ELIF OF SKIP-TILL-ENDIF ENDOF 192 | DIR-ENDIF OF ASSERT-CR ENDOF 193 | PRINT-LOC ." unhandled directive #" . ABORT 194 | ENDCASE 195 | ; 196 | 197 | : TEST 198 | S" TEST.C" OPEN-FILE 199 | BEGIN 200 | MAYBE-HANDLE-DIR 201 | PRINT-LOC 202 | BEGIN 203 | KEY DUP #CR <> 204 | WHILE 205 | EMIT 206 | REPEAT 207 | CR 208 | AGAIN 209 | ; 210 | 211 | TEST 212 | -------------------------------------------------------------------------------- /image-files/stage1.frt: -------------------------------------------------------------------------------- 1 | : S0 $7C00 ; 2 | : BLK $7C10 ; 3 | : >IN $7C14 ; 4 | : LATEST $7C18 ; 5 | : STATE $7C20 ; 6 | : LENGTH $7C24 ; 7 | 8 | : HERE $7C1C @ ; 9 | : HERE! $7C1C ! ; 10 | : ROOT $882C @ LOAD ; 11 | 12 | : F_IMMED $80 ; 13 | : F_HIDDEN $20 ; 14 | : F_LENMASK $1F ; 15 | 16 | : #TAB 9 ; 17 | : #CR 10 ; 18 | : BL 32 ; 19 | 20 | : FALSE 0 ; 21 | : TRUE -1 ; 22 | 23 | : 1+ -1 - ; 24 | : 1- 1 - ; 25 | 26 | : CELL 4 ; 27 | 28 | : CELL+ -4 - ; 29 | : CELL- 4 - ; 30 | : CHAR+ 1+ ; 31 | : CHAR- 1- ; 32 | 33 | : DROP SP@ -4 - SP! ; 34 | : 2DROP SP@ -8 - SP! ; 35 | : 3DROP SP@ -12 - SP! ; 36 | : DUP SP@ @ ; 37 | : OVER SP@ CELL+ @ ; 38 | : R@ RP@ 8 - @ ; 39 | : R> 40 | RP@ 8 - @ 41 | RP@ 4 - @ 42 | RP@ 8 - ! 43 | RP@ 4 - RP! 44 | ; 45 | : >R 46 | RP@ 4 - @ 47 | RP@ ! 48 | RP@ 4 - ! 49 | RP@ -4 - RP! 50 | ; 51 | : RDROP 52 | RP@ 4 - @ 53 | RP@ 8 - ! 54 | RP@ 4 - RP! 55 | ; 56 | 57 | : NIP >R DROP R> ; 58 | : SWAP 59 | OVER >R 60 | NIP 61 | R> 62 | ; 63 | : ROT >R SWAP R> SWAP ; 64 | : -ROT SWAP >R SWAP R> ; 65 | : TUCK SWAP OVER ; 66 | 67 | : 2DUP OVER OVER ; 68 | 69 | : NEGATE >R 0 R> - ; 70 | : + NEGATE - ; 71 | : 2* DUP + ; 72 | 73 | : OR 2DUP AND >R + R> - ; 74 | : XOR 2DUP AND >R + R> 2* - ; 75 | 76 | : C@ @ $FF AND ; 77 | : C! 78 | DUP >R @ 79 | $FFFFFF00 AND 80 | OR 81 | R> ! 82 | ; 83 | 84 | : +! DUP >R @ + R> ! ; 85 | : -! DUP >R @ - NEGATE R> ! ; 86 | : OR! DUP >R @ OR R> ! ; 87 | : XOR! DUP >R @ XOR R> ! ; 88 | : AND! DUP >R @ AND R> ! ; 89 | : COR! DUP >R C@ OR R> C! ; 90 | : CXOR! DUP >R C@ XOR R> C! ; 91 | : CAND! DUP >R C@ AND R> C! ; 92 | 93 | : >FLAGS 2 + ; 94 | : IMMEDIATE F_IMMED LATEST @ >FLAGS COR! ; 95 | 96 | : KEY-NOEOF KEY ; 97 | : UNGETC 98 | 1 >IN -! 99 | 1 LENGTH +! 100 | ; 101 | 102 | : [ FALSE STATE ! ; IMMEDIATE 103 | : ] TRUE STATE ! ; 104 | 105 | : INVERT NEGATE 1- ; 106 | : 0<> 0= INVERT ; 107 | : 0< $80000000 AND 0<> ; 108 | : 0>= 0< INVERT ; 109 | : 0<= DUP 0= >R 0< R> OR ; 110 | : 0> 0<= INVERT ; 111 | 112 | : = - 0= ; 113 | : <> - 0<> ; 114 | : < $80000000 + >R $80000000 + R> U< ; 115 | : > SWAP < ; 116 | : >= < INVERT ; 117 | : <= > INVERT ; 118 | 119 | : U> SWAP U< ; 120 | : U>= U< INVERT ; 121 | : U<= U> INVERT ; 122 | 123 | : ALLOT HERE + HERE! ; 124 | : , HERE CELL ALLOT ! ; 125 | : C, HERE 1 ALLOT C! ; 126 | 127 | : COMPILE R> DUP @ , CELL+ >R ; 128 | 129 | : BRANCH R> @ >R ; 130 | : 0BRANCH 0= DUP R@ @ AND SWAP INVERT R> CELL+ AND OR >R ; 131 | 132 | : BEGIN HERE ; IMMEDIATE 133 | : UNTIL COMPILE 0BRANCH , ; IMMEDIATE 134 | : AGAIN COMPILE BRANCH , ; IMMEDIATE 135 | 136 | : \ UNGETC 137 | BEGIN 138 | KEY-NOEOF #CR = 139 | UNTIL 140 | ; IMMEDIATE 141 | 142 | : WHILE \ ( ptr2-val -- ptr1-addr ptr2-val ) 143 | COMPILE 0BRANCH 144 | HERE \ ( ptr2-val ptr1-addr ) 145 | 0 , \ a dummy destination 146 | SWAP 147 | ; IMMEDIATE 148 | 149 | : REPEAT \ ( ptr1-addr ptr2-val -- ) 150 | COMPILE BRANCH 151 | , \ ( ptr1-addr ) 152 | HERE \ resolve ptr1 153 | SWAP ! 154 | ; IMMEDIATE 155 | 156 | \ WORD is implemented in stage0, but not exposed. 157 | : WORD 158 | BEGIN KEY-NOEOF DUP BL <= WHILE DROP REPEAT 159 | >R $7DDE R> 160 | BEGIN \ ( addr c ) 161 | OVER C! 162 | CHAR+ 163 | KEY DUP BL <= 164 | UNTIL 165 | DROP \ ( addr ) 166 | $7DDE TUCK - 167 | ; 168 | 169 | \ CHAR will parse a word and give you its first character. 170 | : CHAR WORD DROP C@ ; 171 | 172 | CHAR 2 EMIT 173 | 174 | \ 2/ is an arithmetic shift and RSHIFT is a logical shift, so we have to preserve the top bit with 175 | \ some bit twiddling. 176 | : 2/ \ ( x ) 177 | DUP >R \ ( x x ) 178 | 1 RSHIFT \ ( x x>>1 ) 179 | R> \ ( x>>1 x ) 180 | $80000000 AND \ ( x>>1 topbit ) 181 | OR 182 | ; 183 | 184 | \ CELLS turns a number of cells into a number of bytes 185 | : CELLS 2* 2* ; 186 | 187 | \ Also known as the not exposed LIT in stage0 188 | : (LITERAL) R@ @ R> CELL+ >R ; 189 | 190 | \ (LITERAL) is not IMMEDIATE, so one can implement LITERAL like this: 191 | : LITERAL (LITERAL) (LITERAL) , , ; IMMEDIATE 192 | 193 | : >CFA >FLAGS \ ( flags-address ) 194 | DUP C@ \ ( flags-address flags ) 195 | F_LENMASK AND \ ( flags-address name-length ) 196 | + 1+ \ skip name-length bytes, plus one more for the flags byte itself 197 | ; 198 | 199 | : IF \ ( -- ptr1-addr ) 200 | COMPILE 0BRANCH 201 | HERE \ save the address 202 | 0 , \ compile a dummy ptr1 203 | ; IMMEDIATE 204 | 205 | : ELSE \ ( ptr1-addr -- ptr2-addr ) 206 | COMPILE BRANCH 207 | HERE >R \ ( ptr1-addr ) ( R: ptr2-addr ) 208 | 0 , \ compile a dummy ptr2 209 | >R HERE R> ! \ fill in the ptr1 210 | R> 211 | ; IMMEDIATE 212 | 213 | : THEN \ ( ptr-addr -- ) 214 | >R HERE R> ! 215 | ; IMMEDIATE 216 | 217 | : H@ \ ( addr -- val ) 218 | DUP >R C@ R> 1+ C@ 219 | 2* 2* 2* 2* 220 | 2* 2* 2* 2* 221 | + 222 | ; 223 | 224 | \ Drop the address that points to the routine we're exiting from. 225 | : EXIT RDROP ; 226 | 227 | : FOLLOW-LINK \ ( ptr -- ptr | 0 ) 228 | DUP H@ DUP 0= IF NIP EXIT THEN - 229 | ; 230 | 231 | \ ?DUP is a useful word if you want to act on a value if it's non-zero. Compare: 232 | \ DUP IF ... ELSE DROP THEN 233 | \ ?DUP IF ... THEN 234 | : ?DUP DUP IF DUP THEN ; 235 | 236 | : S= \ ( c-addr1 u1 c-addr2 u2 -- true | false ) 237 | >R OVER R> <> IF 3DROP FALSE EXIT THEN 238 | SWAP 239 | BEGIN 240 | ?DUP 241 | WHILE 242 | >R 243 | OVER C@ OVER C@ 244 | <> IF 2DROP RDROP FALSE EXIT THEN 245 | CHAR+ >R CHAR+ R> 246 | R> 1- 247 | REPEAT 248 | 2DROP TRUE 249 | ; 250 | 251 | : FIND \ ( name u -- dict-ptr | 0 ) 252 | LATEST @ \ ( name u ptr ) 253 | BEGIN 254 | >R 2DUP R@ 255 | 2 + \ ( name u name u ptr@len ) ( R: ptr ) 256 | DUP C@ [ F_HIDDEN F_LENMASK OR ] LITERAL AND \ ( name u name u ptr@len len ) ( R: ptr ) 257 | >R 1+ R> S= IF 258 | 2DROP R> EXIT 259 | THEN 260 | R> FOLLOW-LINK DUP 0= 261 | UNTIL 262 | 3DROP 0 263 | ; 264 | 265 | : MUST-FIND FIND DUP 0= IF 33 EMIT BEGIN AGAIN THEN ; 266 | : ' WORD MUST-FIND >CFA ; 267 | 268 | \ ---------- MAKING USE OF CONDITIONALS: EMIT ---------------------------------------------------- 269 | 270 | \ Now that we can use IF, let's implement a few pretty important words that need IF to work. 271 | 272 | \ The underlying assembly implementation uses BIOS's teletype output interrupt, which uses CRLF as 273 | \ the line ending - this overrides the implementation of EMIT to convert LF to CRLF on the fly. 274 | : EMIT 275 | DUP #CR = IF 276 | 13 EMIT 277 | THEN 278 | EMIT 279 | ; 280 | 281 | CHAR K EMIT 282 | 283 | \ ---------- HIDING WORDS ------------------------------------------------------------------------ 284 | 285 | \ Sometimes a word is only needed to implement something bigger, and should not be used after it's 286 | \ used the few times it's designed for. This Forth provides HIDE just for these situations. 287 | 288 | \ HIDDEN takes an address of a dictionary entry and toggles its hidden flag 289 | : HIDDEN >FLAGS >R F_HIDDEN R> CXOR! ; 290 | 291 | : HIDE WORD MUST-FIND HIDDEN ; 292 | 293 | \ ---------- INSPECTING THE FLAGS FIELD ---------------------------------------------------------- 294 | 295 | : HIDDEN? >FLAGS C@ F_HIDDEN AND 0<> ; 296 | : IMMEDIATE? >FLAGS C@ F_IMMED AND 0<> ; 297 | 298 | \ ---------- MAKING USE OF CONDITIONALS: IMPLEMENTING A PROPER POSTPONE -------------------------- 299 | 300 | \ POSTPONE's job is simple: if a word is immediate, just compile it as if it wasn't. Otherwise, it 301 | \ should be equivalent to COMPILE. This implementation does just that. 302 | : POSTPONE 303 | WORD MUST-FIND DUP IMMEDIATE? INVERT IF 304 | COMPILE COMPILE 305 | THEN 306 | >CFA , 307 | ; IMMEDIATE 308 | 309 | \ Since we have POSTPONE, we don't need COMPILE anymore. 310 | HIDE COMPILE 311 | 312 | : ['] ' POSTPONE LITERAL ; IMMEDIATE 313 | : [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE 314 | 315 | \ ---------- MAKING USE OF CONDITIONALS: S>D ----------------------------------------------------- 316 | 317 | \ The way you extend a number to two cells depends on its sign: 318 | : S>D 319 | DUP 0< IF 320 | -1 321 | ELSE 322 | 0 323 | THEN 324 | ; 325 | 326 | \ While we're at it, let's define D>S. 327 | : D>S DROP ; 328 | 329 | \ ---------- MAKING USE OF CONDITIONALS: ABS ----------------------------------------------------- 330 | 331 | : ABS DUP 0< IF NEGATE THEN ; 332 | 333 | : MINMAX \ ( a b -- min max ) 334 | 2DUP > IF 335 | SWAP 336 | THEN 337 | ; 338 | 339 | \ ---------- CASE STATEMENTS --------------------------------------------------------------------- 340 | 341 | : CASE 0 ; IMMEDIATE 342 | : OF 343 | POSTPONE OVER 344 | POSTPONE = 345 | POSTPONE IF 346 | POSTPONE DROP 347 | ; IMMEDIATE 348 | 349 | : ENDOF 350 | POSTPONE ELSE 351 | ; IMMEDIATE 352 | 353 | : ENDCASE 354 | POSTPONE DROP 355 | BEGIN 356 | ?DUP 357 | WHILE 358 | POSTPONE THEN 359 | REPEAT 360 | ; IMMEDIATE 361 | 362 | \ ---------- PARENTHESIS COMMENTS ---------------------------------------------------------------- 363 | 364 | : ( \ ( -- ) 365 | 1 \ initial depth 366 | BEGIN KEY-NOEOF \ ( depth key ) 367 | CASE 368 | [CHAR] ( OF 1+ ENDOF 369 | [CHAR] ) OF 1- ENDOF 370 | ENDCASE \ no default case is OK too! 371 | DUP 0= 372 | UNTIL \ ( depth ) 373 | DROP 374 | ; IMMEDIATE 375 | 376 | ( ---------- HAVING FUN WITH THE NEW TOY: STACK EFFECT COMMENTS! ------------------------------- ) 377 | 378 | : SPACE BL EMIT ; 379 | SPACE CHAR L EMIT 380 | 381 | ( yes, I do indeed agree that my definition of fun is a weird one ) 382 | 383 | : PICK ( x(u) ... x(1) x(0) u -- x(u) ... x(1) x(0) x(u) ) 384 | 1+ CELLS SP@ + ( x(u) ... x(1) x(0) addrof-x(u) ) 385 | @ 386 | ; 387 | 388 | : 2RDROP ( R: x x retaddr -- R: retaddr ) R> RDROP RDROP >R ; 389 | : 2R> ( R: x y retaddr -- x y R: retaddr ) 390 | R> R> R> ( retaddr y x R: ) 391 | ROT ( y x retaddr R: ) 392 | >R ( y x R: retaddr ) 393 | SWAP ( x y R: retaddr ) 394 | ; 395 | 396 | : 2>R ( x y R: retaddr -- R: x y retaddr ) 397 | R> ( x y retaddr R: ) 398 | -ROT ( retaddr x y R: ) 399 | SWAP ( retaddr y x R: ) 400 | >R >R >R ( R: x y retaddr ) 401 | ; 402 | 403 | : 2SWAP ( a b c d -- c d a b ) 404 | >R ( a b c R: d ) 405 | -ROT ( c a b R: d ) 406 | R> ( c a b d ) 407 | -ROT ( c d a b ) 408 | ; 409 | 410 | : 2OVER ( a b c d -- a b c d a b ) 411 | 2>R 412 | 2DUP 413 | 2R> 414 | 2SWAP 415 | ; 416 | 417 | : WITHIN ( c a b -- within? ) 418 | OVER ( c a b a ) 419 | - ( c a range-size ) 420 | >R ( c a R: range-size ) 421 | - ( distance-from-beginning-of-the-range R: range-size ) 422 | R> ( distance-from-beginning-of-the-range range-size ) 423 | U< ( within? ) 424 | ; 425 | 426 | : MIN ( a b -- min(a, b) ) MINMAX DROP ; 427 | : MAX ( a b -- max(a, b) ) MINMAX NIP ; 428 | 429 | : DEPTH ( -- n ) 430 | S0 SP@ - CELL- 2 RSHIFT 431 | ; 432 | 433 | ( ---------- STRING LITERALS ------------------------------------------------------------------- ) 434 | 435 | ( string literals are compiled like this: 436 | 437 | +--+--+--+--+---+---+---+---+- - - - - - - -+ 438 | | LITSTRING | string-length | string-itself | 439 | +--+--+--+--+---+---+---+---+- - - - - - - -+ ) 440 | 441 | : LITSTRING 442 | R@ CELL+ ( string-address ) 443 | R@ @ ( string-address string-length ) 444 | R> OVER + CELL+ >R ( move the return address ) 445 | ; 446 | 447 | : COMPILE-STRING-CHARACTERS 448 | ( a helper function used to compile characters until a " ) 449 | BEGIN 450 | KEY-NOEOF DUP [CHAR] " <> 451 | WHILE 452 | C, 453 | REPEAT 454 | DROP 455 | ; 456 | 457 | : S" 458 | ( S" behaves correctly even in immediate mode ) 459 | STATE @ IF 460 | ( we're in compile mode, compile LITSTRING ) 461 | POSTPONE LITSTRING 462 | HERE ( save the address of the length word on the stack ) 463 | 0 , ( compile a dummy length ) 464 | COMPILE-STRING-CHARACTERS 465 | DUP ( length-addr length-addr ) 466 | CELL+ ( length-addr first-char-addr ) 467 | HERE ( length-addr first-char-addr byte-after-last-char-addr ) 468 | SWAP - ( length-addr length ) 469 | SWAP ! ( ) 470 | ELSE 471 | ( we're in immediate mode, use the currently free bytes but don't update HERE ) 472 | HERE ( first-char-addr ) 473 | COMPILE-STRING-CHARACTERS 474 | HERE ( first-char-addr byte-after-last-char-addr ) 475 | OVER - ( first-char-addr length ) 476 | OVER HERE! ( free the bytes ) 477 | THEN 478 | ; IMMEDIATE 479 | 480 | HIDE COMPILE-STRING-CHARACTERS 481 | 482 | ( ---------- VARIABLES ------------------------------------------------------------------------- ) 483 | 484 | : PUSH-IMM32, $68 C, , ; 485 | : NEXT, 486 | $AD C, ( lodsd ) 487 | $FF C, ( r=4 -> JMP r/m ) 488 | $E0 C, ( r/m: eax / r=4 ) 489 | ; 490 | 491 | : REL! ( value addr -- ) DUP >R CELL+ - R> ! ; 492 | : REL, ( value -- ) HERE CELL ALLOT REL! ; 493 | : REL@ ( addr -- value ) DUP @ CELL+ + ; 494 | 495 | : DOCOL [ HERE CELL- REL@ ] LITERAL ; 496 | : DOCOL, 497 | $E8 C, ( call ) 498 | DOCOL REL, 499 | ; 500 | 501 | : CREATE-BARE ( name u -- ) 502 | HERE LATEST @ - ( name u link ) 503 | HERE LATEST ! 504 | DUP $FF AND C, 505 | 8 RSHIFT C, ( name u ) 506 | DUP C, 507 | F_LENMASK AND 508 | BEGIN ( ptr u ) 509 | ?DUP 510 | WHILE 511 | >R 512 | DUP C@ C, 513 | CHAR+ R> 1- 514 | REPEAT 515 | DROP 516 | ; 517 | 518 | : CREATE 519 | WORD 520 | CREATE-BARE 521 | HERE 8 + PUSH-IMM32, NEXT, 522 | ; 523 | 524 | : MKNOP WORD CREATE-BARE NEXT, ; 525 | 526 | MKNOP ALIGN 527 | MKNOP ALIGNED 528 | 529 | : CONSTANT WORD CREATE-BARE PUSH-IMM32, NEXT, ; 530 | : VARIABLE CREATE CELL ALLOT ; 531 | HIDE PUSH-IMM32, 532 | HIDE NEXT, 533 | 534 | CHAR i EMIT 535 | 536 | ( ---------- COUNTED LOOPS --------------------------------------------------------------------- ) 537 | 538 | ( We can now define DO, ?DO, LOOP, +LOOP and LEAVE. It would be much easier if LEAVE didn't exist, 539 | but oh well. Because storing LEAVE's data on the stack would interfere with other control flow 540 | inside the loop, let's store it in a variable. ) 541 | 542 | VARIABLE LEAVE-PTR 543 | 544 | ( Let's consider the base case: only one LEAVE in the loop. This can be trivially handled by 545 | storing the address we need to patch in the variable. 546 | 547 | This would also work quite well with nested loops. All we need to do is store the old value of 548 | the variable on the stack when opening a loop. 549 | 550 | Finally, we can extend this to an arbitrary number of LEAVEs by threading a singly-linked list 551 | through the branch target address holes. ) 552 | 553 | ( The loop control variables are stored on the return stack, with the counter on top and the limit 554 | on the bottom. 555 | 556 | DO -> 2>R loop-inside 557 | 558 | ?DO -> (?DO) 0BRANCH [do the LEAVE thing but with a conditional jump] loop-inside 559 | ) 560 | 561 | : (?DO) ( limit counter R: retaddr -- R: limit counter retaddr ) 562 | R> ( limit counter retaddr ) 563 | -ROT ( retaddr limit counter ) 564 | 2DUP 2>R ( retaddr limit counter R: limit counter ) 565 | <> ( retaddr should-loop-at-all? ) 566 | SWAP >R ( should-loop-at-all? R: limit counter retaddr ) 567 | ; 568 | 569 | ( This means that LOOP should look for LEAVE one cells before the actual loop body. That will make 570 | it handle ?DO correctly, and because the execution token of 2>R is not the same as the execution 571 | token of LEAVE, this will not break DO. 572 | 573 | LOOP -> (LOOP) 0BRANCH loop-beginning 2RDROP 574 | +LOOP -> (+LOOP) 0BRANCH loop-beginning 2RDROP 575 | ^ LEAVE jumps here 576 | ) 577 | 578 | : (LOOP) ( R: limit old-counter retaddr ) 579 | R> 2R> ( retaddr limit old-counter ) 580 | 1+ ( retaddr limit new-counter ) 581 | 2DUP 2>R ( retaddr limit new-counter R: limit new-counter ) 582 | = ( retaddr should-stop-looping? R: limit new-counter ) 583 | SWAP >R ( should-stop-looping? R: limit new-counter retaddr ) 584 | ; 585 | 586 | : (+LOOP) ( diff R: limit old-counter retaddr ) 587 | R> ( diff retaddr ) 588 | SWAP ( retaddr diff ) 589 | 2R> ( retaddr diff limit old-counter ) 590 | 2 PICK OVER + ( retaddr diff limit old-counter new-counter ) 591 | ROT DUP >R ( retaddr diff old-counter new-counter limit R: limit ) 592 | -ROT DUP >R ( retaddr diff limit old-counter new-counter R: limit new-counter ) 593 | 3 PICK ( retaddr diff limit old-counter new-counter diff ) 594 | 0< IF SWAP THEN ( retaddr diff limit min-limit max-limit ) 595 | 1+ SWAP 1+ SWAP ( retaddr diff limit min-limit+1 max-limit+1 ) 596 | WITHIN ( retaddr diff should-stop-looping? ) 597 | NIP SWAP >R ( should-stop-looping? R: limit new-counter retaddr ) 598 | ; 599 | 600 | : LEAVE, 601 | HERE 602 | LEAVE-PTR @ , 603 | LEAVE-PTR ! 604 | ; 605 | 606 | : LEAVE POSTPONE BRANCH LEAVE, ; IMMEDIATE 607 | 608 | : UNLOOP 609 | POSTPONE 2RDROP 610 | ; IMMEDIATE 611 | 612 | : DO 613 | LEAVE-PTR @ 614 | 0 LEAVE-PTR ! 615 | POSTPONE 2>R 616 | HERE 617 | ; IMMEDIATE 618 | 619 | : ?DO 620 | LEAVE-PTR @ 621 | 0 LEAVE-PTR ! 622 | POSTPONE (?DO) 623 | POSTPONE 0BRANCH LEAVE, 624 | HERE 625 | ; IMMEDIATE 626 | 627 | : SOME-LOOP 628 | POSTPONE 0BRANCH , 629 | LEAVE-PTR @ 630 | BEGIN 631 | ?DUP 632 | WHILE 633 | DUP @ >R 634 | HERE SWAP ! 635 | R> 636 | REPEAT 637 | POSTPONE UNLOOP 638 | LEAVE-PTR ! 639 | ; 640 | 641 | : LOOP 642 | POSTPONE (LOOP) 643 | SOME-LOOP 644 | ; IMMEDIATE 645 | 646 | : +LOOP 647 | POSTPONE (+LOOP) 648 | SOME-LOOP 649 | ; IMMEDIATE 650 | 651 | : I ( -- n ) POSTPONE R@ ; IMMEDIATE 652 | : I-MAX ( -- n ) RP@ 12 - @ ; 653 | : J ( -- n ) RP@ 16 - @ ; 654 | : J-MAX ( -- n ) RP@ 20 - @ ; 655 | 656 | HIDE (?DO) 657 | HIDE (LOOP) 658 | HIDE (+LOOP) 659 | HIDE SOME-LOOP 660 | 661 | : LSHIFT 0 ?DO DUP + LOOP ; 662 | 663 | CHAR n EMIT 664 | ( ---------- STRING HANDLING ------------------------------------------------------------------- ) 665 | 666 | : SCASE 0 ; IMMEDIATE 667 | : SOF 668 | POSTPONE 2OVER 669 | POSTPONE S= 670 | POSTPONE IF 671 | POSTPONE 2DROP 672 | ; IMMEDIATE 673 | 674 | : SENDOF 675 | POSTPONE ELSE 676 | ; IMMEDIATE 677 | 678 | : SENDCASE 679 | POSTPONE 2DROP 680 | BEGIN 681 | ?DUP 682 | WHILE 683 | POSTPONE THEN 684 | REPEAT 685 | ; IMMEDIATE 686 | 687 | : TYPE ( c-addr u -- ) 0 ?DO DUP C@ EMIT 1+ LOOP DROP ; 688 | 689 | : ." 690 | POSTPONE S" 691 | STATE @ IF 692 | POSTPONE TYPE 693 | ELSE 694 | TYPE 695 | THEN 696 | ; IMMEDIATE 697 | 698 | : COUNT ( counted-string -- string strlen ) DUP 1+ SWAP C@ ; 699 | 700 | : EXECUTE [ HERE 12 + ] LITERAL ! 701 | DROP ( this DROP is overwritten by the previous line ) 702 | ; 703 | 704 | : CR #CR EMIT ; 705 | : SPACES 706 | 0 MAX 707 | 0 ?DO SPACE LOOP 708 | ; 709 | 710 | : ABORT 711 | CR 712 | ." ABORTED" 713 | CR 714 | BEGIN AGAIN 715 | ; 716 | 717 | ( ---------- MISCELLANEOUS --------------------------------------------------------------------- ) 718 | : FORGET 719 | WORD MUST-FIND 720 | DUP HERE! 721 | FOLLOW-LINK LATEST ! 722 | ; 723 | 724 | : CFA> ( xt -- dict ) 725 | LATEST @ 726 | BEGIN 727 | DUP >CFA 2 PICK = IF 728 | NIP EXIT 729 | THEN 730 | FOLLOW-LINK 731 | AGAIN 732 | ; 733 | 734 | : CFA>NAME CFA> >FLAGS COUNT F_LENMASK AND ; 735 | 736 | : (COMPILE-ONLY) 737 | STATE @ IF EXIT THEN 738 | R> CELL- ( address of (COMPILE-ONLY) xt ) 739 | 5 - ( address of CALL DOCOL, also the xt of the protected word ) 740 | CFA>NAME TYPE ." is compile only." 741 | ABORT 742 | ; 743 | 744 | : COMPILE-ONLY IMMEDIATE POSTPONE (COMPILE-ONLY) ; IMMEDIATE 745 | : RETRO 746 | WORD 747 | 2DUP MUST-FIND >CFA >R 748 | CREATE-BARE DOCOL, 749 | POSTPONE COMPILE-ONLY 750 | R> , 751 | POSTPONE ; 752 | ; 753 | 754 | RETRO IF 755 | RETRO ELSE 756 | RETRO THEN 757 | RETRO CASE 758 | RETRO ENDCASE 759 | RETRO OF 760 | RETRO ENDOF 761 | RETRO BEGIN 762 | RETRO AGAIN 763 | RETRO UNTIL 764 | RETRO WHILE 765 | RETRO REPEAT 766 | RETRO DO 767 | RETRO ?DO 768 | RETRO LOOP 769 | RETRO +LOOP 770 | RETRO LEAVE 771 | RETRO UNLOOP 772 | RETRO POSTPONE 773 | RETRO LITERAL 774 | RETRO ['] 775 | RETRO [CHAR] 776 | 777 | HIDE RETRO 778 | CHAR u EMIT 779 | 780 | VARIABLE RECURSE-XT 781 | 782 | ( RECURSE calls the word that's currently being defined - using the name of the word directly will 783 | compile a call to the previous definition. This is also an example of how to use COMPILE-ONLY. 784 | It would be simpler to just do LATEST @ >CFA, but that does not work with :NONAME. ) 785 | : RECURSE COMPILE-ONLY RECURSE-XT @ , ; IMMEDIATE 786 | : : WORD F_HIDDEN OR CREATE-BARE HERE RECURSE-XT ! DOCOL, ] ; 787 | : :NONAME HERE DUP RECURSE-XT ! DOCOL, ] ; 788 | 789 | : .DIGIT 790 | DUP 10 < IF 791 | [CHAR] 0 + EMIT 792 | ELSE 793 | 10 - [CHAR] A + EMIT 794 | THEN 795 | ; 796 | 797 | : .R ( u width -- ) 798 | 1- 0 MAX >R ( u ) ( R: width ) 799 | DUP 4 RSHIFT ?DUP IF 800 | R> RECURSE 801 | ELSE 802 | R> SPACES 803 | THEN 804 | $F AND .DIGIT 805 | ; 806 | 807 | : .X 0 .R ; 808 | : . .X SPACE ; 809 | : U. . ; 810 | 811 | : .S 812 | ." <" 813 | DEPTH .X 814 | ." > " 815 | DEPTH 0 ?DO 816 | S0 I 1+ CELLS - @ . 817 | LOOP 818 | CR 819 | ; 820 | 821 | : UPPER? [CHAR] A [CHAR] Z 1+ WITHIN ; 822 | : LOWER? [CHAR] a [CHAR] z 1+ WITHIN ; 823 | : DIGIT? [CHAR] 0 [CHAR] 9 1+ WITHIN ; 824 | : ALPHA? DUP UPPER? SWAP LOWER? OR ; 825 | : ALNUM? DUP ALPHA? SWAP DIGIT? OR ; 826 | 827 | : >UPPER ( char -- char ) 828 | DUP LOWER? IF 829 | [ CHAR A CHAR a - ] LITERAL + 830 | THEN 831 | ; 832 | 833 | : >LOWER ( char -- char ) 834 | DUP UPPER? IF 835 | [ CHAR a CHAR A - ] LITERAL + 836 | THEN 837 | ; 838 | 839 | : FILL ( c-addr u char -- ) 840 | -ROT 0 ?DO 841 | ( char c-addr ) 842 | 2DUP C! 1+ 843 | LOOP 844 | 2DROP 845 | ; 846 | 847 | ( redefine FILE to expand the dot in the filename to the appropriate amount of spaces and convert 848 | the filename to uppercase ) 849 | 850 | CREATE BUFFER 11 ALLOT 851 | 852 | : LENGTH-CHECK ( curr-destination curr-maximum -- curr-destination | ABORT ) 853 | BUFFER + OVER < IF 854 | ." Error: filename too long" ABORT 855 | THEN 856 | ; 857 | 858 | : FILE ( filename filename-length -- ) 859 | ." Reading " 860 | 2DUP TYPE CR 861 | BUFFER TUCK 11 BL FILL ( source destination count ) 862 | 0 ?DO ( source destination ) 863 | OVER I + C@ ( source destination char ) 864 | DUP [CHAR] . = IF ( source destination char ) 865 | DROP ( source destination ) 866 | 8 LENGTH-CHECK ( source destination ) 867 | DROP [ BUFFER 8 + ] LITERAL ( source destination ) 868 | ELSE ( source destination char ) 869 | >UPPER OVER C! 1+ ( source destination ) 870 | THEN ( source destination ) 871 | 11 LENGTH-CHECK ( source destination ) 872 | LOOP ( source destination ) 873 | 2DROP 874 | BUFFER FILE ( old implementation, not recursion ) 875 | ; 876 | 877 | HIDE BUFFER 878 | HIDE LENGTH-CHECK 879 | CHAR x EMIT 880 | 881 | : CONCLUDE" 882 | POSTPONE S" 883 | ROOT 884 | FILE 885 | ; 886 | 887 | : ROLL 888 | SP@ OVER 1+ CELLS + @ SWAP 889 | 0 SWAP ?DO 890 | SP@ DUP I CELLS + @ SWAP I 1+ CELLS + ! 891 | -1 +LOOP 892 | DROP 893 | ; 894 | 895 | : 2@ DUP CELL+ @ SWAP @ ; 896 | : 2! SWAP OVER ! CELL+ ! ; 897 | : 2R@ R> 2R> 2DUP 2>R ROT >R ; 898 | MKNOP CHARS 899 | 900 | : CMOVE 901 | 0 ?DO ( src dst ) 902 | OVER C@ 903 | OVER C! 904 | CHAR+ >R CHAR+ R> 905 | LOOP 2DROP 906 | ; 907 | 908 | : MOVE 909 | >R 910 | 2DUP < IF 911 | 0 R> 1- ?DO 912 | OVER I + C@ 913 | OVER I + C! 914 | -1 +LOOP 915 | 2DROP 916 | ELSE 917 | R> CMOVE 918 | THEN 919 | ; 920 | 921 | : DEFER-DEFAULT 922 | CR ." DEFER-DEFAULT: " 923 | 5 - ( because a CALL is 5 bytes long ) 924 | CFA>NAME TYPE ." used before being defined with IS" 925 | ABORT 926 | ; 927 | 928 | : DEFER 929 | WORD CREATE-BARE 930 | $E8 C, ( call ) 931 | ['] DEFER-DEFAULT REL, 932 | ; 933 | 934 | : DEFER@ ( xt -- inner ) 935 | 1+ ( skip the jmp/call ) 936 | REL@ 937 | ; 938 | 939 | : DEFER! ( new xt -- ) 940 | $E9 OVER C! 941 | 1+ REL! 942 | ; 943 | 944 | : IS 945 | STATE @ IF 946 | POSTPONE ['] POSTPONE DEFER! 947 | ELSE 948 | ' DEFER! 949 | THEN 950 | ; IMMEDIATE 951 | 952 | : ACTION-OF 953 | STATE @ IF 954 | POSTPONE ['] POSTPONE DEFER@ 955 | ELSE 956 | ' DEFER@ 957 | THEN 958 | ; IMMEDIATE 959 | 960 | :NONAME 961 | 2DUP 962 | FIND 963 | DUP 0= IF 964 | ." MUST-FIND: can't find " 965 | DROP TYPE ABORT 966 | THEN 967 | NIP NIP 968 | ; IS MUST-FIND 969 | 970 | :NONAME 971 | KEY 972 | DUP 0= IF 973 | ." KEY-NOEOF: EOF" ABORT 974 | THEN 975 | ; IS KEY-NOEOF 976 | 977 | CR 978 | CONCLUDE" TEST.FRT" 979 | -------------------------------------------------------------------------------- /image-files/test.c: -------------------------------------------------------------------------------- 1 | #if TRUE 2 | one 3 | two 4 | three 5 | #elif TRUE 6 | four 7 | five 8 | six 9 | #elif FALSE 10 | seven 11 | eight 12 | nine 13 | #else 14 | ten 15 | eleven 16 | twelve 17 | #endif 18 | end one 19 | end two 20 | end three 21 | -------------------------------------------------------------------------------- /image-files/test.frt: -------------------------------------------------------------------------------- 1 | \ a portion of the Forth core test suite 2 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 3 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 4 | CREATE ACTUAL-RESULTS $20 CELLS ALLOT 5 | VARIABLE ACTUAL-DEPTH 6 | VARIABLE START-DEPTH 7 | 8 | : EMPTY-STACK S0 SP! ; 9 | : ERROR TYPE CR EMPTY-STACK ABORT ; 10 | 11 | : T{ DEPTH START-DEPTH ! ; 12 | : -> 13 | DEPTH DUP ACTUAL-DEPTH ! 14 | START-DEPTH @ - 0 ?DO 15 | ACTUAL-RESULTS I CELLS + ! 16 | LOOP 17 | ; 18 | 19 | : }T 20 | DEPTH ACTUAL-DEPTH @ = IF 21 | DEPTH START-DEPTH @ - 0 ?DO 22 | ACTUAL-RESULTS I CELLS + @ 23 | <> IF 24 | S" INCORRECT RESULT" ERROR LEAVE 25 | THEN 26 | LOOP 27 | ELSE 28 | S" WRONG NUMBER OF RESULTS" ERROR 29 | THEN 30 | ; 31 | 32 | : TESTING 33 | ." TESTING " 34 | BEGIN 35 | KEY DUP #CR <> 36 | WHILE 37 | EMIT 38 | REPEAT 39 | DROP 40 | CR 41 | ; 42 | 43 | CONCLUDE" CORETEST.FRT" 44 | -------------------------------------------------------------------------------- /run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | qemu-system-i386 -curses -drive format=raw,file=gen/2klinux.img 3 | -------------------------------------------------------------------------------- /stage0.s: -------------------------------------------------------------------------------- 1 | ; This Forth implementation is based on jonesforth - https://github.com/nornagon/jonesforth 2 | ; Any similarities are probably not accidental. 3 | 4 | ; The first bootstrap stage of 2K Linux is implemented as a bootloader. This bootsector implements 5 | ; FAT32, with the assumption that the sector and cluster sizes are both 512 bytes. Long file names 6 | ; are not supported, but their presence for files we don't care about is not harmful. All disk I/O 7 | ; is done using EDD, which means won't work on very old PCs (like pre-Pentium old) or when booting 8 | ; from booting from a floppy. Both of these problems don't concern me a lot, primarily because CHS 9 | ; addressing isn't the most pleasant to work with. Patches welcome. The FAT partition contains all 10 | ; of the necessary source code, and should be the first physical partition of the drive. 11 | 12 | ; EBP is always set to the value 0x7C00 to generate shorter instructions for accessing some memory 13 | ; memory locations. Constants that start with `d` represent an offset from EBP. Almost all of them 14 | ; are also defined in image-files/stage1.frt. It is imperative that these values match between the 15 | ; two files. 16 | 17 | ; We use a part of the code section as variables after executing it: 18 | ; 7C00 - 7C0F -> The EDD disk packet 19 | %define dDiskPacket 0 20 | %define dDiskPacketDestOffset 4 21 | %define dDiskPacketDestSegment 6 22 | %define dDiskPacketLBA 8 23 | ; 7C10 - 7C23 -> Forth variables, all are 4 bytes long. More detail can be found in stage1.frt. 24 | %define dBLK 16 ; The currently loaded cluster 25 | %define dTOIN 20 ; The address of the next byte KEY will read, relative to FileBuffer 26 | %define dLATEST 24 ; The LFA of the last Forth word defined. 27 | %define dHERE 28 ; The address of the first free byte of Forth memory. 28 | %define dSTATE 32 ; 1 if compiling words, 0 if interpreting. 29 | %define dLENGTH 36 ; The number of characters left in the file currently being read 30 | 31 | ; The last two partition entries are reused as a buffer for WORD. 32 | 33 | ; The general memory map looks like this: 34 | ; 0000 - 03FF -> Real mode interrupt vector table 35 | ; 0400 - 04FF -> The BIOS data area 36 | ; 0500 - ???? -> Forth return stack 37 | %define ForthR0 0x0500 38 | 39 | ; ???? - 7BFF -> the stack, used as the Forth parameter stack 40 | ; 7C00 - 7DFF -> The MBR - the first part of this file 41 | ; 7E00 - 83FF -> 3 sectors loaded from the FAT filesystem - the second part of this file 42 | ORG 0x7C00 43 | 44 | ; 8400 - 85FF -> A buffer for one sector of a file or directory 45 | %define FileBuffer 0x8400 46 | 47 | ; 8600 - 87FF -> A buffer for one sector of FAT 48 | %define FATBuffer 0x8600 49 | 50 | ; 8800 - 89FF -> A buffer for the sector with BPB 51 | %define BPBBuffer 0x8800 52 | 53 | ; 8A00 - 7FFFF -> The Forth memory. This is where the definitions of all words are stored, except 54 | ; the ones defined in this file. HERE is initialized to point to the beginning of 55 | ; this memory region. 56 | %define ForthMemoryStart 0x8A00 57 | 58 | ; 80000 - 9FFFF -> Mostly unassigned, but the end is used by the Extended BIOS Data Area. Its size 59 | ; varies, and this 128 KiB is the maximum 60 | ; A0000 - BFFFF -> Video RAM 61 | ; C0000 - FFFFF -> ROMs and memory mapped hardware 62 | 63 | %define SectorLength 512 64 | 65 | ; Addresses of the values in the BPB we need to correctly parse the FAT filesystem. 66 | %define BPBReservedSectors BPBBuffer+14 67 | %define BPBFATCount BPBBuffer+16 68 | %define BPBSectorsPerFAT BPBBuffer+36 69 | %define BPBRootCluster BPBBuffer+44 70 | 71 | %macro NEXT 0 72 | lodsd 73 | jmp eax 74 | %endmacro 75 | 76 | %define F_IMMED 0x80 77 | %define F_HIDDEN 0x20 78 | %define F_LENMASK 0x1f 79 | 80 | ; BIOS loads the first sector of the hard drive at 7C00 and, if the boot signature at offset 0x1FE 81 | ; matches, jumps here, in 16-bit Real Mode. 82 | BITS 16 83 | 84 | MBR: 85 | ; While all BIOSes agree about the destination of the jump, this cannot be said about the value of 86 | ; IP - the memory segmentation of x86 present in Real Mode makes it possible to encode the address 87 | ; in two different ways, i. e. 0000:7C00 (the sane way) and 07C0:0000 (the I am a snowflake way). 88 | 89 | ; Because jumps and calls are relative on x86, the difference is not immediately problematic, 90 | ; which is probably why the bug went unnoticed until it was too late. However, trying to write 91 | ; code that could be loaded at more than one address without the help of relocation table is 92 | ; tricky. Hence, let's correct the faulty BIOSes with a long jump. 93 | jmp 0:start 94 | start: 95 | ; Since an interrupt can happen at any time, and interrupts use the stack, one has to disable them 96 | ; before moving the stack, since doing so is not an atomic operation. 97 | cli 98 | mov bp, MBR 99 | mov sp, bp 100 | 101 | ; Here, we set up the segment registers. All real mode code operates in the 00000-0FFFF range, and 102 | ; therefore no values other than zero are necessary... 103 | xor cx, cx 104 | mov ss, cx 105 | mov ds, cx 106 | mov es, cx 107 | 108 | ; ... except for probing the A20 gate, for which access to the segment FFFF is required. 109 | dec cx 110 | mov fs, cx 111 | 112 | ; When BIOS jumps to 0000:7C00, a few valuable values are left in the registers. One of them is of 113 | ; particular interest to any developer of a bootloader or any code that works on a similar level - 114 | ; the DL register contains the BIOS number of the disk the MBR was loaded from, which is primarily 115 | ; used as a parameter to the BIOS disk calls. 116 | 117 | ; You will see self modifying code in a few places. Every label used to mark these situations uses 118 | ; a suffix `Patch` and, perhaps more importantly, the prefix `..@`, which decouples the label from 119 | ; the system of global and local labels. Please refer to yasm's documentation for more details. 120 | mov byte[..@DiskNumberPatch], dl 121 | sti 122 | 123 | ; Setting the video mode makes screen output work even if the BIOS leaves the VGA card in graphics 124 | ; mode, like some new BIOSes like to do. This also clears the screen from any BIOS messages. 125 | mov ax, 0x0003 126 | int 0x10 127 | 128 | ; Interpreting a FAT filesystem starts with the BIOS Parameter Block, which is stored in the first 129 | ; sector of the partition. 130 | mov eax, dword[P1LBA] 131 | ; What follows is the first instruction that isn't overlapping with the variable area at all. 132 | mov di, BPBBuffer 133 | call near DiskRead 134 | 135 | ; First FAT sector = Partition Start LBA + Reserved Sector Count 136 | movzx ebx, word[BPBReservedSectors] 137 | add ebx, dword[P1LBA] 138 | mov dword[..@FirstFATSectorPatch], ebx 139 | 140 | ; Cluster Zero LBA = First FAT sector + FAT count * Sectors Per FAT - 2 141 | mov eax, dword[BPBSectorsPerFAT] 142 | movzx ecx, byte[BPBFATCount] 143 | mul ecx 144 | add eax, ebx 145 | sub eax, 2 146 | mov dword[..@ClusterZeroLBAPatch], eax 147 | 148 | mov di, StageZeroFilename 149 | push word LoadPartTwo 150 | ; fallthrough 151 | ; push X / jmp Y is equivalent to call near Y / jmp X, but here jmp Y is a noop, so it was omitted 152 | ; TL;DR: call near FindFileRoot / jmp LoadPartTwo 153 | 154 | ; ---------- PARSING FAT DIRECTORIES ------------------------------------------------------------- 155 | 156 | ; In a FAT filesystem, a directory is just a file that stores constant-size directory entries. One 157 | ; directory entry contains: 158 | ; - a filename 159 | ; - an attribute byte 160 | ; - the number of the first cluster of the file the entry describes 161 | ; - the size of the file 162 | ; - a lot of information we don't care about like the creation and modification date. 163 | 164 | %define FATNameLength 11 165 | %define DirAttributes 11 166 | %define DirHighCluster 20 167 | %define DirLowCluster 26 168 | %define DirFileSize 28 169 | %define DirEntrySize 32 170 | 171 | ; The attribute byte is a bit field: 172 | ; - bit 0 (value 1): if set, the file is read only 173 | ; - bit 1 (value 2): if set, the file is hidden 174 | ; - bit 2 (value 4): if set, the file is marked as a system file 175 | ; - bit 3 (value 8): if set, this is not a file but a volume ID 176 | ; - bit 4 (value 16): if set, the file is a directory 177 | ; - bit 5 (value 32): if set, the file has been changed since this bit has last been cleared - it 178 | ; is commonly used by archiving/backup software. 179 | ; If the entry is not a file but a long file name entry, it is marked as read only, hidden, system 180 | ; and volume ID, which is unambiguous because volume ID excludes all other three. 181 | 182 | %define AttrReadOnly 1 183 | %define AttrHidden 2 184 | %define AttrSystem 4 185 | %define AttrVolumeID 8 186 | %define AttrDirectory 16 187 | %define AttrArchive 32 188 | 189 | ; If the entry has either of the following bits set, ignore it 190 | %define AttrMaskIgnore AttrVolumeID | AttrSystem | AttrHidden 191 | 192 | ; FindFileRoot: like FindFile, but looks in the root directory of the partition, as opposed to the 193 | ; one currently loaded. 194 | FindFileRoot: 195 | push di 196 | mov eax, dword[BPBRootCluster] 197 | call near ReadCluster 198 | pop di 199 | ; fallthrough 200 | 201 | ; FindFile: read the currently loaded file as a directory, find the file with a specified name and 202 | ; load its first cluster. Also sets >IN and LENGTH appropriately. 203 | ; Input: 204 | ; DI = pointer to filename 205 | FindFile: 206 | ; Set >IN to 0 207 | xor ecx, ecx 208 | mov dword[byte bp+dTOIN], ecx 209 | 210 | ; Initialize the loop counter for this cluster 211 | mov cl, SectorLength / DirEntrySize 212 | ; SI holds a pointer to the entry currently being processed 213 | mov si, FileBuffer 214 | .loop: 215 | ; If the filename starts with a zero, the directory ended, which means we couldn't find the file. 216 | mov al, byte[si] 217 | or al, al 218 | jz short .notfound 219 | ; Usually, one should check whether the first byte is 0xE5 (if so, you should skip the entry), but 220 | ; it won't won't match the filename anyway. 221 | 222 | ; Check the attribute byte for any flags that indicate we should skip it. 223 | test byte[byte si+DirAttributes], AttrMaskIgnore 224 | jnz short .next 225 | 226 | ; Before comparing the filename, CL, SI and DI need to be pushed on the stack, but remembering all 227 | ; registers is shorter and doesn't hurt. 228 | pusha 229 | mov cl, FATNameLength 230 | .cmploop: 231 | lodsb 232 | ; Convert the bytes coming from disk to uppercase. 233 | cmp al, 'a' 234 | jb .noconvert 235 | cmp al, 'z' 236 | ja .noconvert 237 | sub al, 'a' - 'A' 238 | .noconvert: 239 | cmp al, byte[di] 240 | jne short .nomatch 241 | inc di 242 | loop .cmploop 243 | popa 244 | 245 | ; We have a match! Set LENGTH and load the first cluster. 246 | mov eax, dword[byte si+DirFileSize] 247 | mov dword[byte bp+dLENGTH], eax 248 | ; Load the doubleword two bytes earlier to make the desired part land in the more significant word 249 | mov eax, dword[byte si+DirHighCluster-2] 250 | mov ax, word[byte si+DirLowCluster] 251 | jmp short ReadCluster 252 | .nomatch: 253 | popa 254 | .next: 255 | add si, DirEntrySize 256 | loop .loop 257 | ; Load next cluster of the directory and start from the beginning 258 | push di 259 | call near ReadNextCluster 260 | pop di 261 | jnc short FindFile 262 | .notfound: 263 | mov cx, 13 264 | NotFoundError: 265 | mov si, di 266 | call near PrintTextLength 267 | jmp short PrintGenericErrorMsg 268 | 269 | ReadNextCluster: 270 | ; one FAT entry is 4 bytes, a sector is 512 bytes, 512 / 4 = 128, log_2 128 = 7 271 | mov eax, dword[byte bp+dBLK] 272 | shr eax, 7 273 | db 0x66, 0x05 ; add eax, imm32 274 | ..@FirstFATSectorPatch: 275 | dd 0 ; modified during initialisation 276 | 277 | mov di, FATBuffer 278 | call near DiskRead 279 | 280 | movzx bx, byte[byte bp+dBLK] 281 | shl bl, 1 ; discard the top bit 282 | shl bx, 1 283 | mov eax, dword[di+bx] ; DI is preserved during DiskRead 284 | and eax, 0x0fffffff ; fun fact: FAT32 uses only the bottom 28 bits, the top 4 are reserved 285 | cmp eax, 0x0ffffff8 ; if the carry is set, it means "below", i. e. go to ReadCluster 286 | cmc ; cmc flips the carry to make "set carry" mean "EOF" 287 | jc short ..@Return 288 | 289 | ReadCluster: 290 | mov dword[bp+dBLK], eax 291 | db 0x66, 0x05 ; add eax, imm32 292 | ..@ClusterZeroLBAPatch: 293 | dd 0 ; modified during initialisation 294 | 295 | db 0xBF, 0x00 ; mov di, imm16 296 | ..@ReadClusterDestinationPatch: 297 | db FileBuffer>>8 ; modified when loading the remaining 1.5K of this file 298 | ; fallthrough 299 | 300 | ; DiskRead: read a sector 301 | ; Input: 302 | ; EAX = LBA 303 | ; DI = output buffer 304 | DiskRead: 305 | mov dword[byte bp+dDiskPacketLBA], eax 306 | xor eax, eax 307 | mov dword[byte bp+dDiskPacketLBA+4], eax 308 | mov dword[byte bp+dDiskPacket], 0x10010 309 | mov word[byte bp+dDiskPacketDestOffset], di 310 | mov word[byte bp+dDiskPacketDestSegment], ax 311 | db 0xB2 ; mov dl, imm8 312 | ..@DiskNumberPatch: 313 | db 0xFF ; modified during initialisation 314 | mov ah, 0x42 315 | mov si, bp 316 | int 0x13 317 | jnc short ..@Return 318 | 319 | ; disk error handling 320 | mov al, ah 321 | shr al, 4 322 | call near PrintHexDigit 323 | 324 | mov al, ah 325 | and al, 0x0f 326 | call near PrintHexDigit 327 | 328 | mov si, DiskErrorMsg 329 | ; fallthrough 330 | Error: 331 | call near PrintText 332 | PrintGenericErrorMsg: 333 | mov si, GenericErrorMsg 334 | call near PrintText 335 | cli 336 | hlt 337 | 338 | PrintHexDigit: 339 | add al, '0' 340 | cmp al, '9' 341 | jbe short PrintChar 342 | add al, 'A' - '0' - 0x0A 343 | ; fallthrough 344 | PrintChar: 345 | pusha 346 | xor bx, bx 347 | mov ah, 0x0e 348 | int 0x10 349 | popa 350 | ..@Return: 351 | ret 352 | 353 | ; Print a Pascal-style string. 354 | ; Input: 355 | ; DS:SI -> the string 356 | PrintText: 357 | lodsb 358 | movzx cx, al 359 | ; Print a string with the length passed in explicitly. 360 | ; Input: 361 | ; DS:SI -> the string 362 | ; CX = length 363 | PrintTextLength: 364 | lodsb 365 | call near PrintChar 366 | loop PrintTextLength 367 | ret 368 | 369 | StageZeroFilename: 370 | db 'STAGE0 BIN' 371 | 372 | A20ErrorMsg: 373 | db 3, 'A20' 374 | 375 | DiskErrorMsg: 376 | db 3, 'DSK' 377 | 378 | GenericErrorMsg: 379 | db 4, ' ERR' 380 | 381 | EOFMessage: 382 | db 3, 'EOF' 383 | 384 | GDT: 385 | dw GDT_End-GDT-1 386 | dd GDT 387 | dw 0 388 | 389 | %define Selector_Code16 0x08 390 | dw 0xffff 391 | dw 0 392 | db 0 393 | db 0x9a 394 | db 0x8f 395 | db 0 396 | 397 | %define Selector_Code32 0x10 398 | dw 0xffff 399 | dw 0 400 | db 0 401 | db 0x9a 402 | db 0xcf 403 | db 0 404 | 405 | %define Selector_Data 0x18 406 | dw 0xffff 407 | dw 0 408 | db 0 409 | db 0x92 410 | db 0xcf 411 | db 0 412 | GDT_End: 413 | 414 | LoadPartTwo: 415 | mov byte[..@ReadClusterDestinationPatch], 0x7E 416 | .loop: 417 | call near ReadNextCluster 418 | jc short A20 419 | add byte[..@ReadClusterDestinationPatch], 2 420 | jmp short .loop 421 | 422 | KBC_SendCommand: 423 | in al, 0x64 424 | test al, 2 425 | jnz KBC_SendCommand 426 | pop si 427 | lodsb 428 | out 0x64, al 429 | jmp si 430 | 431 | MBR_FREESPACE EQU 446 - ($ - $$) 432 | times MBR_FREESPACE db 0 433 | 434 | PartitionTable: 435 | ; The following 64 bytes will be overwritten by the partition table. In the first four of them are 436 | ; stored the amounts of free space in each of the two code regions, which are calculated easily by 437 | ; the assembler. 438 | dw MBR_FREESPACE ; could be replaced with 0 with no consequencess 439 | dw REST_FREESPACE ; same 440 | times 4 db 0 441 | 442 | P1LBA: dd 0 443 | P1Length: dd 0 444 | 445 | times 16 db 0 446 | 447 | WORDBuffer: 448 | 449 | times 32 db 0 450 | 451 | dw 0xaa55 452 | 453 | A20: 454 | call near Check_A20 455 | mov ax, 0x2401 456 | int 0x15 457 | call near Check_A20 458 | 459 | call near KBC_SendCommand 460 | db 0xAD 461 | 462 | call near KBC_SendCommand 463 | db 0xD0 464 | 465 | .readwait: 466 | in al, 0x64 467 | test al, 1 468 | jz .readwait 469 | 470 | in al, 0x60 471 | push ax 472 | 473 | call near KBC_SendCommand 474 | db 0xD1 475 | 476 | pop ax 477 | or al, 2 478 | out 0x60, al 479 | 480 | call near KBC_SendCommand 481 | db 0xAE 482 | 483 | call near Check_A20 484 | in al, 0x92 485 | or al, 2 486 | and al, 0xfe 487 | out 0x92, al 488 | call near Check_A20 489 | mov si, A20ErrorMsg 490 | jmp Error 491 | 492 | Check_A20: 493 | ; we have set DS to 0 and FS to 0xFFFF and the very beginning 494 | cli 495 | mov si, 0x7dfe 496 | .loop: 497 | mov al, byte[si] 498 | inc byte[fs:si+0x10] 499 | wbinvd 500 | cmp al, byte[si] 501 | jz .ok 502 | loop .loop 503 | ret 504 | .ok: 505 | pop ax ; discard the return address 506 | push dword PM_Entry-2 507 | jmp short GoPM 508 | 509 | BITS 32 510 | CallRM: 511 | xchg ebp, eax 512 | mov eax, dword[esp] 513 | mov eax, dword[eax] 514 | jmp Selector_Code16:.code16 515 | BITS 16 516 | .code16: 517 | push word GoPM 518 | push ax 519 | mov eax, cr0 520 | dec ax 521 | mov cr0, eax 522 | jmp 0:.rmode 523 | .rmode: 524 | xor ax, ax 525 | mov ds, ax 526 | mov es, ax 527 | mov ss, ax 528 | xchg eax, ebp 529 | mov bp, MBR 530 | sti 531 | ret 532 | GoPM: 533 | cli 534 | lgdt [GDT] 535 | mov ebp, eax 536 | mov eax, cr0 537 | inc ax 538 | mov cr0, eax 539 | jmp Selector_Code32:.code32 540 | BITS 32 541 | .code32: 542 | mov ax, Selector_Data 543 | mov ds, ax 544 | mov es, ax 545 | mov ss, ax 546 | movzx esp, sp 547 | add dword[esp], 2 548 | mov eax, ebp 549 | mov ebp, MBR 550 | ret 551 | 552 | ; Here is where the actual Forth implementation starts. In contrast to jonesforth, we are using 553 | ; direct threaded code. Also, the link fields in the dictionary are relative. 554 | 555 | StageOneFilename: 556 | db 'STAGE1 FRT' 557 | 558 | PM_Entry: 559 | mov di, StageOneFilename 560 | call near CallRM 561 | dw FindFileRoot 562 | 563 | mov dword[ebp+dLATEST], LATESTInitialValue 564 | 565 | xor eax, eax 566 | mov dword[ebp+dSTATE], eax 567 | 568 | mov ah, ForthMemoryStart >> 8 569 | mov dword[ebp+dHERE], eax 570 | 571 | ; fallthrough 572 | 573 | INTERPRET: 574 | call near doWORD 575 | mov ebx, eax 576 | 577 | mov edx, [ebp+dLATEST] 578 | .find: 579 | lea esi, [edx+2] 580 | lodsb 581 | and al, F_HIDDEN|F_LENMASK 582 | cmp al, cl 583 | jnz .next 584 | 585 | mov edi, ebx 586 | push ecx 587 | repe cmpsb 588 | pop ecx 589 | je short .found 590 | .next: 591 | movzx eax, word[edx] 592 | or eax, eax 593 | jz short .handle_number 594 | sub edx, eax 595 | jmp short .find 596 | .found: 597 | xchg eax, esi 598 | mov ebx, [ebp+dSTATE] 599 | or ebx, ebx 600 | jz short .interpret ; if we're in interpreting mode, execute the word 601 | 602 | test byte[edx+2], F_IMMED 603 | jz short .comma_next ; not immediate, compile it 604 | 605 | .interpret: 606 | mov esi, INTERPRET_LOOP 607 | mov edi, ForthR0 608 | jmp eax 609 | 610 | .interpret_number: 611 | push eax 612 | .go_again: 613 | jmp short INTERPRET 614 | 615 | .handle_number: 616 | push ecx 617 | push esi 618 | mov esi, WORDBuffer 619 | mov word[.negate_patch], 0x9066 ; two byte nop - assume we don't need to negate 620 | xor ebx, ebx 621 | mul ebx ; zeroes EAX, EBX and EDX 622 | mov dl, 10 623 | mov bl, [esi] 624 | cmp bl, '$' 625 | jne .nothex 626 | mov dl, 16 627 | inc esi 628 | dec ecx 629 | .nothex: 630 | cmp bl, '-' 631 | jne .loop 632 | mov word[.negate_patch], 0xd8f7 633 | inc esi 634 | dec ecx 635 | .loop: 636 | mov bl, [esi] 637 | sub bl, '0' 638 | jb .end 639 | cmp bl, 9 640 | jbe .gotdigit 641 | sub bl, 'A' - '0' 642 | jb .end 643 | add bl, 10 644 | .gotdigit: 645 | cmp bl, dl 646 | jae .end 647 | push edx 648 | mul edx 649 | add eax, ebx 650 | pop edx 651 | inc esi 652 | loop .loop 653 | .end: 654 | .negate_patch: 655 | dw 0xd8f7 ; either `neg eax' or `nop' 656 | pop esi 657 | 658 | or ecx, ecx 659 | pop ecx 660 | jnz short .error 661 | 662 | mov ebx, [ebp+dSTATE] 663 | or ebx, ebx 664 | jz short .interpret_number 665 | 666 | push eax 667 | mov eax, LIT 668 | call near doCOMMA 669 | pop eax 670 | 671 | .comma_next: 672 | call near doCOMMA 673 | jmp short .go_again 674 | 675 | .error: 676 | mov di, WORDBuffer 677 | call near CallRM 678 | dw NotFoundError 679 | 680 | doCOMMA: 681 | lea edx, [ebp+dHERE] 682 | mov ebx, [edx] 683 | mov [ebx], eax 684 | add dword[edx], 4 685 | ret 686 | 687 | INTERPRET_LOOP: 688 | dd INTERPRET 689 | 690 | ; ( -- ) 691 | ; Return to executing its callee. Appended automatically by `;` at the end of all definitions, but 692 | ; may be used explicitly, usually conditionally 693 | EXIT: 694 | sub edi, 4 695 | mov esi, [edi] 696 | jmp short doNEXT 697 | 698 | LIT: 699 | lodsd 700 | push eax 701 | jmp short doNEXT 702 | 703 | link_SUB: 704 | dw 0 705 | db 1, '-' 706 | pop eax 707 | sub dword[esp], eax 708 | jmp short doNEXT 709 | 710 | link_ZEQ: 711 | dw $-link_SUB 712 | db 2, '0=' 713 | pop ecx 714 | xor eax, eax 715 | or ecx, ecx 716 | setnz al 717 | dec eax 718 | push eax 719 | jmp short doNEXT 720 | 721 | link_ULT: 722 | dw $-link_ZEQ 723 | db 2, 'U<' 724 | pop ecx 725 | pop ebx 726 | xor eax, eax 727 | cmp ebx, ecx 728 | setnb al 729 | dec eax 730 | push eax 731 | jmp short doNEXT 732 | 733 | link_AND: 734 | dw $-link_ULT 735 | db 3, 'AND' 736 | pop eax 737 | and dword[esp], eax 738 | jmp short doNEXT 739 | 740 | link_RSHIFT: 741 | dw $-link_AND 742 | db 6, 'RSHIFT' 743 | pop ecx 744 | shr dword[esp], cl 745 | jmp short doNEXT 746 | 747 | link_STORE: 748 | dw $-link_RSHIFT 749 | db 1, '!' 750 | pop ebx 751 | pop eax 752 | mov [ebx], eax 753 | jmp short doNEXT 754 | 755 | link_FETCH: 756 | dw $-link_STORE 757 | db 1, '@' 758 | pop eax 759 | mov eax, [eax] 760 | push eax 761 | jmp short doNEXT 762 | 763 | link_RPSTORE: 764 | dw $-link_FETCH 765 | db 3, 'RP!' 766 | pop edi 767 | jmp short doNEXT 768 | 769 | link_RPFETCH: 770 | dw $-link_RPSTORE 771 | db 3, 'RP@' 772 | push edi 773 | jmp short doNEXT 774 | 775 | DOCOL: 776 | mov [edi], esi 777 | add edi, 4 778 | pop esi 779 | doNEXT: 780 | NEXT 781 | 782 | link_SPSTORE: 783 | dw $-link_RPFETCH 784 | db 3, 'SP!' 785 | pop esp 786 | jmp short doNEXT 787 | 788 | link_SPFETCH: 789 | dw $-link_SPSTORE 790 | db 3, 'SP@' 791 | mov eax, esp 792 | push eax 793 | jmp short doNEXT 794 | 795 | link_KEY: 796 | dw $-link_SPFETCH 797 | db 3, 'KEY' 798 | call near doKEY 799 | push eax 800 | jmp short doNEXT 801 | 802 | link_EMIT: 803 | dw $-link_KEY 804 | db 4, 'EMIT' 805 | pop eax 806 | call near CallRM 807 | dw PrintChar 808 | jmp short doNEXT 809 | 810 | ; ( cluster -- ) 811 | ; A thin wrapper around ReadCluster 812 | link_LOAD: 813 | dw $-link_EMIT 814 | db 4, 'LOAD' 815 | pop eax 816 | pushad 817 | call near CallRM 818 | dw ReadCluster 819 | popad 820 | jmp short doNEXT 821 | 822 | ; ( name-pointer -- ) 823 | ; A thin wrapper around FindFile 824 | link_FILE: 825 | dw $-link_LOAD 826 | db 4, 'FILE' 827 | pop eax 828 | xchg edi, eax 829 | pushad 830 | call near CallRM 831 | dw FindFile 832 | popad 833 | xchg edi, eax 834 | jmp short doNEXT 835 | 836 | link_COLON: 837 | dw $-link_FILE 838 | db 1, ':' 839 | COLON: 840 | call near doWORD 841 | or cl, F_HIDDEN 842 | 843 | push edi 844 | push esi 845 | xchg esi, eax 846 | mov edi, [ebp+dHERE] 847 | mov eax, edi 848 | sub eax, [ebp+dLATEST] 849 | mov [ebp+dLATEST], edi 850 | stosw 851 | mov al, cl 852 | stosb 853 | and cl, F_LENMASK 854 | rep movsb 855 | mov [ebp+dHERE], edi 856 | pop esi 857 | 858 | mov edi, [ebp+dHERE] 859 | mov al, 0xE8 860 | stosb 861 | mov eax, DOCOL-4 ; eax = DOCOL - (edi + 4) 862 | sub eax, edi 863 | stosd 864 | mov [ebp+dHERE], edi 865 | pop edi 866 | 867 | xor eax, eax 868 | dec eax 869 | ChangeState: 870 | mov [ebp+dSTATE], eax 871 | NEXT 872 | 873 | link_SEMICOLON: 874 | dw $-link_COLON 875 | db F_IMMED|1, ';' 876 | SEMICOLON: 877 | mov eax, EXIT 878 | call near doCOMMA 879 | 880 | mov eax, [ebp+dLATEST] 881 | and byte[eax+2], ~F_HIDDEN 882 | 883 | xor eax, eax 884 | jmp short ChangeState 885 | 886 | doKEY: 887 | mov eax, [ebp+dLENGTH] 888 | or eax, eax 889 | jz .end 890 | dec dword[ebp+dLENGTH] 891 | 892 | mov ebx, dword[ebp+dTOIN] 893 | cmp bx, 0x200 894 | jb .nonextcluster 895 | 896 | pushad 897 | call near CallRM 898 | dw ReadNextCluster 899 | popad 900 | 901 | xor ebx, ebx 902 | .nonextcluster: 903 | xor eax, eax 904 | mov al, byte[FileBuffer+ebx] 905 | inc ebx 906 | mov dword[ebp+dTOIN], ebx 907 | .end: 908 | ret 909 | 910 | doWORD: 911 | call near doKEY 912 | or al, al 913 | jz .eof 914 | cmp al, ' ' 915 | jbe doWORD 916 | xor ecx, ecx 917 | mov edx, WORDBuffer 918 | .loop: 919 | mov [edx+ecx], al 920 | inc ecx 921 | call near doKEY 922 | cmp al, ' ' 923 | ja .loop 924 | 925 | xchg edx, eax 926 | ret 927 | .eof: 928 | mov si, EOFMessage 929 | call near CallRM 930 | dw Error 931 | 932 | LATESTInitialValue EQU link_SEMICOLON 933 | 934 | REST_FREESPACE EQU 2048 - ($ - $$) 935 | times REST_FREESPACE db 0x00 936 | --------------------------------------------------------------------------------