├── LICENSE ├── bottles.forth ├── eforth.forth ├── forth.c └── readme.md /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2017, Todd Thomas 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /bottles.forth: -------------------------------------------------------------------------------- 1 | : MANY ?DUP IF . ELSE ." no more " THEN ; 2 | : BOTTLES ." bottle" 1- IF ." s" THEN ; 3 | : BEER CR DUP MANY BOTTLES SPACE ." of beer" ; 4 | : WALL SPACE ." on the wall." ; 5 | : DRINK CR ." Take one down and pass it around." ; 6 | : BUY CR ." Go to the store and buy some more. " ; 7 | : ANOTHER ?DUP IF DRINK 1- ELSE BUY 99 THEN ; 8 | : VERSE DUP BEER WALL DUP BEER ANOTHER BEER WALL CR ; 9 | : VERSES FOR R@ VERSE NEXT ; 10 | 99 VERSES 11 | BYE 12 | 13 | -------------------------------------------------------------------------------- /eforth.forth: -------------------------------------------------------------------------------- 1 | : + UM+ DROP ; 2 | : CELLS DUP + ; 3 | : CELL+ 2 + ; 4 | : CELL- -2 + ; 5 | : CELL 2 ; 6 | : BOOT 0 CELLS ; 7 | : FORTH 4 CELLS ; 8 | : DPL 5 CELLS ; 9 | : SP0 6 CELLS ; 10 | : RP0 7 CELLS ; 11 | : '?KEY 8 CELLS ; 12 | : 'EMIT 9 CELLS ; 13 | : 'EXPECT 10 CELLS ; 14 | : 'TAP 11 CELLS ; 15 | : 'ECHO 12 CELLS ; 16 | : 'PROMPT 13 CELLS ; 17 | : BASE 14 CELLS ; 18 | : tmp 15 CELLS ; 19 | : SPAN 16 CELLS ; 20 | : >IN 17 CELLS ; 21 | : #TIBB 18 CELLS ; 22 | : TIBB 19 CELLS ; 23 | : CSP 20 CELLS ; 24 | : 'EVAL 21 CELLS ; 25 | : 'NUMBER 22 CELLS ; 26 | : HLD 23 CELLS ; 27 | : HANDLER 24 CELLS ; 28 | : CONTEXT 25 CELLS ; 29 | : CURRENT 27 CELLS ; 30 | : CP 29 CELLS ; 31 | : NP 30 CELLS ; 32 | : LAST 31 CELLS ; 33 | : STATE 32 CELLS ; 34 | : SPP 33 CELLS ; 35 | : RPP 34 CELLS ; 36 | : TRUE -1 ; 37 | : FALSE 0 ; 38 | : BL 32 ; 39 | : BS 8 ; 40 | : =IMMED 3 ; 41 | : =WORDLIST 2 ; 42 | : IMMEDIATE =IMMED LAST @ CELL- ! ; 43 | : HERE CP @ ; 44 | : ALLOT CP @ + CP ! ; 45 | : , HERE CELL ALLOT ! ; 46 | : C, HERE 1 ALLOT C! ; 47 | : +! SWAP OVER @ + SWAP ! ; 48 | : COMPILE R> DUP @ , CELL+ >R ; 49 | : STATE? STATE @ ; 50 | : LITERAL COMPILE LIT , ; IMMEDIATE 51 | : [ FALSE STATE ! ; IMMEDIATE 52 | : ] TRUE STATE ! ; IMMEDIATE 53 | : IF COMPILE 0BRANCH HERE 0 , ; IMMEDIATE 54 | : THEN HERE SWAP ! ; IMMEDIATE 55 | : FOR COMPILE >R HERE ; IMMEDIATE 56 | : NEXT COMPILE next , ; IMMEDIATE 57 | : BEGIN HERE ; IMMEDIATE 58 | : AGAIN COMPILE BRANCH , ; IMMEDIATE 59 | : UNTIL COMPILE 0BRANCH , ; IMMEDIATE 60 | : AHEAD COMPILE BRANCH HERE 0 , ; IMMEDIATE 61 | : REPEAT COMPILE BRANCH , HERE SWAP ! ; IMMEDIATE 62 | : AFT DROP COMPILE BRANCH HERE 0 , HERE SWAP ; IMMEDIATE 63 | : ELSE COMPILE BRANCH HERE 0 , SWAP HERE SWAP ! ; IMMEDIATE 64 | : WHILE COMPILE 0BRANCH HERE 0 , SWAP ; IMMEDIATE 65 | : EXECUTE >R ; 66 | : @EXECUTE @ DUP IF EXECUTE THEN ; 67 | : R@ R> R> DUP >R SWAP >R ; 68 | : #TIB #TIBB @ ; 69 | : TIB TIBB @ ; 70 | : \ #TIB @ >IN ! ; IMMEDIATE 71 | : ROT >R SWAP R> SWAP ; 72 | : -ROT SWAP >R SWAP R> ; 73 | : NIP SWAP DROP ; 74 | : TUCK SWAP OVER ; 75 | : 2>R SWAP R> SWAP >R SWAP >R >R ; 76 | : 2R> R> R> SWAP R> SWAP >R SWAP ; 77 | : 2R@ R> R> R@ SWAP >R SWAP R@ SWAP >R ; 78 | : 2DROP DROP DROP ; 79 | : 2DUP OVER OVER ; 80 | : 2SWAP ROT >R ROT R> ; 81 | : 2OVER >R >R 2DUP R> R> 2SWAP ; 82 | : 2ROT 2>R 2SWAP 2R> 2SWAP ; 83 | : -2ROT 2ROT 2ROT ; 84 | : 2NIP 2SWAP 2DROP ; 85 | : 2TUCK 2SWAP 2OVER ; 86 | : NOT DUP NAND ; 87 | : AND NAND NOT ; 88 | : OR NOT SWAP NOT NAND ; 89 | : NOR OR NOT ; 90 | : XOR 2DUP AND -ROT NOR NOR ; 91 | : XNOR XOR NOT ; 92 | : NEGATE NOT 1 + ; 93 | : - NEGATE + ; 94 | : 1+ 1 + ; 95 | : 1- 1 - ; 96 | : 2+ 2 + ; 97 | : 2- 2 - ; 98 | : D+ >R SWAP >R UM+ R> R> + + ; 99 | : DNEGATE NOT >R NOT 1 UM+ R> + ; 100 | : D- DNEGATE D+ ; 101 | : 2! SWAP OVER ! CELL+ ! ; 102 | : 2@ DUP CELL+ @ SWAP @ ; 103 | : ?DUP DUP IF DUP THEN ; 104 | : S>D DUP 0< ; 105 | : ABS DUP 0< IF NEGATE THEN ; 106 | : DABS DUP 0< IF DNEGATE THEN ; 107 | : U< 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ; 108 | : U> SWAP U< ; 109 | : = XOR IF FALSE EXIT THEN TRUE ; 110 | : < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ; 111 | : > SWAP < ; 112 | : 0> NEGATE 0< ; 113 | : 0<> IF TRUE EXIT THEN FALSE ; 114 | : 0= 0 = ; 115 | : <> = 0= ; 116 | : D0< SWAP DROP 0< ; 117 | : D0> DNEGATE D0< ; 118 | : D0= OR 0= ; 119 | : D= D- D0= ; 120 | : D< ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ; 121 | : DU< ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ; 122 | : DMIN 2OVER 2OVER 2SWAP D< IF 2SWAP THEN 2DROP ; 123 | : DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; 124 | : M+ S>D D+ ; 125 | : M- S>D D- ; 126 | : MIN 2DUP SWAP < IF SWAP THEN DROP ; 127 | : MAX 2DUP < IF SWAP THEN DROP ; 128 | : UMIN 2DUP SWAP U< IF SWAP THEN DROP ; 129 | : UMAX 2DUP U< IF SWAP THEN DROP ; 130 | : WITHIN OVER - >R - R> U< ; 131 | : UM/MOD 132 | 2DUP U< 133 | IF NEGATE 134 | 15 FOR 135 | >R DUP UM+ 136 | >R >R DUP UM+ 137 | R> + DUP R> R@ SWAP 138 | >R UM+ 139 | R> OR 140 | IF >R DROP 1+ R> 141 | ELSE DROP 142 | THEN R> 143 | NEXT DROP SWAP EXIT 144 | THEN DROP 2DROP -1 DUP ; 145 | : M/MOD 146 | DUP 0< DUP >R 147 | IF NEGATE >R 148 | DNEGATE R> 149 | THEN >R DUP 0< 150 | IF R@ + 151 | THEN R> UM/MOD 152 | R> 153 | IF SWAP NEGATE SWAP THEN ; 154 | : /MOD OVER 0< SWAP M/MOD ; 155 | : MOD /MOD DROP ; 156 | : / /MOD NIP ; 157 | : UM* 158 | 0 SWAP 159 | 15 FOR 160 | DUP UM+ >R >R 161 | DUP UM+ 162 | R> + 163 | R> 164 | IF >R OVER UM+ 165 | R> + 166 | THEN 167 | NEXT 168 | ROT DROP ; 169 | : * UM* DROP ; 170 | : M* 171 | 2DUP XOR 0< >R 172 | ABS SWAP ABS UM* 173 | R> IF DNEGATE THEN ; 174 | : */MOD >R M* R> M/MOD ; 175 | : */ */MOD SWAP DROP ; 176 | : 2* 2 * ; 177 | : 2/ 2 / ; 178 | : MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; 179 | : D2* 2DUP D+ ; 180 | : DU2/ 2 MU/MOD ROT DROP ; 181 | : D2/ DUP >R 1 AND DU2/ R> 2/ OR ; 182 | : ALIGNED DUP 0 2 UM/MOD DROP DUP IF 2 SWAP - THEN + ; 183 | : parse 184 | tmp ! OVER >R DUP 185 | IF 186 | 1- tmp @ BL = 187 | IF 188 | FOR BL OVER C@ - 0< NOT 189 | WHILE 1+ 190 | NEXT R> DROP 0 DUP EXIT 191 | THEN R> 192 | THEN 193 | OVER SWAP 194 | FOR tmp @ OVER C@ - tmp @ BL = 195 | IF 0< THEN 196 | WHILE 1+ 197 | NEXT DUP >R 198 | ELSE R> DROP DUP 1+ >R 199 | THEN OVER - R> R> - EXIT 200 | THEN OVER R> - ; 201 | : PARSE >R TIB >IN @ + #TIB C@ >IN @ - R> parse >IN +! ; 202 | : CHAR BL PARSE DROP C@ ; 203 | : TX! 1 PUTC ; 204 | : EMIT 'EMIT @EXECUTE ; 205 | : TYPE FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ; 206 | : ?RX 0 GETC ; 207 | : ?KEY '?KEY @EXECUTE ; 208 | : KEY BEGIN ?KEY UNTIL ; 209 | : COUNT DUP 1+ SWAP C@ ; 210 | : CMOVE 211 | FOR 212 | AFT 213 | >R DUP C@ R@ C! 1+ R> 1+ 214 | THEN 215 | NEXT 2DROP ; 216 | : FILL 217 | SWAP 218 | FOR SWAP 219 | AFT 2DUP C! 1+ THEN 220 | NEXT 2DROP ; 221 | : -TRAILING 222 | FOR 223 | AFT 224 | BL OVER R@ + C@ < 225 | IF 226 | R> 1+ EXIT 227 | THEN 228 | THEN 229 | NEXT 0 ; 230 | : PACK$ 231 | DUP >R 232 | 2DUP C! 1+ 2DUP + 0 SWAP ! SWAP CMOVE 233 | R> ; 234 | : WORD PARSE HERE PACK$ ; 235 | : TOKEN BL PARSE 31 MIN NP @ OVER - 1- PACK$ ; 236 | : LINK> 3 CELLS - ; 237 | : CODE> 2 CELLS - ; 238 | : TYPE> 1 CELLS - ; 239 | : DATA> CELL+ ; 240 | : SAME? 241 | FOR AFT 242 | OVER R@ CELLS + @ 243 | OVER R@ CELLS + @ 244 | - ?DUP 245 | IF R> DROP EXIT THEN 246 | THEN 247 | NEXT 0 ; 248 | : find 249 | @ BEGIN DUP WHILE 250 | 2DUP C@ SWAP C@ = IF 251 | 2DUP 1+ SWAP COUNT ALIGNED CELL / >R SWAP R> 252 | SAME? 0= IF 253 | 2DROP SWAP DROP DUP CODE> @ SWAP -1 EXIT 254 | THEN 2DROP THEN 255 | LINK> @ REPEAT ; 256 | : ' TOKEN CONTEXT @ find IF DROP ELSE SWAP DROP 0 THEN ; 257 | : ! ! ; 258 | ' TX! 'EMIT ! 259 | ' ?RX '?KEY ! 260 | : ['] COMPILE ' ; IMMEDIATE 261 | : POSTPONE ' , ; IMMEDIATE 262 | : [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE 263 | : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE 264 | : :NONAME HERE POSTPONE ] ; 265 | : OVERT LAST @ CURRENT @ ! ; 266 | : $,n 267 | DUP LAST ! CELL- 268 | DUP =WORDLIST 269 | SWAP ! 270 | CELL- DUP HERE 271 | SWAP ! 272 | CELL- DUP CURRENT @ @ 273 | SWAP ! 274 | CELL- NP ! ; 275 | : : TOKEN $,n POSTPONE ] ; 276 | : ; COMPILE EXIT POSTPONE [ OVERT ; IMMEDIATE 277 | : RECURSE LAST @ CURRENT @ ! ; IMMEDIATE 278 | : doVAR R> ; 279 | : CREATE TOKEN $,n COMPILE doVAR OVERT ; 280 | : DOES LAST @ CODE> @ R> SWAP ! ; 281 | : DOES> COMPILE DOES COMPILE R> ; IMMEDIATE 282 | : CONSTANT CREATE , DOES> @ ; 283 | : VARIABLE CREATE 0 , ; 284 | : 2LITERAL SWAP POSTPONE LITERAL 285 | POSTPONE LITERAL ; IMMEDIATE 286 | : 2CONSTANT CREATE , , DOES> 2@ ; 287 | : 2VARIABLE CREATE 2 CELLS ALLOT ; 288 | : SPACE BL EMIT ; 289 | : SPACES 0 MAX FOR SPACE NEXT ; 290 | : PAD HERE 80 + ; 291 | : DECIMAL 10 BASE ! ; 292 | : HEX 16 BASE ! ; 293 | : BINARY 2 BASE ! ; 294 | : OCTAL 8 BASE ! ; 295 | DECIMAL 296 | : CHAR- 1- ; 297 | : CHAR+ 1+ ; 298 | : CHARS ; 299 | : >CHAR 127 AND DUP 127 BL WITHIN IF DROP 95 THEN ; 300 | : DIGIT 9 OVER < 7 AND + [CHAR] 0 + ; 301 | : <# PAD HLD ! ; 302 | : HOLD HLD @ CHAR- DUP HLD ! C! ; 303 | : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ; 304 | : #S BEGIN # 2DUP OR 0= UNTIL ; 305 | : SIGN 0< IF [CHAR] - HOLD THEN ; 306 | : #> 2DROP HLD @ PAD OVER - ; 307 | : S.R OVER - SPACES TYPE ; 308 | : D.R >R DUP >R DABS <# #S R> SIGN #> R> S.R ; 309 | : U.R 0 SWAP D.R ; 310 | : .R >R S>D R> D.R ; 311 | : D. 0 D.R SPACE ; 312 | : U. 0 D. ; 313 | : . BASE @ 10 XOR IF U. EXIT THEN S>D D. ; 314 | : ? @ . ; 315 | : DU.R >R <# #S #> R> S.R ; 316 | : DU. DU.R SPACE ; 317 | : do$ R> R@ R> COUNT + ALIGNED >R SWAP >R ; 318 | : ."| do$ COUNT TYPE ; 319 | : $," [CHAR] " WORD COUNT + ALIGNED CP ! ; 320 | : ." COMPILE ."| $," ; IMMEDIATE 321 | : .( [CHAR] ) PARSE TYPE ; IMMEDIATE 322 | : $"| do$ ; 323 | : $" COMPILE $"| $," ; IMMEDIATE 324 | : s" [CHAR] " PARSE HERE PACK$ ; 325 | : CR 10 EMIT ; 326 | : TAP OVER C! 1+ ; 327 | : KTAP 328 | 10 XOR 329 | IF 330 | BL TAP EXIT 331 | THEN 332 | NIP DUP ; 333 | : ACCEPT 334 | OVER + OVER 335 | BEGIN 336 | 2DUP XOR 337 | WHILE 338 | KEY 339 | DUP BL - 95 U< 340 | IF TAP ELSE KTAP THEN 341 | REPEAT DROP OVER - ; 342 | : EXPECT ACCEPT SPAN ! DROP ; 343 | : QUERY TIB 80 ACCEPT #TIB C! DROP 0 >IN ! ; 344 | : DIGIT? 345 | >R [CHAR] 0 - 346 | 9 OVER < 347 | IF 7 - DUP 10 < OR THEN 348 | DUP R> U< ; 349 | : /STRING DUP >R - SWAP R> + SWAP ; 350 | : >NUMBER 351 | BEGIN DUP 352 | WHILE >R DUP >R C@ BASE @ DIGIT? 353 | WHILE SWAP BASE @ UM* DROP ROT 354 | BASE @ UM* D+ R> CHAR+ R> 1 - 355 | REPEAT DROP R> R> THEN ; 356 | : NUMBER? 357 | OVER C@ [CHAR] - = DUP >R IF 1 /STRING THEN 358 | >R >R 0 DUP R> R> -1 DPL ! 359 | BEGIN >NUMBER DUP 360 | WHILE OVER C@ [CHAR] . XOR 361 | IF ROT DROP ROT R> 2DROP FALSE EXIT 362 | THEN 1 - DPL ! CHAR+ DPL @ 363 | REPEAT 2DROP R> IF DNEGATE THEN TRUE ; 364 | ' NUMBER? 'NUMBER ! 365 | : $INTERPRET 366 | CONTEXT @ find 367 | IF DROP EXECUTE EXIT THEN 368 | COUNT 'NUMBER @EXECUTE IF 369 | DPL @ 0< IF DROP THEN EXIT THEN ." ?" TYPE ; 370 | : $COMPILE 371 | CONTEXT @ find 372 | IF CELL- @ =IMMED = 373 | IF EXECUTE ELSE , THEN EXIT 374 | THEN COUNT 'NUMBER @EXECUTE 375 | IF 376 | DPL @ 0< 377 | IF DROP POSTPONE LITERAL 378 | ELSE POSTPONE 2LITERAL 379 | THEN EXIT 380 | THEN ." ?" TYPE ; 381 | : eval STATE? IF $COMPILE ELSE $INTERPRET THEN ; 382 | ' eval 'EVAL ! 383 | : EVAL 384 | BEGIN TOKEN DUP C@ WHILE 385 | 'EVAL @EXECUTE 386 | REPEAT DROP ; 387 | : OK CR ." OK." SPACE ; 388 | ' OK 'PROMPT ! 389 | : QUIT 390 | BEGIN 'PROMPT @EXECUTE QUERY 391 | EVAL AGAIN ; 392 | : BYE ." Good Bye " CR HALT ; 393 | ' QUIT BOOT ! 394 | : SP@ SPP @ ; 395 | : DEPTH SP@ SP0 @ - CELL / ; 396 | : PICK CELLS SP@ SWAP - 2 CELLS - @ ; 397 | : .S CR DEPTH FOR AFT R@ PICK . THEN NEXT SPACE ." 400 | @ SPACE REPEAT DROP CR ; 401 | 402 | VARIABLE FILE 403 | : OPEN F_OPEN FILE ! ; 404 | : CLOSE FILE @ F_CLOSE ; 405 | : FPUT FILE @ PUTC ; 406 | : FGET FILE @ GETC ; 407 | : FPUTS COUNT FOR AFT DUP C@ FPUT 1+ THEN NEXT DROP ; 408 | 409 | : SAVEVM $" eforth.img" $" wb" OPEN 0 410 | 16384 FOR AFT DUP C@ FPUT 1+ THEN NEXT CLOSE DROP ; 411 | 412 | SAVEVM 413 | 414 | -------------------------------------------------------------------------------- /forth.c: -------------------------------------------------------------------------------- 1 | #include 2 | #define VM_SIZE (1024 * 64) // Size in bytes of vm 3 | #define NUM_FILE_HANDLES 8 // Number of simultaneous open files allowed 4 | #define CELL_SIZE 2 5 | #define SP0 6 * CELL_SIZE // Top of data stack 6 | #define RP0 7 * CELL_SIZE // Top of return stack 7 | #define SPP 33 * CELL_SIZE // Data stack pointer 8 | #define RPP 34 * CELL_SIZE // Return stack pointer 9 | #define TRUE -1 10 | #define FALSE 0 11 | #define FORTH 4 * CELL_SIZE // Forth Vocabulary 12 | #define TO_IN 17 * CELL_SIZE // >IN 13 | #define NUM_TIB 18 * CELL_SIZE // #TIB 14 | #define TIB 19 * CELL_SIZE // Text input buffer 15 | #define CONTEXT 25 * CELL_SIZE // Current search vocabulary 16 | #define CURRENT 27 * CELL_SIZE // Current vocabulary 17 | #define CP 29 * CELL_SIZE // Code Pointer 18 | #define NP 30 * CELL_SIZE // Next cell in name dictionary 19 | #define LAST 31 * CELL_SIZE // Last name in dictionary 20 | #define STATE 32 * CELL_SIZE // State of compiler 21 | #define LIT 2 22 | #define EXIT 3 23 | #define INTERPRETER 0 24 | #define WORDLIST 2 25 | #define IMMEDIATE 3 26 | struct IMAGE { 27 | char memory[VM_SIZE]; 28 | FILE* file_handles[NUM_FILE_HANDLES]; 29 | }; 30 | unsigned short create_handle(FILE** fh, FILE* handle) { 31 | int index = 0; 32 | while(index++ < NUM_FILE_HANDLES) { 33 | if(fh[index] == NULL) { 34 | fh[index] = handle; 35 | return index; 36 | } 37 | } 38 | return 0; 39 | } 40 | #define GET(X) *(unsigned short*)(image->memory + X) 41 | #define SET(X,Y) *(unsigned short *)(image->memory + X) = Y 42 | #define PUSHDS(X) *(unsigned short *)(image->memory + GET(SPP)) = (X & 0xFFFF);SET(SPP,GET(SPP) + CELL_SIZE) 43 | #define PUSHRS(X) *(unsigned short *)(image->memory + GET(RPP)) = (X & 0xFFFF);SET(RPP,GET(RPP) - CELL_SIZE) 44 | #define POPDS(X) SET(SPP,GET(SPP) - CELL_SIZE);X = *(unsigned short *)(image->memory + GET(SPP)) 45 | #define POPRS(X) SET(RPP,GET(RPP) + CELL_SIZE);X = *(unsigned short *)(image->memory + GET(RPP)) 46 | int vm_tostring(struct IMAGE * image, int start, char * text) { 47 | int ndx = 0; 48 | int pos = start; 49 | int size = image->memory[pos]; 50 | while(ndx < (size)) { 51 | text[ndx] = image->memory[pos + ndx + 1]; 52 | ndx = ndx + 1; 53 | } 54 | text[ndx] = '\0'; 55 | return size; 56 | } 57 | int vm_run(struct IMAGE * image, int start) { 58 | int PC = start; 59 | long int regA, regB = 0; 60 | PUSHRS(VM_SIZE - 1); 61 | while(PC < VM_SIZE - 1) { 62 | switch(GET(PC)) { 63 | case 0: // NOP 64 | PC += CELL_SIZE; 65 | break; 66 | case 1: // HALT 67 | return PC; 68 | case 2: // LIT 69 | PC += CELL_SIZE; 70 | PUSHDS(GET(PC)); 71 | PC += CELL_SIZE; 72 | break; 73 | case 3: // EXIT 74 | regA = PC; 75 | POPRS(PC); 76 | break; 77 | case 4: // @ 78 | POPDS(regA); 79 | PUSHDS(GET(regA)); 80 | PC += CELL_SIZE; 81 | break; 82 | case 5: // ! 83 | POPDS(regA); 84 | POPDS(regB); 85 | SET(regA, regB); 86 | PC += CELL_SIZE; 87 | break; 88 | case 6: // DROP 89 | POPDS(regA); 90 | PC += CELL_SIZE; 91 | break; 92 | case 7: // OVER 93 | POPDS(regA); 94 | POPDS(regB); 95 | PUSHDS(regB); 96 | PUSHDS(regA); 97 | PUSHDS(regB); 98 | PC += CELL_SIZE; 99 | break; 100 | case 8: // SWAP 101 | POPDS(regA); 102 | POPDS(regB); 103 | PUSHDS(regA); 104 | PUSHDS(regB); 105 | PC += CELL_SIZE; 106 | break; 107 | case 9: // DUP 108 | POPDS(regA); 109 | PUSHDS(regA); 110 | PUSHDS(regA); 111 | PC += CELL_SIZE; 112 | break; 113 | case 10: // UM+ 114 | POPDS(regA); 115 | POPDS(regB); 116 | regA = regA + regB; 117 | if(regA > 0xFFFF) { 118 | PUSHDS(regA & 0xFFFF); 119 | PUSHDS(1); 120 | } 121 | else { 122 | PUSHDS(regA); 123 | PUSHDS(0); 124 | } 125 | PC += CELL_SIZE; 126 | break; 127 | case 11: // NAND 128 | POPDS(regA); 129 | POPDS(regB); 130 | PUSHDS(~(regA & regB) & 0xFFFF); 131 | PC += CELL_SIZE; 132 | break; 133 | case 12: // 0< 134 | POPDS(regA); 135 | PUSHDS(regA > 0x8000 ? TRUE : FALSE); 136 | PC += CELL_SIZE; 137 | break; 138 | case 13: // >R 139 | POPDS(regA); 140 | PUSHRS(regA); 141 | PC += CELL_SIZE; 142 | break; 143 | case 14: // R> 144 | POPRS(regA); 145 | PUSHDS(regA); 146 | PC += CELL_SIZE; 147 | break; 148 | case 15: // next 149 | PC += CELL_SIZE; 150 | regA = GET(PC); 151 | POPRS(regB); 152 | regB--; 153 | if(regB < 0) PC += CELL_SIZE; 154 | else { 155 | PUSHRS(regB); 156 | PC = regA; 157 | } 158 | break; 159 | case 16: // BRANCH 160 | PC += CELL_SIZE; 161 | PC = GET(PC); 162 | break; 163 | case 17: // 0BRANCH 164 | POPDS(regA); 165 | PC += CELL_SIZE; 166 | regB = GET(PC); 167 | if(regA == FALSE) PC = regB; 168 | else PC += CELL_SIZE; 169 | break; 170 | case 18: // TX! 171 | POPDS(regA); 172 | POPDS(regB); 173 | fputc(regB, image->file_handles[regA]); 174 | PC += CELL_SIZE; 175 | break; 176 | case 19: // ?RX 177 | POPDS(regA); 178 | regA = fgetc(image->file_handles[regA]); 179 | PUSHDS(regA); 180 | PUSHDS(TRUE); 181 | PC += CELL_SIZE; 182 | break; 183 | case 20: // F_OPEN 184 | { 185 | char filename[31]; 186 | char options[31]; 187 | POPDS(regB); 188 | POPDS(regA); 189 | vm_tostring(image, regA, filename); 190 | vm_tostring(image, regB, options); 191 | PUSHDS(create_handle(image->file_handles, fopen(filename,options))); 192 | } 193 | PC += CELL_SIZE; 194 | break; 195 | case 21: // F_CLOSE 196 | POPDS(regA); 197 | fclose(image->file_handles[regA]); 198 | image->file_handles[regA] = NULL; 199 | PC += CELL_SIZE; 200 | break; 201 | case 22: // C@ 202 | POPDS(regA); 203 | regB = image->memory[regA]; 204 | PUSHDS(regB); 205 | PC += CELL_SIZE; 206 | break; 207 | case 23: // C! 208 | POPDS(regA); 209 | POPDS(regB); 210 | image->memory[regA] = regB; 211 | PC += CELL_SIZE; 212 | break; 213 | default: // CALL 214 | PUSHDS(GET(PC)); 215 | PC += CELL_SIZE; 216 | PUSHRS(PC); 217 | POPDS(PC); 218 | break; 219 | } 220 | } 221 | return PC; 222 | } 223 | void vm_init(struct IMAGE * image, FILE * fi, int size) { 224 | int x = 0; 225 | while(x < NUM_FILE_HANDLES) { 226 | image->file_handles[x++] = NULL; 227 | } 228 | image->file_handles[0] = stdin; 229 | image->file_handles[1] = stdout; 230 | x = 0; 231 | while(x < VM_SIZE) { 232 | image->memory[x++] = (fi == NULL ? 0 : fgetc(fi)); 233 | } 234 | SET(SP0, 35 * CELL_SIZE); 235 | SET(SPP, 35 * CELL_SIZE); 236 | SET(RP0, 99 * CELL_SIZE); 237 | SET(RPP, 99 * CELL_SIZE); 238 | } 239 | int int_getCompiler(struct IMAGE * image) { return GET(STATE); } 240 | void int_setcompiler(struct IMAGE * image, int val) { SET(STATE, val); } 241 | void int_create(struct IMAGE * image, char * word, int size, 242 | unsigned short type, unsigned short data) { 243 | int x = 0; 244 | int charstart; 245 | int position = GET(NP); 246 | position = position - size; 247 | charstart = position + 1; 248 | image->memory[position] = size; 249 | SET(position - (3 * CELL_SIZE), GET(LAST)); 250 | SET(LAST, position); 251 | while(x < size) { image->memory[charstart + x] = word[x];x++; } 252 | if((size) % 2 == 1) image->memory[charstart + size] = '\0'; 253 | SET(position - (1 * CELL_SIZE), type); 254 | SET(position - (2 * CELL_SIZE), data); 255 | SET(NP, position - (4 * CELL_SIZE)); 256 | } 257 | void int_init(struct IMAGE * image) { 258 | SET(NP, (VM_SIZE / 4) - 1); 259 | SET(CP, (182 * CELL_SIZE)); 260 | SET(NUM_TIB, (100 * CELL_SIZE)); 261 | SET(TIB, ((100 * CELL_SIZE) + 1)); 262 | SET(CURRENT, FORTH); 263 | SET(CONTEXT, FORTH); 264 | int_create(image, ":", 1, INTERPRETER, 41); 265 | int_create(image, ";", 1, INTERPRETER, 42); 266 | int_create(image, "NOP", 3, WORDLIST, 0); 267 | int_create(image, "HALT", 4, WORDLIST, 1); 268 | int_create(image, "LIT", 3, WORDLIST, 2); 269 | int_create(image, "EXIT", 4, WORDLIST, 3); 270 | int_create(image, "@", 1, WORDLIST, 4); 271 | int_create(image, "!", 1, WORDLIST, 5); 272 | int_create(image, "DROP", 4, WORDLIST, 6); 273 | int_create(image, "OVER", 4, WORDLIST, 7); 274 | int_create(image, "SWAP", 4, WORDLIST, 8); 275 | int_create(image, "DUP", 3, WORDLIST, 9); 276 | int_create(image, "UM+", 3, WORDLIST, 10); 277 | int_create(image, "NAND", 4, WORDLIST, 11); 278 | int_create(image, "0<", 2, WORDLIST, 12); 279 | int_create(image, ">R", 2, WORDLIST, 13); 280 | int_create(image, "R>", 2, WORDLIST, 14); 281 | int_create(image, "next", 4, WORDLIST, 15); 282 | int_create(image, "BRANCH", 6, WORDLIST, 16); 283 | int_create(image, "0BRANCH", 7, WORDLIST, 17); 284 | int_create(image, "PUTC", 4, WORDLIST, 18); 285 | int_create(image, "GETC", 4, WORDLIST, 19); 286 | int_create(image, "F_OPEN", 6, WORDLIST, 20); 287 | int_create(image, "F_CLOSE", 7, WORDLIST, 21); 288 | int_create(image, "C@", 2, WORDLIST, 22); 289 | int_create(image, "C!", 2, WORDLIST, 23); 290 | SET(GET(CURRENT), GET(LAST)); 291 | } 292 | int int_word(struct IMAGE * image, char * word) { 293 | int numIn = GET(TO_IN); 294 | int length = image->memory[GET(NUM_TIB)]; 295 | int start = numIn; 296 | int count = 0; 297 | while(numIn < length) { 298 | char c = (char)image->memory[GET(TIB) + numIn]; 299 | numIn = numIn + 1; 300 | if(c == ' ') { 301 | word[count] = '\0'; 302 | break; 303 | } 304 | else word[count] = c; 305 | count = count + 1; 306 | } 307 | SET(TO_IN, numIn); 308 | return numIn - start; 309 | } 310 | int int_find(struct IMAGE * image, char * word, int size) { 311 | int start = GET(GET(CONTEXT)); 312 | int len = image->memory[start]; 313 | while(start != 0) { 314 | if(len == size) { 315 | int match = TRUE; 316 | int x = 0; 317 | while ( x < len) { 318 | match &= (word[x] == image->memory[start + 1 + x]);x++; } 319 | if(match > FALSE) return start; 320 | } 321 | start = GET(start - (3 * CELL_SIZE)); 322 | len = image->memory[start]; 323 | } 324 | return 0; 325 | } 326 | int int_number(int * val, char * word, int size) { 327 | int ndx, negative = 0; 328 | if(size == 0) return 0; 329 | if(word[ndx] == '-') { 330 | negative = 1; 331 | ndx++; 332 | } 333 | while(ndx < size) { 334 | if(word[ndx] >= '0' && word[ndx] <= '9') 335 | *val = ((*val * 10) + (word[ndx] - '0')); 336 | else return 0; 337 | ndx++; 338 | } 339 | if(negative == 1) { *val = ~*val + 1; } 340 | return 1; 341 | } 342 | #define HERE GET(CP) 343 | void int_comma(struct IMAGE * image, unsigned short val) { 344 | SET(HERE, val); 345 | SET(CP, HERE + CELL_SIZE); 346 | } 347 | int int_interpret(struct IMAGE * image) { 348 | int sz, found, num, type, data; 349 | char word[128]; 350 | while(GET(TO_IN) < image->memory[GET(NUM_TIB)]) { 351 | sz = int_word(image, word); 352 | found = int_find(image, word, sz-1); 353 | if(found != FALSE) { 354 | type = GET(found - (1 * CELL_SIZE)); 355 | data = GET(found - (2 * CELL_SIZE)); 356 | if(type == INTERPRETER) { 357 | switch(data) { 358 | case 41: // : 359 | sz = int_word(image, word); 360 | int_create(image, word, sz - 1, WORDLIST, HERE); 361 | int_setcompiler(image, TRUE); 362 | break; 363 | case 42: // ; 364 | int_comma(image, EXIT); 365 | int_setcompiler(image, FALSE); 366 | SET(GET(CURRENT), GET(LAST)); 367 | break; 368 | default: 369 | break; 370 | } 371 | } 372 | else if(type == IMMEDIATE || 373 | (type == WORDLIST && int_getCompiler(image) == FALSE)) { 374 | if(vm_run(image, data) == -1) return -1; 375 | } 376 | else int_comma(image, data); 377 | } 378 | else { 379 | num = 0; 380 | if(int_number(&num, word, sz - 1)) { 381 | if(int_getCompiler(image) != FALSE) { 382 | int_comma(image, LIT); 383 | int_comma(image, num); 384 | } 385 | } 386 | else { 387 | if(word[0] != 0 && word[0] != '\n' && word[0] != '\r') 388 | word[sz] = '\0'; 389 | } 390 | } 391 | } 392 | return 1; 393 | } 394 | int int_readfile(FILE * fp, struct IMAGE * image) { 395 | char c = 1; 396 | int i = 0; 397 | while(c != '\n') { 398 | c = fgetc(fp); 399 | image->memory[GET(TIB) + i++] = c; 400 | if(c == EOF) return -1; 401 | } 402 | image->memory[GET(NUM_TIB)] = i; 403 | SET(TO_IN, 0); 404 | return i - 1; 405 | } 406 | void int_eval(struct IMAGE * image, FILE * fi) { 407 | while(int_readfile(fi, image) != -1) 408 | int_interpret(image); 409 | } 410 | struct IMAGE image; 411 | int main(int argc, char *argv[]) { 412 | FILE * f = NULL; 413 | if(argc > 1) { 414 | int x = 0; 415 | while(x < argc) { 416 | if(argv[x][0] == '-') { 417 | if((x + 1) <= argc) { 418 | f = fopen(argv[x+1],"rb"); 419 | if(f != NULL) { 420 | if(argv[x][1] == 'c'){ 421 | vm_init(&image, NULL, VM_SIZE); 422 | int_init(&image); 423 | int_eval(&image, f); 424 | } 425 | else if(argv[x][1] == 'i'){ 426 | vm_init(&image, f, VM_SIZE); 427 | } 428 | else return -1; 429 | fclose(f); 430 | vm_run(&image, 0); 431 | } 432 | break; 433 | } 434 | } 435 | x++; 436 | } 437 | } 438 | return 1; 439 | } 440 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | * gcc forth.c -o forth 2 | * ./forth -c eforth.forth 3 | * cat bottles.forth | ./forth -i eforth.img 4 | 5 | 6 | $ ./forth -i eforth.img 7 | 8 | OK. WORDS 9 | 10 | 11 | SAVEVM FPUTS FGET FPUT CLOSE OPEN FILE WORDS .S PICK DEPTH SP@ BYE QUIT OK EVAL eval $COMPILE $INTERPRET NUMBER? >NUMBER /STRING DIGIT? QUERY EXPECT ACCEPT KTAP TAP CR s" $" $"| .( ." $," ."| do$ DU. DU.R ? . U. D. .R U.R D.R S.R #> SIGN #S # HOLD <# DIGIT >CHAR CHARS CHAR+ CHAR- OCTAL BINARY HEX DECIMAL PAD SPACES SPACE 2VARIABLE 2CONSTANT 2LITERAL VARIABLE CONSTANT DOES> DOES CREATE doVAR RECURSE ; : $,n OVERT :NONAME ( [CHAR] POSTPONE ['] ! ' find SAME? DATA> TYPE> CODE> LINK> TOKEN WORD PACK$ -TRAILING FILL CMOVE COUNT KEY ?KEY ?RX TYPE EMIT TX! CHAR PARSE parse ALIGNED D2/ DU2/ D2* MU/MOD 2/ 2* */ */MOD M* * UM* / MOD /MOD M/MOD UM/MOD WITHIN UMAX UMIN MAX MIN M- M+ DMAX DMIN DU< D< D= D0= D0> D0< <> 0= 0<> 0> > < = U> U< DABS ABS S>D ?DUP 2@ 2! D- DNEGATE D+ 2- 2+ 1- 1+ - NEGATE XNOR XOR NOR OR AND NOT 2TUCK 2NIP -2ROT 2ROT 2OVER 2SWAP 2DUP 2DROP 2R@ 2R> 2>R TUCK NIP -ROT ROT \ TIB #TIB R@ @EXECUTE EXECUTE WHILE ELSE AFT REPEAT AHEAD UNTIL AGAIN BEGIN NEXT FOR THEN IF ] [ LITERAL STATE? COMPILE +! C, , ALLOT HERE IMMEDIATE =WORDLIST =IMMED BS BL FALSE TRUE RPP SPP STATE LAST NP CP CURRENT CONTEXT HANDLER HLD 'NUMBER 'EVAL CSP TIBB #TIBB >IN SPAN tmp BASE 'PROMPT 'ECHO 'TAP 'EXPECT 'EMIT '?KEY RP0 SP0 DPL FORTH BOOT CELL CELL- CELL+ CELLS + C! C@ F_CLOSE F_OPEN GETC PUTC 0BRANCH BRANCH next R> >R 0< NAND UM+ DUP SWAP OVER DROP ! @ EXIT LIT HALT NOP ; : 12 | 13 | 14 | 15 | OK. 16 | 17 | --------------------------------------------------------------------------------