├── README ├── cmforth.fth └── cmforth.txt /README: -------------------------------------------------------------------------------- 1 | Chuck Moore's Forth for the Novix NC4016, dated December 1987. 2 | 3 | Code is in cmforth.fth, shadow blocks in cmforth.txt. They are combined 4 | side-by-side in the 'combined' branch. 5 | -------------------------------------------------------------------------------- /cmforth.fth: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | ( FORTHkit 1987 December) 18 | ( Optimizing compiler) 4 LOAD 5 LOAD 6 LOAD 19 | : 0< \ 0< \ NOP ; 20 | : END \ RECURSIVE POP DROP ; 21 | : REMEMBER; CONTEXT 2 - 2@ , , \ END ; 22 | FORTH 23 | : -MOD ( n n - n) 4 I! MOD' ; ( 3) 24 | 25 | : THRU ( n n) OVER - FOR DUP LOAD 1 + NEXT DROP ; 26 | : EMPTY FORGET REMEMBER; 27 | 28 | 29 | 30 | 31 | 32 | 33 | ( Separated heads) 34 | VARIABLE H' HEX 2000 , ( relocation) 35 | : { dA @ HERE H' 2@ H ! dA ! H' 2! ; : } { ; 36 | COMPILER : } H' @ ,A \\ PREVIOUS 8000 XOR SWAP ! { ; 37 | FORTH : forget SMUDGE ; 38 | : RECOVER -1 ALLOT ; 39 | 40 | : SCAN ( a - a) @ BEGIN DUP 1 2000 WITHIN WHILE @ REPEAT ; 41 | : TRIM ( a a - a) DUP PUSH dA @ - SWAP ! POP 42 | DUP 1 + DUP @ DFFF AND OVER ! 43 | DUP @ 200 \ F AND + DUP @ FF7F AND SWAP ! ; 44 | : CLIP ( a) DUP BEGIN DUP SCAN DUP WHILE TRIM REPEAT 45 | 2025 XOR dA @ - SWAP ! @ , ; 46 | : PRUNE { CONTEXT 2 - DUP CLIP 1 + CLIP { 47 | 20 0 2025 2! EMPTY ; 48 | 49 | ( cmFORTH) EMPTY 50 | ( Target compiler) 2 LOAD 51 | HEX 2000 800 0 FILL 2000 H' ! 52 | : BOOT } 16 FFF FOR 0 @+ 1 !+ NEXT -1 @ ( reset) ; 53 | 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ( TIB) , 54 | 77C0 , 0 , 0 , 0 , 0 , 0 , 1FF ( S0) , A ( BASE) , 55 | 0 ( H) , DECIMAL 521 ( 5MHz 9600b/s) , 56 | { : interrupt } POP DROP ; 0 , 0 , 1 ( CONTEXT) , 57 | 58 | ( Nucleus) : # POP DROP ; 7 11 THRU 59 | ( Interpreter) 12 22 THRU 60 | ( Initialize) 23 24 THRU ' reset dA @ - HEX 2009 ! DECIMAL 61 | ( Compiler) 25 30 THRU } PRUNE 62 | 63 | : GO FLUSH [ HEX ] 2015 4 I! 15 6EA FOR 64 | 4 I@! 1 @+ 4 I@! 1 !+ NEXT 2009 PUSH ; 65 | ( Optimizing compiler) OCTAL 66 | : FORTH 1 CONTEXT ! ; 67 | : COMPILER 2 CONTEXT ! ; 68 | : uCODE ( n) CREATE , DOES R> 77777 AND @ ,C ; 69 | 70 | COMPILER : \ 2 -' IF DROP ABORT" ?" THEN ,A ; 71 | : !- 172700 SHORT ; 72 | : I@! 157700 SHORT ; 73 | 100000 uCODE NOP 140000 uCODE TWO 74 | 154600 uCODE 0+c 102404 uCODE MOD' 75 | 177300 uCODE N! 147303 uCODE -1 76 | FORTH : DUP? HERE 2 - @ 100120 = IF 77 | HERE 1 - @ 7100 XOR -2 ALLOT ,C THEN ; 78 | COMPILER : I! 157200 SHORT DUP? ; 79 | : PUSH 157201 ,C DUP? ; 80 | 81 | ( Defining Words) OCTAL 82 | FORTH : PACK ( a n - a) 160257 AND 140201 XOR IF 83 | 40 SWAP +! ELSE DROP 100040 , THEN POP DROP ; 84 | COMPILER : EXIT ?CODE @ DUP IF \\ DUP @ DUP 0< IF 85 | DUP 170000 AND 100000 = IF PACK THEN 86 | DUP 170300 AND 140300 = IF PACK THEN 87 | DUP 170000 AND 150000 = IF 88 | DUP 170600 AND 150000 XOR IF PACK THEN THEN DROP 89 | ELSE DUP HERE dA @ - XOR 170000 AND 0= IF 90 | 7777 AND 130000 XOR SWAP ! EXIT THEN DROP THEN 91 | THEN DROP 100040 , ; 92 | 93 | : ; \ RECURSIVE POP DROP \ EXIT ; 94 | FORTH : CONSTANT ( n) CREATE -1 ALLOT \ LITERAL \ EXIT ; 95 | 96 | 97 | ( Binary operators) OCTAL 98 | : BINARY ( n n) CREATE , , DOES POP 77777 AND 2@ 99 | ?CODE @ DUP IF @ DUP 117100 AND 107100 = 100 | OVER 177700 AND 157500 = OR IF ( v -!) 101 | DUP 107020 - IF SWAP DROP XOR DUP 700 AND 200 = IF 102 | 500 XOR ELSE DUP 70000 AND 0= IF 20 XOR THEN THEN 103 | ?CODE @ ! EXIT THEN 104 | THEN THEN DROP ,C DROP ; 105 | : SHIFT ( n n) CREATE , , DOES POP 77777 AND 2@ 106 | ?CODE @ ?DUP IF @ AND 100000 = WHILE ?CODE @ +! EXIT THEN 107 | DROP THEN 100000 XOR ,C ; 108 | COMPILER 7100 107020 BINARY DROP 109 | 4100 103020 BINARY OR 2100 105020 BINARY XOR 110 | 6100 101020 BINARY AND 3100 104020 BINARY + 111 | 5100 106020 BINARY - 1100 102020 BINARY SWAP- 112 | 2 171003 SHIFT 2* 1 171003 SHIFT 2/ 3 177003 SHIFT 0< 113 | ( Nucleus) OCTAL 114 | : ROT ( n n n - n n n) PUSH SWAP POP SWAP ; ( 5) 115 | 116 | : 0= ( n - t) IF 0 EXIT THEN -1 ; ( 3) 117 | : NOT ( n - t) 0= ; ( 4) 118 | : < ( n n - t) - 0< ; ( 3) 119 | : > ( n n - t) SWAP- 0< ; ( 3) 120 | : = ( n n - t) XOR 0= ; ( 5) 121 | : U< ( u u - t) - 2/ 0< ; ( 3) 122 | 123 | { COMPILER 124 | 104411 uCODE *' 102411 uCODE *- 125 | 100012 uCODE D2* 100011 uCODE D2/ 126 | 102416 uCODE /' 102414 uCODE /'' 127 | ( 102412 uCODE *F 102616 uCODE S') FORTH } 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | ( Multiply, divide) 146 | : M/MOD ( l h u - q r) 4 I! D2* 13 TIMES /' /'' ; ( 21) 147 | : M/ ( l h u - q r) OVER 0< IF DUP PUSH + POP THEN 148 | M/MOD DROP ; ( 27-30) 149 | : VNEGATE ( v - v) NEGATE SWAP NEGATE SWAP ; ( 5) 150 | : M* ( n n - d) DUP 0< IF VNEGATE THEN 0 SWAP 151 | 4 I! 13 TIMES *' *- ; ( 26-31) 152 | 153 | : /MOD ( u u - r q) 0 SWAP M/MOD SWAP ; ( 25) 154 | : MOD ( u u - r) /MOD DROP ; ( 27) 155 | 156 | : U*+ ( u n u - l h) 4 I! 14 TIMES *' ; ( 20) 157 | : */ ( n n u - n) PUSH M* POP M/ ; ( 64) 158 | : * ( n n - n) 0 SWAP U*+ DROP ; ( 24) 159 | : / ( n u - q) PUSH DUP 0< POP M/ ; ( 35) 160 | 161 | ( Memory reference operators) 162 | : 2/MOD ( n - r q) DUP 1 AND SWAP 0 [ \\ ] + 2/ ; ( 6) 163 | 164 | : +! ( n a) 0 @+ PUSH + POP ! ; ( 9) 165 | : C! ( n b) 2/MOD DUP PUSH @ SWAP IF -256 AND 166 | ELSE 255 AND SWAP 6 TIMES 2* THEN XOR POP ! ; ( 20-29) 167 | : C@ ( b - n) 2/MOD @ SWAP 1 - IF 6 TIMES 2/ THEN 255 AND ; 168 | ( 10-20) 169 | : 2@ ( a - d) 1 @+ @ SWAP ; ( 6) 170 | : 2! ( d a) 1 !+ ! ; ( 6) 171 | 172 | { OCTAL COMPILER : -ZERO 1 + \ BEGIN 130000 , ; FORTH } 173 | : MOVE ( s d n) PUSH 4 I! BEGIN -ZERO 174 | 1 @+ 4 I@! 1 !+ 4 I@! THEN NEXT DROP ; ( 7* 5+) 175 | : FILL ( a n n) 4 I! FOR -ZERO 4 I@ SWAP 1 !+ THEN NEXT 176 | DROP ; ( 5* 5+) 177 | ( Words) 178 | : EXECUTE ( a) PUSH ; ( 3) 179 | : CYCLES ( n) TIMES ; ( 4 n+) 180 | 181 | : ?DUP ( n - n n, 0) DUP IF DUP EXIT THEN ; ( 4) 182 | : 2DUP ( d - d d) OVER OVER ; ( 3) 183 | : 2DROP ( d) DROP DROP ; ( 3) 184 | 185 | : WITHIN ( n l h - t) OVER - PUSH - POP U< ; 186 | : ABS ( n - u) DUP 0< IF NEGATE EXIT THEN ; ( 4) 187 | 188 | : MAX ( n n - n) OVER OVER - 0< IF BEGIN SWAP DROP ; 189 | : MIN ( n n - n) OVER OVER - 0< UNTIL THEN DROP ; ( 6) 190 | 191 | 192 | 193 | ( RAM allocation) OCTAL 194 | { : ARRAY ( n) CONSTANT 154462 USE ; 195 | HEX 10 CONSTANT PREV ( Last referenced buffer) 196 | 11 CONSTANT OLDEST ( oldest loaded buffer) 197 | 12 ARRAY BUFFERS ( Block in each buffer) } 198 | 2 1 - CONSTANT NB ( Number of buffers) 199 | 200 | { 14 CONSTANT CYLINDER } 15 CONSTANT TIB 201 | 202 | ( Initialized) 203 | 16 CONSTANT SPAN 17 CONSTANT >IN { 18 CONSTANT BLK } 204 | 19 CONSTANT dA 205 | 1A CONSTANT ?CODE 1B CONSTANT CURSOR 206 | { 1C CONSTANT S0 } 1D CONSTANT BASE 1E CONSTANT H 207 | 1F CONSTANT C/B 24 CONSTANT CONTEXT 208 | 209 | ( ASCII terminal: 4X in, 0X out) HEX 210 | : EMIT ( n) 1E D I! 2* S0 @ XOR 211 | 9 FOR DUP C I! 2/ C/B @ A - CYCLES NEXT DROP ; 212 | : CR D EMIT A EMIT ; 213 | : TYPE ( a - a) 2* DUP C@ 1 - FOR 1 + DUP C@ EMIT NEXT 214 | 2 + 2/ ; 215 | 216 | { : RX ( - n) } 0 I@ 10 AND ; ( 3) 217 | : KEY ( - n) 0 BEGIN RX 10 XOR UNTIL C/B @ DUP 2/ + 218 | 7 FOR 10 - CYCLES 2/ RX 2* 2* 2* OR C/B @ NEXT 219 | BEGIN RX UNTIL DROP ; 220 | 221 | 222 | 223 | 224 | 225 | ( Serial EXPECT) HEX 226 | : SPACE 20 EMIT ; 227 | : SPACES ( n) 0 MAX FOR -ZERO SPACE THEN NEXT ; 228 | : HOLD ( ..# x n - ..# x) SWAP PUSH SWAP 1 + POP ; 229 | 230 | : EXPECT ( a #) SWAP CURSOR ! 231 | 1 - DUP FOR KEY DUP 8 XOR IF 232 | DUP D XOR IF DUP CURSOR @ 1 !+ CURSOR ! EMIT 233 | ELSE SPACE DROP POP - SPAN ! EXIT THEN 234 | ELSE ( 8) DROP DUP I XOR [ OVER ] UNTIL 235 | CURSOR @ 1 - CURSOR ! POP 2 + PUSH 8 EMIT 236 | THEN NEXT 1 + SPAN ! ; 237 | 238 | 239 | 240 | 241 | ( Numbers) 242 | : DIGIT ( n - n) DUP 9 > 7 AND + 48 + ; 243 | : <# ( n - ..# n) -1 SWAP ; 244 | : #> ( ..# n) DROP FOR EMIT NEXT ; 245 | : SIGN ( ..# n n - ..# n) 0< IF 45 HOLD THEN ; 246 | : # ( ..# n - ..# n) BASE @ /MOD SWAP DIGIT HOLD ; 247 | : #S ( ..# n - ..# 0) BEGIN # DUP 0= UNTIL ; 248 | : (.) ( n - ..# n) DUP PUSH ABS <# #S POP SIGN ; 249 | : . ( n) (.) #> SPACE ; 250 | 251 | : U.R ( u n) PUSH <# #S OVER POP SWAP- 1 - SPACES #> ; 252 | : U. ( u) 0 U.R SPACE ; 253 | : DUMP ( a - a) CR DUP 5 U.R SPACE 7 FOR 254 | 1 @+ SWAP 7 U.R NEXT SPACE ; 255 | 256 | 257 | ( Strings) HEX 258 | : HERE ( - a) H @ ; 259 | 260 | { : abort" } H @ TYPE SPACE POP 7FFF AND TYPE 2DROP 261 | BLK @ ?DUP DROP 0 ( QUIT) ; 262 | { : dot" } POP 7FFF AND TYPE PUSH ; 263 | 264 | { COMPILER : ABORT" COMPILE abort" 22 STRING ; 265 | : ." COMPILE dot" 22 STRING ; 266 | FORTH } 267 | 268 | 269 | 270 | 271 | 272 | 273 | ( 15-bit buffer manager) 274 | { : ADDRESS ( n - a) } 30 + 8 TIMES 2* ; 275 | { : ABSENT ( n - n) } NB FOR DUP I BUFFERS @ XOR 2* WHILE 276 | NEXT EXIT THEN POP PREV N! POP DROP SWAP DROP ADDRESS ; 277 | 278 | { : UPDATED ( - a n) } OLDEST @ BEGIN 1 + NB AND 279 | DUP PREV @ XOR UNTIL OLDEST N! PREV N! 280 | DUP ADDRESS SWAP BUFFERS DUP @ 281 | 8192 ROT ! DUP 0< NOT IF POP DROP DROP THEN ; 282 | 283 | : UPDATE PREV @ BUFFERS 0 @+ SWAP 32768 OR SWAP ! ; 284 | { : ESTABLISH ( n a - a) } SWAP OLDEST @ PREV N! 285 | BUFFERS ! ; 286 | : IDENTIFY ( n a - a) SWAP PREV @ BUFFERS ! ; 287 | 288 | 289 | ( Disk read/write) 290 | { : ## ( a n - a a #) } 0 EMIT 256 /MOD EMIT EMIT DUP 1023 ; 291 | 292 | { : buffer ( n - a) } UPDATED 293 | ## FOR 1 @+ SWAP EMIT NEXT KEY 2DROP ; 294 | : BUFFER ( n - a) buffer ESTABLISH ; 295 | 296 | { : block ( n a - n a) } OVER ## FOR KEY SWAP ] !+ 297 | NEXT DROP ; 298 | : BLOCK ( n - a) ABSENT buffer block ESTABLISH ; 299 | 300 | : FLUSH NB FOR 8192 BUFFER DROP NEXT ; 301 | : EMPTY-BUFFERS PREV [ NB 3 + ] LITERAL 0 FILL FLUSH ; 302 | 303 | 304 | 305 | ( Interpreter) 306 | { : LETTER ( b a # - b a) } FOR DUP @ 6 I@ XOR WHILE 307 | 1 @+ PUSH OVER C! 1 + POP NEXT EXIT THEN 308 | >IN @ POP - >IN ! ; 309 | { : -LETTER ( b a # - b a) } ?DUP IF 310 | 1 - FOR 1 @+ SWAP 6 I@ XOR 0= WHILE NEXT EXIT THEN 311 | 1 - POP LETTER THEN ; 312 | : WORD ( n - a) PUSH H @ DUP 2* DUP 1 + DUP >IN @ 313 | BLK @ IF BLK @ BLOCK + 1024 ELSE TIB @ + SPAN @ THEN 314 | >IN @ OVER >IN ! - POP 6 I! 315 | -LETTER DROP 32 OVER C! SWAP- SWAP C! ; 316 | 317 | 318 | 319 | 320 | 321 | ( Dictionary search) 322 | { : SAME ( h a - h a f, a t) } OVER 4 I! DUP 1 + 323 | 6 I@ FOR 1 @+ SWAP 4 I@ 1 @+ 4 I! - 2* IF 324 | POP DROP 0 AND EXIT THEN 325 | NEXT SWAP 1 + @ 0< IF @ THEN SWAP ; 326 | 327 | { : COUNT ( n - n) } 7 TIMES 2/ 15 AND ; 328 | { : HASH ( n - a) } CONTEXT SWAP- ; 329 | { : -FIND ( h n - h t, a f) } HASH OVER @ COUNT 6 I! 330 | BEGIN @ DUP WHILE SAME UNTIL 0 EXIT THEN -1 XOR ; 331 | 332 | 333 | 334 | 335 | 336 | 337 | ( Number input) HEX 338 | : -DIGIT ( n - n) 30 - DUP 9 > IF 7 - DUP A < OR THEN 339 | DUP BASE @ U< IF EXIT THEN 340 | 2DROP ABORT" ?" ; RECOVER 341 | 342 | { : C@+ ( - n) } 6 I@ 1 + DUP 6 I! C@ ; 343 | { : 10*+ ( u n - u) } -DIGIT 0E TIMES *' DROP ; 344 | : NUMBER ( a - n) BASE @ 4 I! 0 SWAP 2* DUP 1 + C@ 2D = 345 | PUSH DUP I - 6 I! C@ I + 1 - FOR C@+ 10*+ NEXT 346 | POP IF NEGATE THEN ; 347 | 348 | 349 | 350 | 351 | 352 | 353 | ( Control) 354 | : -' ( n - h t, a f) 32 WORD SWAP -FIND ; 355 | : ' ( - a) CONTEXT @ -' IF DROP ABORT" ?" THEN ; forget 356 | 357 | : INTERPRET ( n n) >IN 2! BEGIN 1 -' IF NUMBER 358 | ELSE EXECUTE THEN AGAIN ; RECOVER 359 | 360 | : QUIT BEGIN CR TIB @ 64 EXPECT 361 | 0 0 INTERPRET ." ok" AGAIN ; RECOVER 362 | 363 | ' QUIT dA @ - ' abort" 11 + ! 364 | 365 | 366 | 367 | 368 | 369 | ( Initialize) HEX 370 | : FORGET ( a) POP 7FFF AND DUP 2 + H ! 2@ CONTEXT 2 - 2! 371 | 1 CONTEXT ! ; 372 | 373 | { : BPS } 4 BEGIN RX 10 XOR UNTIL BEGIN 5 + RX UNTIL 374 | 2/ C/B ! ; 375 | { : RS232 } RX IF EXIT THEN 200 S0 ! 0B 0 I! ; 376 | 377 | { : reset } 0 ( RESET) 378 | 0 DUP 9 I! DUP A I! DUP 0B I! DUP 8 I! -1 A I! 379 | DUP D I! DUP E I! F I! 1A C I! 380 | TIB 2@ XOR IF EMPTY-BUFFERS SPAN @ TIB ! THEN 381 | RS232 F E I! BPS ." hi" QUIT ; 382 | 383 | 384 | 385 | ( Words) 386 | : SWAP SWAP ; : OVER OVER ; 387 | : DUP DUP ; : DROP DROP ; 388 | 389 | : XOR XOR ; : AND AND ; 390 | : OR OR ; 391 | : + + ; : - - ; 392 | : 0< 0< ; : NEGATE NEGATE ; 393 | 394 | : @ @ ; : ! ! ; 395 | 396 | : OCTAL 8 BASE ! ; forget 397 | : DECIMAL 10 BASE ! ; forget 398 | : HEX 16 BASE ! ; forget 399 | : LOAD ( n) >IN 2@ PUSH PUSH 0 INTERPRET 10 BASE ! 400 | POP POP >IN 2! ; forget 401 | ( Compiler) OCTAL 402 | : \\ 0 ?CODE ! ; 403 | : ALLOT ( n) H +! \\ ; 404 | : , ( n) H @ ! 1 H +! ; 405 | : ,C ( n) H @ ?CODE ! , ; 406 | : ,A ( a) dA @ - ,C ; 407 | COMPILER : LITERAL ( n) DUP -40 AND IF 147500 ,C , EXIT 408 | THEN 157500 XOR ,C ; 409 | : [ POP DROP ; 410 | 411 | FORTH : ] BEGIN 2 -' IF 1 -FIND IF NUMBER \ LITERAL 412 | ELSE DUP @ 413 | DUP 140040 AND 140040 = OVER 170377 AND 140342 XOR AND 414 | SWAP 170040 AND 100040 = OR IF @ 40 XOR ,C 415 | ELSE ,A THEN THEN 416 | ELSE EXECUTE THEN AGAIN ; RECOVER 417 | ( Compiler) HEX 418 | : PREVIOUS ( - a n) CONTEXT @ HASH @ 1 + 0 @+ SWAP ; 419 | : USE ( a) PREVIOUS COUNT + 1 + ! ; 420 | : DOES POP 7FFF AND USE ; 421 | : SMUDGE PREVIOUS 2000 XOR SWAP ! ; 422 | : EXIT POP DROP ; 423 | 424 | : COMPILE POP 7FFF AND 1 @+ PUSH ,A ; 425 | OCTAL 426 | COMPILER : EXIT 100040 ,C ; HEX 427 | : RECURSIVE PREVIOUS DFFF AND SWAP ! ; 428 | : ; \ RECURSIVE POP DROP \ EXIT ; forget 429 | 430 | 431 | 432 | 433 | ( Defining words) OCTAL 434 | FORTH : CREATE H @ 0 , 40 WORD CONTEXT @ HASH 435 | 2DUP @ SWAP 1 - ! SWAP @ COUNT 1 + ALLOT ! 147342 , ; 436 | 437 | : : CREATE -1 ALLOT SMUDGE ] ; forget 438 | 439 | : CONSTANT ( n) CREATE -1 ALLOT \ LITERAL \ EXIT ; 440 | : VARIABLE CREATE 0 , ; 441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | 449 | ( uCODE) OCTAL 450 | : -SHORT ( - t) ?CODE @ @ 177700 AND 157500 XOR ; 451 | : FIX ( n) ?CODE @ @ 77 AND OR ?CODE @ ! ; 452 | : SHORT ( n) -SHORT IF DROP ABORT" n?" THEN FIX ; 453 | 454 | COMPILER 455 | : @ -SHORT IF 167100 ,C ELSE 147100 FIX THEN ; forget 456 | : ! -SHORT IF 177000 ,C ELSE 157000 FIX THEN ; forget 457 | : I@ 147300 SHORT ; 458 | : I! 157200 SHORT ; 459 | : @+ 164700 SHORT ; 460 | : !+ 174700 SHORT ; 461 | 462 | : R> 147321 ,C ; 463 | : POP 147321 ,C ; : PUSH 157201 ,C ; 464 | : I 147301 ,C ; : TIMES 157221 ,C ; forget 465 | ( Structures) OCTAL 466 | FORTH { : OR, ( n n) } \\ SWAP 7777 AND OR , ; 467 | COMPILER : BEGIN ( - a) H @ \\ ; 468 | 469 | : UNTIL ( a) 110000 OR, ; 470 | : AGAIN ( a) 130000 OR, ; 471 | : THEN ( a) \ BEGIN 7777 AND SWAP +! ; 472 | : IF ( - a) \ BEGIN 110000 , ; 473 | : WHILE ( a - a a) \ IF SWAP ; 474 | : REPEAT ( a a) \ AGAIN \ THEN ; 475 | : ELSE ( a - a) \ BEGIN 130000 , SWAP \ THEN ; 476 | 477 | : FOR ( - a) \ PUSH \ BEGIN ; 478 | : NEXT ( a) 120000 OR, ; 479 | 480 | 481 | ( Strings) HEX 482 | FORTH : STRING ( n) WORD @ 7 TIMES 2/ 1 + ALLOT ; 483 | 484 | COMPILER : ABORT" COMPILE abort" 22 STRING ; 485 | : ." COMPILE dot" 22 STRING ; 486 | : ( 29 WORD DROP ; 487 | 488 | FORTH : ( \ ( ; 489 | 490 | : RESET FORGET 0 ; RECOVER ' RESET dA @ - ' reset ! 491 | 492 | 493 | 494 | 495 | 496 | 497 | -------------------------------------------------------------------------------- /cmforth.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | cmFORTH shadow blocks (1987 December). Addresses are hex; 18 | word timing in parentheses after ; ( cycles) . 19 | 20 | 1 LOAD compiles the compacting compiler (blocks 4-6). Block 6 21 | exits in COMPILER vocabulary, anticipating additions. 22 | 0< is redefined to resolve timing conflict. 23 | END terminates a definition. 24 | REMEMBER; saves vocabulary heads (at compile time). 25 | 26 | FORTH puts following words in interpretive vocabulary. 27 | -MOD provides modular arithmetic. It does a subtract if the 28 | result is non-negative. 29 | 30 | THRU loads a sequence of blocks. 31 | EMPTY empties the dictionary except for compacting compiler. 32 | 33 | H' holds the next available address in the target dictionary. 34 | 2000 relocates target addresses from RAM (2000) to PROM (0). 35 | { } switches between host and target dictionary by exchanging 36 | pointers and relocation offsets. 37 | COMPILER } compiles an indirect reference for a headless word. 38 | forget smudges a word that cannot execute in target dictionary. 39 | 40 | RECOVER recovers a return (after AGAIN ). 41 | 42 | SCAN finds the next word in target dictionary. 43 | TRIM relocates the vocabulary link and erases the smudge bit. 44 | CLIP constructs a target vocabulary and stores its head. 45 | PRUNE relinks the target dictionary to produce a stand-alone 46 | application (fixing the end-of-vocabulary word) 47 | and restores the host dictionary. 48 | 49 | 3 LOAD recompiles cmFORTH. EMPTY clears dictionary for a new 50 | application. 51 | 2 LOAD compiles the target compiler. 52 | Target is compiled at 2000 which is initialized to 0. 53 | BOOT copies PROM to RAM at power-up. The reference to -1 54 | disables PROM and enables RAM (setting A15 clocks 74). 55 | Low RAM (16-24) is initialized (see block 12). 56 | 57 | # is the bottom of the target dictionary. PRUNE changes its 58 | name to null and link to 0. This version of EXIT marks the 59 | end of both vocabulary chains. 60 | The address of RESET is relocated into the end of BOOT . 61 | The end of target program is stored into TIB and HERE . 62 | COMPILER head is selected for PRUNE . 63 | GO emulates BOOT for testing: 3 LOAD GO 64 | 65 | FORTH sets interpretive vocabulary for both searches and 66 | definitions. Words are compiled in definitions. 67 | COMPILER sets immediate vocabulary. Words are executed in : . 68 | uCODE names a NC4016 micro-coded instruction. Compiled on use. 69 | \ compiles a following compiler directive (that would normally 70 | be executed). Named [COMPILE] in FORTH-83. 71 | 72 | 4016 instructions: 73 | !- stores and decrements. I@! exchanges stack®ister. 74 | NOP delays 1 cycle. TWO delays 2 cycles. 75 | 0+c Adds 0 with carry. MOD' conditionally subtracts R4. 76 | N! stores and saves data. -1 fetches register 3 77 | 78 | DUP? compacts preceeding DUP with current instruction. Used 79 | to redefine I! and PUSH (previously >R ). 80 | 81 | PACK sets the return bit, if an instruction does not reference 82 | the Return stack. Otherwise it compiles a return. It exits 83 | from EXIT with POP DROP . 84 | 85 | EXIT optimizes return if permitted ( ?CODE nonzero): 86 | For instructions (bit-15 = 1) it calls PACK except for jump 87 | or 2-cycle instructions; 88 | for calls to the same 4K page, it substitutes a jump. 89 | 90 | ; is redefined to use the new EXIT . 91 | 92 | CONSTANT is redefined to take advantage of the new EXIT for 93 | 5-bit literals. 94 | 95 | 96 | 97 | BINARY defines and compacts ALU instructions. If the previous 98 | instruction was a fetch (ALU code 7) and not a store or DROP 99 | the ALU code is merged; stack push is inhibited. Otherwise 100 | a new instruction is compiled. ?CODE holds address of 101 | candidate for compaction. 102 | 103 | SHIFT defines and compacts shift instructions. Shift left 104 | ( 2* ) and right ( 2/) may be merged with an arithmetic 105 | instruction; sign propagate ( 0< ) only with DUP . 106 | 107 | DROP OR XOR AND + - SWAP- are redefined. 108 | 2* 2/ 0< likewise. 109 | 110 | 111 | 112 | 113 | ROT is a slow way to reference into the stack. 114 | 115 | 0= returns false (0) if stack non-zero; otherwise true ( -1). 116 | NOT same as 0=. FORTH-83 wants one's complement. 117 | < > subtract and test sign bit. Range of difference limited 118 | to 15 bits (-20000 is not less-than 20000). 119 | = equality tested by XOR. 120 | U< unsigned compare with 16-bit range (0 is less-than 40000). 121 | 122 | { ... } surround words defined into host dictionary. Used 123 | during compilation, they will not be in target dictionary. 124 | 4016 instructions: 125 | *' multiply step *- signed multiply step 126 | D2* 32-bit left shift D2/ 32-bit right shift 127 | /' divide step /'' final divide step 128 | F* fraction multiply S' square-root step 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | M/MOD 30-bit dividend; 15-bit divisor, quotient, remainder. 146 | M/ signed dividend; 15-bit divisor, quotient. 147 | VNEGATE negates both multiplier and multiplicand. 148 | M* 32-bit signed product; multiplier (on top) must be even. 149 | 150 | /MOD 15-bit dividend, divisor, quotient, remainder. 151 | MOD 15-bit dividend, divisor, remainder. 152 | 153 | U*+ 15-bit multiplier, multiplicand, addend; 30-bit product. 154 | */ signed multiplier, multiplicand, result; 15-bit divisor; 155 | multiplier (in middle) must be even. 156 | * signed product; multiplier (on top) must be even. 157 | / signed dividend, quotient; 15-bit divisor. 158 | 159 | 160 | 161 | 2/MOD 16-bit unsigned dividend; 15-bit quotient, remainder. 162 | \\ (break compaction) used to combine + 2/ ; 163 | +! adds to memory. 164 | Byte address is 2* cell address; high byte is byte 0. Range 165 | restricted to low RAM (0-7FFF). 166 | C! stores 8-bit data into byte address; other byte unaffected. 167 | C@ fetches 8-bits from byte address. 168 | 169 | 2@ fetches 2 16-bit numbers; lower address on top. 170 | 2! stores 2 16-bit numbers. 171 | 172 | MOVE the fastest move that does not stream to-from stack. 173 | FILL fills RAM with constant. 174 | 175 | 176 | 177 | EXECUTE executes code at an address by returning to it. 178 | CYCLES delays n+4 cycles - count 'em. 179 | 180 | ?DUP copies stack if non-zero. 181 | 2DUP copies 32-bit (2 16-bit) stack item. 182 | 2DROP DROP DROP ; is faster and usually no longer. 183 | 184 | WITHIN returns true if number within low (inclusive) and high 185 | (non-inclusive) limits; all numbers 16 bits or signed. 186 | ABS returns positive number (15-bits). 187 | 188 | MAX returns larger of pair; 15-bit range. 189 | MIN returns smaller. Intertwining code saves 2 cells; left in 190 | as illustration of obscure but efficient code. 191 | 192 | 193 | ARRAY defines an array that adds an index from stack in only 194 | 2 cycles. Similar to VARIABLE . 195 | 196 | These low-RAM variables are used by cmFORTH (0-F are unused). 197 | Change them cautiously! In particular, make sure a variable 198 | is not used during compilation. For example, HEX is 199 | redefined to set BASE . It can be used if BASE has not 200 | moved; otherwise it must be forgetted. 201 | Non-standard variables: 202 | ?CODE address of last instruction compiled. Zero indicates 203 | no compaction permitted (ie, after THEN ). 204 | dA offset to be added to compiled addresses. Normally 0. 205 | Relocated code cannot be executed! 206 | CURSOR tracks cursor (terminal dependent); used by EXPECT . 207 | S0 serial output polarity; 1FF or 200. 208 | C/B cycles/bit for serial I/O. 209 | EMIT sets Xmask to 1E so that only X0 can be changed. Start/ 210 | stop bits are added and polarity set. I! emits bits at C/B 211 | rate thru X0. 212 | CR emits carriage-return and line-feed. 213 | 214 | TYPE types a string with prefixed count byte. It returns an 215 | incremented cell address. This is not FORTH-83 standard. 216 | 217 | RX reads a bit from pin X4. 218 | KEY reads 8-bits from X4. It waits for a start bit, then 219 | delays until the middle of the first data bit. Each bit is 220 | sampled then ored into bit 7 of the accumulated byte. It 221 | does not exit until the stop bit (low) is detected. 222 | 223 | 224 | 225 | SPACE emits a space. 226 | SPACES emits n>0 spaces. 227 | HOLD holds characters on the stack, maintaining a count. 228 | It reverses the digits resulting from number conversion. 229 | 230 | EXPECT accepts keystrokes and buffers them (at TIB ). An 8 231 | will discard a character and emit a backspace; a D will 232 | emit a space and exit; all other keys are stored and echoed 233 | until the count is exhausted. Actual count is in SPAN . 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | DIGIT converts a digit (0-F) into an ASCII character. 242 | <# starts conversion by tucking a count under the number. 243 | #> ends conversion by emitting the string of digits. 244 | SIGN stacks a minus sign, if needed. 245 | # converts the low-order digit of a 16-bit number. 246 | #S converts non-zero digits, at least one. 247 | (.) formats a signed number. 248 | . displays a 16-bit signed integer, followed by a space. 249 | 250 | U.R displays a right-justified 16-bit unsigned number. 251 | U. displays an unsigned number. 252 | DUMP displays an address and 8 numbers from memory. It 253 | returns an incremented address for a subsequent DUMP . 254 | 255 | 256 | 257 | HERE returns next address in dictionary. 258 | 259 | abort" types the current word (at HERE ) and an error message 260 | (at I ) It also returns the current BLK to locate an 261 | error during LOAD . It will end with QUIT , when defined. 262 | It is a headless definition, referenced only by ABORT" . 263 | dot" types a message whose address is pulled off the return 264 | stack, incremented and replaced. 265 | 266 | ABORT" compiles abort" and the following string. This is a 267 | host COMPILER definition. The target definition is in 268 | block 30. 269 | ." compiles dot" and the following string. 270 | 271 | 272 | 273 | BUFFERS returns indexed address of buffer ID. 274 | PREV current buffer number (0-NB). 275 | OLDEST last buffer read. Next buffer is OLDEST @ 1 + . 276 | ADDRESS calculates a buffer address from buffer number. NB is 277 | 1. If increased, ADDRESS and BUFFERS must be also. 278 | ABSENT returns the block number when the requested block isn't 279 | already in RAM. Otherwise it returns the buffer address and 280 | exits from BLOCK . 281 | UPDATED returns the buffer address and current block number if 282 | the pending buffer has been UPDATEd . Otherwise it returns 283 | the buffer address and exits from the calling routine ( BLOCK 284 | or BUFFER ). Pending means oldest but not just used. 285 | UPDATE marks the current buffer ( PREV ) to be rewritten. 286 | ESTABLISH stores the block number of the current buffer. 287 | IDENTIFY stores a block number into the current buffer. Used 288 | to copy blocks. 289 | ## emits 3 bytes to host to start a block transfer; 0 followed 290 | by block number. 291 | 292 | buffer transmits an updated block and awaits acknowledgement. 293 | BUFFER returns address of an empty (but assigned) buffer. 294 | 295 | block reads a block. 296 | BLOCK returns the buffer address of a specified block, writing 297 | and reading as necessary. 298 | 299 | FLUSH forces buffers to be written. 300 | EMPTY-BUFFERS clears buffer IDs, without writing. 301 | 302 | 303 | 304 | 305 | LETTER moves a string of characters from cell address a to 306 | byte address b . Terminated by count ( # ) or delimitor 307 | (register 6). Input pointer >IN is advanced. 308 | 309 | -LETTER scans the source string for a non-delimiter. If found, 310 | calls LETTER . 311 | 312 | WORD locates text in either block buffer or TIB ( BLK is 0). 313 | Reads word into HERE prefixing count and suffixing a space 314 | (in case count even). 315 | 316 | 317 | 318 | 319 | 320 | 321 | SAME compares the string at HERE with a name field. Cell 322 | count is in register 6. High bit of each cell is ignored. 323 | Returns address of parameter field; requires indirect 324 | reference if high bit of count set (separated head). 325 | 326 | COUNT extracts the cell count from the first word of a string. 327 | HASH returns the address of the head of a vocabulary. 328 | -FIND searches a vocabulary for match with HERE . Fails with 329 | zero link field. 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | -DIGIT converts an ASCII character to a digit (0-Z). 338 | Failure generates an error message. 339 | 340 | C@+ increments address in register 6 and fetches character. 341 | 10*+ multiplies number by BASE and adds digit. 342 | NUMBER converts given string to binary; stores BASE in R4; 343 | saves minus sign; terminates on count; applies sign 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | -' searches vocabulary for following word. 354 | ' returns address of following word in current vocabulary 355 | Error message on failure. forget to use host version. 356 | 357 | INTERPRET accepts block number and offset. Searches FORTH 358 | and executes words found; otherwise converts to binary. 359 | 360 | QUIT accepts a character string into the text input buffer, 361 | interprets and replies ok to signify success; repeats. 362 | The address of QUIT is relocated into the end of abort" . 363 | 364 | 365 | 366 | 367 | 368 | 369 | FORGET restores HERE and vocabulary heads to values saved at 370 | compile time (by REMEMBER; ). 371 | 372 | BPS awaits a start bit, assumes only the first data bit is 373 | zero and computes C/B . Type a B or other even letter. 374 | RS232 examines the serial input line and inverts serial I/O if 375 | an inverting buffer is used (line rests low). 376 | 377 | reset is executed at power-up or reset. 378 | Carefully initializes I/O registers to avoid glitches. 379 | Empties buffers at power-up only ( TIB contains garbage). 380 | Calibrates serial I/O. 381 | Cheerful hi and awaits command. 382 | 383 | 384 | 385 | This is the beginning of the compiler. A turn-key application 386 | might need only the code above. 387 | 388 | Common words are defined for both interpreter and compiler. 389 | 390 | Number base words defined together; DECIMAL required. 391 | 392 | LOAD saves current input pointers, calls INTERPRET , restores 393 | input pointers and returns to DECIMAL . >IN and BLK are 394 | treated as a 32-bit pointer. forget so that host LOAD 395 | will be used. 396 | 397 | 398 | 399 | 400 | 401 | \\ breaks code compaction. 402 | ALLOT increments the dictionary pointer to allot memory. 403 | , compiles a number into the dictionary. 404 | ,C compiles an instruction available for compaction. 405 | ,A compiles a address relocated by dA . 406 | LITERAL compiles a number as a short literal, if possible. 407 | [ stops compilation by popping the return stack, thus returning 408 | out of the infinite ] loop. 409 | 410 | ] unlike INTERPRET , searches both vocabularies before falling 411 | into NUMBER . When a word is found in COMPILER it is 412 | executed; if found in FORTH it is compiled. If it is a 413 | single instruction, it is placed in-line; otherwise its 414 | address is compiled for a call. 415 | 416 | 417 | PREVIOUS returns the address and count of the name field of 418 | the word just defined. 419 | USE assigns to the previous word a specified code field. 420 | DOES provides a behavior for a newly defined word. It is 421 | executed when that word is defined. 422 | SMUDGE smudges the name field to avoid recursion. 423 | EXIT returns from a definition early ( FORTH version). 424 | 425 | COMPILE pops the address of the following word and compiles it. 426 | 7FFF AND masks the carry bit from the return stack. 427 | EXIT compiles a return instruction ( COMPILER version). 428 | RECURSIVE unsmudges the name field so a new word can be found. 429 | ; terminates a definition. forget permits more definitions. 430 | 431 | 432 | 433 | CREATE creates an entry in the dictionary. It saves space for 434 | the link field, then fetches a word terminated by space. It 435 | links the word into the proper vocabulary, allots space for 436 | the name field and compiles the return-next-address 437 | instruction appropriate for a variable. 438 | 439 | : creates a definition; -1 ALLOT recovers the instruction 440 | compiled by CREATE ; ] compiles the definition in its 441 | place. forget permits more definitions. 442 | 443 | CONSTANT names a number by compiling a literal. 444 | 445 | VARIABLE initializes its variable to zero. 446 | 447 | 448 | 449 | -SHORT checks if last instruction was a 5-bit literal. 450 | FIX merges 5-bit literal with new instruction. 451 | SHORT requires 5-bit literal (register, address or increment) 452 | for current instruction. Error message. 453 | 454 | @ and ! compile 5-bit or stack address instructions. 455 | I@ and I! compile 5-bit register instuctions. 456 | @+ and !+ compile 5-bit increment instructions. 457 | 458 | PUSH and POP push and pop the return stack. 459 | They are usually designated >R and R> . 460 | I copies the return stack onto the parameter stack. 461 | TIMES pushes the return stack to repeat the next instruction 462 | for n + 2 cycles. 463 | 464 | 465 | OR, compiles a 12-bit address with a backward jump instruction. 466 | BEGIN saves HERE for backward jumps. 467 | 468 | UNTIL compiles a conditional backward jump. 469 | AGAIN compiles an unconditional backward jump. 470 | THEN adds 12-bit current address into forward jump. 471 | IF compiles a conditional forward jump. 472 | WHILE compiles a conditional forward jump - out of structure. 473 | REPEAT resolves a BEGIN ... WHILE ... loop. 474 | ELSE inserts false clause in an IF ... THEN conditional. 475 | 476 | FOR compiles return stack push for a down-counting loop. 477 | NEXT compiles a backward decrement-and-jump. 478 | 479 | 480 | 481 | STRING compiles a character string with a specified delimiter. 482 | 483 | ABORT" DOT" are target versions of previously-defined host 484 | words. 485 | 486 | ( skips over a comment. It must be defined in both FORTH and 487 | COMPILER . 488 | 489 | RESET restores dictionary to power-up status. It must be the 490 | last word in the dictionary. It is called by reset . 491 | 492 | Insert application code before this block, to avoid using these 493 | common target words. Alternatively, forget them. 494 | 495 | 496 | 497 | --------------------------------------------------------------------------------