| bb6b2dcd |
1 | : FIRST_COLON ;\r |
| 2 | \r |
| 3 | : LATEST context @ ;\r |
| 4 | \r |
| 5 | : FLAG_IMMEDIATE 64 ;\r |
| 6 | \r |
| 7 | : IMMEDIATE\r |
| 8 | latest dup c@ flag_immediate OR\r |
| 9 | swap c!\r |
| 10 | ;\r |
| 11 | \r |
| 12 | : ( 41 word drop ; immediate\r |
| 13 | ( That was the definition for the comment word. )\r |
| 14 | ( Now we can add comments to what we are doing! )\r |
| 15 | ( Note that we are in decimal numeric input mode. )\r |
| 16 | \r |
| 17 | : \ ( <line> -- , comment out rest of line )\r |
| 18 | EOL word drop\r |
| 19 | ; immediate\r |
| 1cb310e6 |
20 | \r |
| 21 | \ 1 echo ! \ Uncomment this line to echo Forth code while compiling.\r |
| bb6b2dcd |
22 | \r |
| 23 | \ *********************************************************************\r |
| 24 | \ This is another style of comment that is common in Forth.\r |
| 25 | \ pFORTH - Portable Forth System\r |
| 26 | \ Based on HMSL Forth\r |
| 27 | \\r |
| 28 | \ Author: Phil Burk\r |
| 29 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r |
| 30 | \\r |
| 31 | \ The pForth software code is dedicated to the public domain,\r |
| 32 | \ and any third party may reproduce, distribute and modify\r |
| 33 | \ the pForth software code or any derivative works thereof\r |
| 34 | \ without any compensation or license. The pForth software\r |
| 35 | \ code is provided on an "as is" basis without any warranty\r |
| 36 | \ of any kind, including, without limitation, the implied\r |
| 37 | \ warranties of merchantability and fitness for a particular\r |
| 38 | \ purpose and their equivalents under the laws of any jurisdiction.\r |
| 39 | \ *********************************************************************\r |
| 40 | \r |
| 41 | : COUNT dup 1+ swap c@ ;\r |
| 42 | \r |
| 43 | \ Miscellaneous support words\r |
| 44 | : ON ( addr -- , set true )\r |
| 45 | -1 swap !\r |
| 46 | ;\r |
| 47 | : OFF ( addr -- , set false )\r |
| 48 | 0 swap !\r |
| 49 | ;\r |
| 50 | \r |
| bb6b2dcd |
51 | : CELL+ ( n -- n+cell ) cell + ;\r |
| 52 | : CELL- ( n -- n+cell ) cell - ;\r |
| 1cb310e6 |
53 | : CELL* ( n -- n*cell ) cells ; |
| bb6b2dcd |
54 | \r |
| 55 | : CHAR+ ( n -- n+size_of_char ) 1+ ;\r |
| 56 | : CHARS ( n -- n*size_of_char , don't do anything) ; immediate\r |
| 57 | \r |
| 58 | \ useful stack manipulation words\r |
| 59 | : -ROT ( a b c -- c a b )\r |
| 60 | rot rot\r |
| 61 | ;\r |
| 62 | : 3DUP ( a b c -- a b c a b c )\r |
| 63 | 2 pick 2 pick 2 pick\r |
| 64 | ;\r |
| 65 | : 2DROP ( a b -- )\r |
| 66 | drop drop\r |
| 67 | ;\r |
| 68 | : NIP ( a b -- b )\r |
| 69 | swap drop\r |
| 70 | ;\r |
| 71 | : TUCK ( a b -- b a b )\r |
| 72 | swap over\r |
| 73 | ;\r |
| 74 | \r |
| 75 | : <= ( a b -- f , true if A <= b )\r |
| 76 | > 0=\r |
| 77 | ;\r |
| 78 | : >= ( a b -- f , true if A >= b )\r |
| 79 | < 0=\r |
| 80 | ;\r |
| 81 | \r |
| 82 | : INVERT ( n -- 1'comp )\r |
| 83 | -1 xor\r |
| 84 | ;\r |
| 85 | \r |
| 86 | : NOT ( n -- !n , logical negation )\r |
| 87 | 0=\r |
| 88 | ;\r |
| 89 | \r |
| 90 | : NEGATE ( n -- -n )\r |
| 91 | 0 swap -\r |
| 92 | ;\r |
| 93 | \r |
| 94 | : DNEGATE ( d -- -d , negate by doing 0-d )\r |
| 95 | 0 0 2swap d-\r |
| 96 | ;\r |
| 97 | \r |
| 98 | \r |
| 99 | \ --------------------------------------------------------------------\r |
| 100 | \r |
| 101 | : ID. ( nfa -- )\r |
| 102 | count 31 and type\r |
| 103 | ;\r |
| 104 | \r |
| 105 | : DECIMAL 10 base ! ;\r |
| 106 | : OCTAL 8 base ! ;\r |
| 107 | : HEX 16 base ! ;\r |
| 108 | : BINARY 2 base ! ;\r |
| 109 | \r |
| 110 | : PAD ( -- addr )\r |
| 111 | here 128 +\r |
| 112 | ;\r |
| 113 | \r |
| 114 | : $MOVE ( $src $dst -- )\r |
| 115 | over c@ 1+ cmove\r |
| 116 | ;\r |
| 117 | : BETWEEN ( n lo hi -- flag , true if between lo & hi )\r |
| 118 | >r over r> > >r\r |
| 119 | < r> or 0=\r |
| 120 | ;\r |
| 121 | : [ ( -- , enter interpreter mode )\r |
| 122 | 0 state !\r |
| 123 | ; immediate\r |
| 124 | : ] ( -- enter compile mode )\r |
| 125 | 1 state !\r |
| 126 | ;\r |
| 127 | \r |
| 128 | : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;\r |
| 129 | : ALIGNED ( addr -- a-addr )\r |
| 130 | [ cell 1- ] literal +\r |
| 131 | [ cell 1- invert ] literal and\r |
| 132 | ;\r |
| 133 | : ALIGN ( -- , align DP ) dp @ aligned dp ! ;\r |
| 134 | : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;\r |
| 135 | \r |
| 136 | : C, ( c -- ) here c! 1 chars dp +! ;\r |
| 137 | : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;\r |
| 138 | : , ( n -- , lay into dictionary ) align here ! cell allot ;\r |
| 139 | \r |
| 140 | \ Dictionary conversions ------------------------------------------\r |
| 141 | \r |
| 142 | : N>NEXTLINK ( nfa -- nextlink , traverses name field )\r |
| 143 | dup c@ 31 and 1+ + aligned\r |
| 144 | ;\r |
| 145 | \r |
| 146 | : NAMEBASE ( -- base-of-names )\r |
| 147 | Headers-Base @\r |
| 148 | ;\r |
| 149 | : CODEBASE ( -- base-of-code dictionary )\r |
| 150 | Code-Base @\r |
| 151 | ;\r |
| 152 | \r |
| 153 | : NAMELIMIT ( -- limit-of-names )\r |
| 154 | Headers-limit @\r |
| 155 | ;\r |
| 156 | : CODELIMIT ( -- limit-of-code, last address in dictionary )\r |
| 157 | Code-limit @\r |
| 158 | ;\r |
| 159 | \r |
| 160 | : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )\r |
| 161 | namebase +\r |
| 162 | ;\r |
| 163 | \r |
| 164 | : >CODE ( xt -- secondary_code_address, not valid for primitives )\r |
| 165 | codebase +\r |
| 166 | ;\r |
| 167 | \r |
| 168 | : CODE> ( secondary_code_address -- xt , not valid for primitives )\r |
| 169 | codebase -\r |
| 170 | ;\r |
| 171 | \r |
| 172 | : N>LINK ( nfa -- lfa )\r |
| 1cb310e6 |
173 | 2 CELLS -\r |
| bb6b2dcd |
174 | ;\r |
| 175 | \r |
| 176 | : >BODY ( xt -- pfa )\r |
| 177 | >code body_offset +\r |
| 178 | ;\r |
| 179 | \r |
| 180 | : BODY> ( pfa -- xt )\r |
| 181 | body_offset - code>\r |
| 182 | ;\r |
| 183 | \r |
| 184 | \ convert between addresses useable by @, and relocatable addresses.\r |
| 185 | : USE->REL ( useable_addr -- rel_addr )\r |
| 186 | codebase -\r |
| 187 | ;\r |
| 188 | : REL->USE ( rel_addr -- useable_addr )\r |
| 189 | codebase +\r |
| 190 | ;\r |
| 191 | \r |
| 192 | \ for JForth code\r |
| 193 | \ : >REL ( adr -- adr ) ; immediate\r |
| 194 | \ : >ABS ( adr -- adr ) ; immediate\r |
| 195 | \r |
| 196 | : X@ ( addr -- xt , fetch execution token from relocatable ) @ ;\r |
| 197 | : X! ( addr -- xt , store execution token as relocatable ) ! ;\r |
| 198 | \r |
| 199 | \ Compiler support ------------------------------------------------\r |
| 200 | : COMPILE, ( xt -- , compile call to xt )\r |
| 201 | ,\r |
| 202 | ;\r |
| 203 | \r |
| 204 | ( Compiler support , based on FIG )\r |
| 205 | : [COMPILE] ( <name> -- , compile now even if immediate )\r |
| 206 | ' compile,\r |
| 207 | ; IMMEDIATE\r |
| 208 | \r |
| 209 | : (COMPILE) ( xt -- , postpone compilation of token )\r |
| 210 | [compile] literal ( compile a call to literal )\r |
| 211 | ( store xt of word to be compiled )\r |
| 212 | \r |
| 213 | [ ' compile, ] literal \ compile call to compile,\r |
| 214 | compile,\r |
| 215 | ;\r |
| 216 | \r |
| 217 | : COMPILE ( <name> -- , save xt and compile later )\r |
| 218 | ' (compile)\r |
| 219 | ; IMMEDIATE\r |
| 220 | \r |
| 221 | \r |
| 222 | : :NONAME ( -- xt , begin compilation of headerless secondary )\r |
| 223 | align\r |
| 224 | here code> \ convert here to execution token\r |
| 225 | ]\r |
| 226 | ;\r |
| 227 | \r |
| 228 | \ Error codes defined in ANSI Exception word set.\r |
| 229 | : ERR_ABORT -1 ; \ general abort\r |
| a8f5615d |
230 | : ERR_ABORTQ -2 ; \ for abort"\r |
| bb6b2dcd |
231 | : ERR_EXECUTING -14 ; \ compile time word while not compiling\r |
| 232 | : ERR_PAIRS -22 ; \ mismatch in conditional\r |
| 233 | : ERR_DEFER -258 ; \ not a deferred word\r |
| 234 | \r |
| 235 | : ABORT ( i*x -- )\r |
| 236 | ERR_ABORT throw\r |
| 237 | ;\r |
| 238 | \r |
| 239 | \ Conditionals in '83 form -----------------------------------------\r |
| 240 | : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r |
| 241 | : ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;\r |
| 242 | : >MARK ( -- addr ) here 0 , ;\r |
| 243 | : >RESOLVE ( addr -- ) here over - swap ! ;\r |
| 244 | : <MARK ( -- addr ) here ;\r |
| 245 | : <RESOLVE ( addr -- ) here - , ;\r |
| 246 | \r |
| 247 | : ?COMP ( -- , error if not compiling )\r |
| 248 | state @ 0= err_executing ?error\r |
| 249 | ;\r |
| 250 | : ?PAIRS ( n m -- )\r |
| 251 | - err_pairs ?error\r |
| 252 | ;\r |
| 253 | \ conditional primitives\r |
| 254 | : IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate\r |
| 255 | : THEN ( f orig -- ) swap ?condition >resolve ; immediate\r |
| 256 | : BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate\r |
| 257 | : AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate\r |
| 258 | : UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate\r |
| 259 | : AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate\r |
| 260 | \r |
| 261 | \ conditionals built from primitives\r |
| 262 | : ELSE ( f orig1 -- f orig2 )\r |
| 263 | [compile] AHEAD 2swap [compile] THEN ; immediate\r |
| 264 | : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate\r |
| 265 | : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate\r |
| 266 | \r |
| 267 | : ['] ( <name> -- xt , define compile time tick )\r |
| 268 | ?comp ' [compile] literal\r |
| 269 | ; immediate\r |
| 270 | \r |
| 271 | \ for example:\r |
| 272 | \ compile time: compile create , (does>) then ;\r |
| 273 | \ execution time: create <name>, ',' data, then patch pi to point to @\r |
| 274 | \ : con create , does> @ ;\r |
| 275 | \ 345 con pi\r |
| 276 | \ pi\r |
| 277 | \ \r |
| 278 | : (DOES>) ( xt -- , modify previous definition to execute code at xt )\r |
| 279 | latest name> >code \ get address of code for new word\r |
| 280 | cell + \ offset to second cell in create word\r |
| 281 | ! \ store execution token of DOES> code in new word\r |
| 282 | ;\r |
| 283 | \r |
| 284 | : DOES> ( -- , define execution code for CREATE word )\r |
| 285 | 0 [compile] literal \ dummy literal to hold xt\r |
| 286 | here cell- \ address of zero in literal\r |
| 287 | compile (does>) \ call (DOES>) from new creation word\r |
| 288 | >r \ move addrz to return stack so ; doesn't see stack garbage\r |
| 289 | [compile] ; \ terminate part of code before does>\r |
| 290 | r>\r |
| 291 | :noname ( addrz xt )\r |
| 292 | swap ! \ save execution token in literal\r |
| 293 | ; immediate\r |
| 294 | \r |
| 295 | : VARIABLE ( <name> -- )\r |
| 296 | CREATE 0 , \ IMMEDIATE\r |
| 297 | \ DOES> [compile] aliteral \ %Q This could be optimised\r |
| 298 | ;\r |
| 299 | \r |
| 300 | : 2VARIABLE ( <name> -c- ) ( -x- addr )\r |
| 301 | create 0 , 0 ,\r |
| 302 | ;\r |
| 303 | \r |
| 304 | : CONSTANT ( n <name> -c- ) ( -x- n )\r |
| 305 | CREATE , ( n -- )\r |
| 306 | DOES> @ ( -- n )\r |
| 307 | ;\r |
| 308 | \r |
| 309 | \r |
| 310 | \r |
| 311 | 0 1- constant -1\r |
| 312 | 0 2- constant -2\r |
| 313 | \r |
| 314 | : 2! ( x1 x2 addr -- , store x2 followed by x1 )\r |
| 315 | swap over ! cell+ !\r |
| 316 | ;\r |
| 317 | : 2@ ( addr -- x1 x2 )\r |
| 318 | dup cell+ @ swap @\r |
| 319 | ;\r |
| 320 | \r |
| 321 | \r |
| 322 | : ABS ( n -- |n| )\r |
| 323 | dup 0<\r |
| 324 | IF negate\r |
| 325 | THEN\r |
| 326 | ;\r |
| 327 | : DABS ( d -- |d| )\r |
| 328 | dup 0<\r |
| 329 | IF dnegate\r |
| 330 | THEN\r |
| 331 | ;\r |
| 332 | \r |
| 333 | : S>D ( s -- d , extend signed single precision to double )\r |
| 334 | dup 0<\r |
| 335 | IF -1\r |
| 336 | ELSE 0\r |
| 337 | THEN\r |
| 338 | ;\r |
| 339 | \r |
| 340 | : D>S ( d -- s ) drop ;\r |
| 341 | \r |
| 342 | : /MOD ( a b -- rem quo , unsigned version, FIXME )\r |
| 343 | >r s>d r> um/mod\r |
| 344 | ;\r |
| 345 | \r |
| 346 | : MOD ( a b -- rem )\r |
| 347 | /mod drop\r |
| 348 | ;\r |
| 349 | \r |
| 350 | : 2* ( n -- n*2 )\r |
| 351 | 1 lshift\r |
| 352 | ;\r |
| 353 | : 2/ ( n -- n/2 )\r |
| 354 | 1 arshift\r |
| 355 | ;\r |
| 356 | \r |
| 357 | : D2* ( d -- d*2 )\r |
| 1cb310e6 |
358 | 2* over |
| 359 | cell 8 * 1- rshift or swap\r |
| bb6b2dcd |
360 | 2* swap\r |
| 361 | ;\r |
| 362 | \r |
| 363 | \ define some useful constants ------------------------------\r |
| 364 | 1 0= constant FALSE\r |
| 365 | 0 0= constant TRUE\r |
| 366 | 32 constant BL\r |
| 367 | \r |
| 368 | \r |
| 369 | \ Store and Fetch relocatable data addresses. ---------------\r |
| 370 | : IF.USE->REL ( use -- rel , preserve zero )\r |
| 371 | dup IF use->rel THEN\r |
| 372 | ;\r |
| 373 | : IF.REL->USE ( rel -- use , preserve zero )\r |
| 374 | dup IF rel->use THEN\r |
| 375 | ;\r |
| 376 | \r |
| 377 | : A! ( dictionary_address addr -- )\r |
| 378 | >r if.use->rel r> !\r |
| 379 | ;\r |
| 380 | : A@ ( addr -- dictionary_address )\r |
| 381 | @ if.rel->use\r |
| 382 | ;\r |
| 383 | \r |
| 384 | : A, ( dictionary_address -- )\r |
| 385 | if.use->rel ,\r |
| 386 | ;\r |
| 387 | \r |
| 388 | \ Stack data structure ----------------------------------------\r |
| 389 | \ This is a general purpose stack utility used to implement necessary\r |
| 390 | \ stacks for the compiler or the user. Not real fast.\r |
| 391 | \ These stacks grow up which is different then normal.\r |
| 392 | \ cell 0 - stack pointer, offset from pfa of word\r |
| 393 | \ cell 1 - limit for range checking\r |
| 394 | \ cell 2 - first data location\r |
| 395 | \r |
| 396 | : :STACK ( #cells -- )\r |
| 397 | CREATE 2 cells , ( offset of first data location )\r |
| 398 | dup , ( limit for range checking, not currently used )\r |
| 399 | cells cell+ allot ( allot an extra cell for safety )\r |
| 400 | ;\r |
| 401 | \r |
| 402 | : >STACK ( n stack -- , push onto stack, postincrement )\r |
| 403 | dup @ 2dup cell+ swap ! ( -- n stack offset )\r |
| 404 | + !\r |
| 405 | ;\r |
| 406 | \r |
| 407 | : STACK> ( stack -- n , pop , predecrement )\r |
| 408 | dup @ cell- 2dup swap !\r |
| 409 | + @\r |
| 410 | ;\r |
| 411 | \r |
| 412 | : STACK@ ( stack -- n , copy )\r |
| 413 | dup @ cell- + @ \r |
| 414 | ;\r |
| 415 | \r |
| 416 | : STACK.PICK ( index stack -- n , grab Nth from top of stack )\r |
| 417 | dup @ cell- +\r |
| 418 | swap cells - \ offset for index\r |
| 419 | @ \r |
| 420 | ;\r |
| 421 | : STACKP ( stack -- ptr , to next empty location on stack )\r |
| 422 | dup @ +\r |
| 423 | ;\r |
| 424 | \r |
| 425 | : 0STACKP ( stack -- , clear stack)\r |
| 426 | 8 swap !\r |
| 427 | ;\r |
| 428 | \r |
| 429 | 32 :stack ustack\r |
| 430 | ustack 0stackp\r |
| 431 | \r |
| 432 | \ Define JForth like words.\r |
| 433 | : >US ustack >stack ;\r |
| 434 | : US> ustack stack> ;\r |
| 435 | : US@ ustack stack@ ;\r |
| 436 | : 0USP ustack 0stackp ;\r |
| 437 | \r |
| 438 | \r |
| 439 | \ DO LOOP ------------------------------------------------\r |
| 440 | \r |
| 441 | 3 constant do_flag\r |
| 442 | 4 constant leave_flag\r |
| 443 | 5 constant ?do_flag\r |
| 444 | \r |
| 445 | : DO ( -- , loop-back do_flag jump-from ?do_flag )\r |
| 446 | ?comp\r |
| 447 | compile (do)\r |
| 448 | here >us do_flag >us ( for backward branch )\r |
| 449 | ; immediate\r |
| 450 | \r |
| 451 | : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )\r |
| 452 | ?comp\r |
| 453 | ( leave address to set for forward branch )\r |
| 454 | compile (?do)\r |
| 455 | here 0 ,\r |
| 456 | here >us do_flag >us ( for backward branch )\r |
| 457 | >us ( for forward branch ) ?do_flag >us\r |
| 458 | ; immediate\r |
| 459 | \r |
| 460 | : LEAVE ( -- addr leave_flag )\r |
| 461 | compile (leave)\r |
| 462 | here 0 , >us\r |
| 463 | leave_flag >us\r |
| 464 | ; immediate\r |
| 465 | \r |
| 466 | : LOOP-FORWARD ( -us- jump-from ?do_flag -- )\r |
| 467 | BEGIN\r |
| 468 | us@ leave_flag =\r |
| 469 | us@ ?do_flag =\r |
| 470 | OR\r |
| 471 | WHILE\r |
| 472 | us> leave_flag =\r |
| 473 | IF\r |
| 474 | us> here over - cell+ swap !\r |
| 475 | ELSE\r |
| 476 | us> dup\r |
| 477 | here swap -\r |
| 478 | cell+ swap !\r |
| 479 | THEN\r |
| 480 | REPEAT\r |
| 481 | ;\r |
| 482 | \r |
| 483 | : LOOP-BACK ( loop-addr do_flag -us- )\r |
| 484 | us> do_flag ?pairs\r |
| 485 | us> here - here\r |
| 486 | !\r |
| 487 | cell allot\r |
| 488 | ;\r |
| 489 | \r |
| 490 | : LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r |
| 491 | compile (loop)\r |
| 492 | loop-forward loop-back\r |
| 493 | ; immediate\r |
| 494 | \r |
| 495 | \ : DOTEST 5 0 do 333 . loop 888 . ;\r |
| 496 | \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;\r |
| 497 | \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;\r |
| 498 | \r |
| 499 | : +LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r |
| 500 | compile (+loop)\r |
| 501 | loop-forward loop-back\r |
| 502 | ; immediate\r |
| 503 | \r |
| 504 | : UNLOOP ( loop-sys -r- )\r |
| 505 | r> \ save return pointer\r |
| 506 | rdrop rdrop\r |
| 507 | >r\r |
| 508 | ;\r |
| 509 | \r |
| 510 | : RECURSE ( ? -- ? , call the word currently being defined )\r |
| 511 | latest name> compile,\r |
| 512 | ; immediate\r |
| 513 | \r |
| 514 | \r |
| 515 | \r |
| 516 | : SPACE bl emit ;\r |
| 517 | : SPACES 512 min 0 max 0 ?DO space LOOP ;\r |
| 518 | : 0SP depth 0 ?do drop loop ;\r |
| 519 | \r |
| 520 | : >NEWLINE ( -- , CR if needed )\r |
| 521 | out @ 0>\r |
| 522 | IF cr\r |
| 523 | THEN\r |
| 524 | ;\r |
| 525 | \r |
| 526 | \r |
| 527 | \ Support for DEFER --------------------\r |
| 528 | : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )\r |
| 529 | >code @\r |
| 530 | ['] emit >code @\r |
| 531 | - err_defer ?error\r |
| 532 | ;\r |
| 533 | \r |
| 534 | : >is ( xt -- address_of_vector )\r |
| 535 | >code\r |
| 536 | cell +\r |
| 537 | ;\r |
| 538 | \r |
| 539 | : (IS) ( xt_do xt_deferred -- )\r |
| 540 | >is !\r |
| 541 | ;\r |
| 542 | \r |
| 543 | : IS ( xt <name> -- , act like normal IS )\r |
| 544 | ' \ xt\r |
| 545 | dup check.defer \r |
| 546 | state @\r |
| 547 | IF [compile] literal compile (is)\r |
| 548 | ELSE (is)\r |
| 549 | THEN\r |
| 550 | ; immediate\r |
| 551 | \r |
| 552 | : (WHAT'S) ( xt -- xt_do )\r |
| 553 | >is @\r |
| 554 | ;\r |
| 555 | : WHAT'S ( <name> -- xt , what will deferred word call? )\r |
| 556 | ' \ xt\r |
| 557 | dup check.defer\r |
| 558 | state @\r |
| 559 | IF [compile] literal compile (what's)\r |
| 560 | ELSE (what's)\r |
| 561 | THEN\r |
| 562 | ; immediate\r |
| 563 | \r |
| 564 | : /STRING ( addr len n -- addr' len' )\r |
| 565 | over min rot over + -rot -\r |
| 566 | ;\r |
| 567 | : PLACE ( addr len to -- , move string )\r |
| 568 | 3dup 1+ swap cmove c! drop\r |
| 569 | ;\r |
| 570 | \r |
| 571 | : PARSE-WORD ( char -- addr len )\r |
| 572 | >r source tuck >in @ /string r@ skip over swap r> scan\r |
| 573 | >r over - rot r> dup 0<> + - >in !\r |
| 574 | ;\r |
| 575 | : PARSE ( char -- addr len )\r |
| 576 | >r source >in @ /string over swap r> scan\r |
| 577 | >r over - dup r> 0<> - >in +!\r |
| 578 | ;\r |
| 579 | \r |
| 580 | : LWORD ( char -- addr )\r |
| 581 | parse-word here place here \ 00002 , use PARSE-WORD\r |
| 582 | ;\r |
| 583 | \r |
| 584 | : ASCII ( <char> -- char , state smart )\r |
| 585 | bl parse drop c@\r |
| 586 | state @\r |
| 587 | IF [compile] literal\r |
| 588 | THEN\r |
| 589 | ; immediate\r |
| 590 | \r |
| 591 | : CHAR ( <char> -- char , interpret mode )\r |
| 592 | bl parse drop c@\r |
| 593 | ;\r |
| 594 | \r |
| 595 | : [CHAR] ( <char> -- char , for compile mode )\r |
| 596 | char [compile] literal\r |
| 597 | ; immediate\r |
| 598 | \r |
| 599 | : $TYPE ( $string -- )\r |
| 600 | count type\r |
| 601 | ;\r |
| 602 | \r |
| 603 | : 'word ( -- addr ) here ;\r |
| 604 | \r |
| 605 | : EVEN ( addr -- addr' ) dup 1 and + ;\r |
| 606 | \r |
| 607 | : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)\r |
| 608 | r> dup count + aligned >r\r |
| 609 | ;\r |
| 610 | : (S") ( -- c-addr cnt )\r |
| 611 | r> count 2dup + aligned >r\r |
| 612 | ;\r |
| 613 | \r |
| 614 | : (.") ( -- , type following string )\r |
| 615 | r> count 2dup + aligned >r type\r |
| 616 | ;\r |
| 617 | \r |
| 618 | : ", ( adr len -- , place string into dictionary )\r |
| 619 | tuck 'word place 1+ allot align\r |
| 620 | ;\r |
| 621 | : ," ( -- )\r |
| 622 | [char] " parse ",\r |
| 623 | ;\r |
| 624 | \r |
| 625 | : .( ( <string> -- , type string delimited by parentheses )\r |
| 626 | [CHAR] ) PARSE TYPE\r |
| 627 | ; IMMEDIATE\r |
| 628 | \r |
| 629 | : ." ( <string> -- , type string )\r |
| 630 | state @\r |
| 631 | IF compile (.") ,"\r |
| 632 | ELSE [char] " parse type\r |
| 633 | THEN\r |
| 634 | ; immediate\r |
| 635 | \r |
| 636 | \r |
| 637 | : .' ( <string> -- , type string delimited by single quote )\r |
| 638 | state @\r |
| 639 | IF compile (.") [char] ' parse ",\r |
| 640 | ELSE [char] ' parse type\r |
| 641 | THEN\r |
| 642 | ; immediate\r |
| 643 | \r |
| 644 | : C" ( <string> -- addr , return string address, ANSI )\r |
| 645 | state @\r |
| 646 | IF compile (c") ,"\r |
| 647 | ELSE [char] " parse pad place pad\r |
| 648 | THEN\r |
| 649 | ; immediate\r |
| 650 | \r |
| 651 | : S" ( <string> -- , -- addr , return string address, ANSI )\r |
| 652 | state @\r |
| 653 | IF compile (s") ,"\r |
| 654 | ELSE [char] " parse pad place pad count\r |
| 655 | THEN\r |
| 656 | ; immediate\r |
| 657 | \r |
| 658 | : " ( <string> -- , -- addr , return string address )\r |
| 659 | [compile] C"\r |
| 660 | ; immediate\r |
| 661 | : P" ( <string> -- , -- addr , return string address )\r |
| 662 | [compile] C"\r |
| 663 | ; immediate\r |
| 664 | \r |
| 665 | : "" ( <string> -- addr )\r |
| 666 | state @\r |
| 667 | IF \r |
| 668 | compile (C")\r |
| 669 | bl parse-word ",\r |
| 670 | ELSE\r |
| 671 | bl parse-word pad place pad\r |
| 672 | THEN\r |
| 673 | ; immediate\r |
| 674 | \r |
| 675 | : SLITERAL ( addr cnt -- , compile string )\r |
| 676 | compile (S")\r |
| 677 | ",\r |
| 678 | ; IMMEDIATE\r |
| 679 | \r |
| 680 | : $APPEND ( addr count $1 -- , append text to $1 )\r |
| 681 | over >r\r |
| 682 | dup >r\r |
| 683 | count + ( -- a2 c2 end1 )\r |
| 684 | swap cmove\r |
| 685 | r> dup c@ ( a1 c1 )\r |
| 686 | r> + ( -- a1 totalcount )\r |
| 687 | swap c!\r |
| 688 | ;\r |
| 689 | \r |
| 690 | \r |
| 691 | \ ANSI word to replace [COMPILE] and COMPILE ----------------\r |
| 692 | : POSTPONE ( <name> -- )\r |
| 693 | bl word find\r |
| 694 | dup 0=\r |
| 695 | IF\r |
| 696 | ." Postpone could not find " count type cr abort\r |
| 697 | ELSE\r |
| 698 | 0>\r |
| 699 | IF compile, \ immediate\r |
| 700 | ELSE (compile) \ normal\r |
| 701 | THEN\r |
| 702 | THEN\r |
| 703 | ; immediate\r |
| 704 | \r |
| 705 | \ -----------------------------------------------------------------\r |
| 706 | \ Auto Initialization\r |
| 707 | : AUTO.INIT ( -- )\r |
| 708 | \ Kernel finds AUTO.INIT and executes it after loading dictionary.\r |
| 709 | \ ." Begin AUTO.INIT ------" cr\r |
| 710 | ;\r |
| 711 | : AUTO.TERM ( -- )\r |
| 712 | \ Kernel finds AUTO.TERM and executes it on bye.\r |
| 713 | \ ." End AUTO.TERM ------" cr\r |
| 714 | ;\r |
| 715 | \r |
| 716 | \ -------------- INCLUDE ------------------------------------------\r |
| 717 | variable TRACE-INCLUDE\r |
| 718 | \r |
| 719 | : INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?)\r |
| 720 | " ::::" pad $MOVE\r |
| 721 | count pad $APPEND\r |
| 722 | pad ['] noop (:)\r |
| 723 | ;\r |
| 724 | \r |
| 725 | : INCLUDE.MARK.END ( -- , mark end of include )\r |
| 726 | " ;;;;" ['] noop (:)\r |
| 727 | ;\r |
| 728 | \r |
| 729 | : $INCLUDE ( $filename -- )\r |
| 730 | \ Print messages.\r |
| 731 | trace-include @\r |
| 732 | IF\r |
| 733 | >newline ." Include " dup count type cr\r |
| 734 | THEN\r |
| 735 | here >r\r |
| 736 | dup\r |
| 737 | count r/o open-file \r |
| 738 | IF ( -- $filename bad-fid )\r |
| 739 | drop ." Could not find file " $type cr abort\r |
| 740 | ELSE ( -- $filename good-fid )\r |
| 741 | swap include.mark.start\r |
| bb6b2dcd |
742 | depth >r\r |
| 90975d26 |
743 | include-file \ will also close the file\r |
| bb6b2dcd |
744 | depth 1+ r> -\r |
| 745 | IF\r |
| 746 | ." Warning: stack depth changed during include!" cr\r |
| 747 | .s cr\r |
| 748 | 0sp\r |
| 749 | THEN\r |
| bb6b2dcd |
750 | include.mark.end\r |
| 751 | THEN\r |
| 752 | trace-include @\r |
| 753 | IF\r |
| 754 | ." include added " here r@ - . ." bytes,"\r |
| 755 | codelimit here - . ." left." cr\r |
| 756 | THEN\r |
| 757 | rdrop\r |
| 758 | ;\r |
| 759 | \r |
| 760 | create INCLUDE-SAVE-NAME 128 allot\r |
| 761 | : INCLUDE ( <fname> -- )\r |
| 762 | BL lword\r |
| 763 | dup include-save-name $move \ save for RI\r |
| 764 | $include\r |
| 765 | ;\r |
| 766 | \r |
| 767 | : RI ( -- , ReInclude previous file as a convenience )\r |
| 768 | include-save-name $include\r |
| 769 | ;\r |
| 770 | \r |
| 771 | : INCLUDE? ( <word> <file> -- , load file if word not defined )\r |
| 772 | bl word find\r |
| 773 | IF drop bl word drop ( eat word from source )\r |
| 774 | ELSE drop include\r |
| 775 | THEN\r |
| 776 | ;\r |
| 777 | \r |
| 778 | \ desired sizes for dictionary loaded after SAVE-FORTH\r |
| 779 | variable HEADERS-SIZE \r |
| 780 | variable CODE-SIZE\r |
| 781 | \r |
| 782 | : AUTO.INIT\r |
| 783 | auto.init\r |
| 784 | codelimit codebase - code-size !\r |
| 785 | namelimit namebase - headers-size !\r |
| 786 | ;\r |
| 787 | auto.init\r |
| 788 | \r |
| 789 | : SAVE-FORTH ( $name -- )\r |
| 790 | 0 \ Entry point\r |
| 791 | headers-ptr @ namebase - 65536 + \ NameSize\r |
| 792 | headers-size @ MAX\r |
| 793 | here codebase - 131072 + \ CodeSize\r |
| 794 | code-size @ MAX\r |
| 795 | (save-forth)\r |
| 796 | IF\r |
| 797 | ." SAVE-FORTH failed!" cr abort\r |
| 798 | THEN\r |
| 799 | ;\r |
| 800 | \r |
| 801 | : TURNKEY ( $name entry-token-- )\r |
| 802 | 0 \ NameSize = 0, names not saved in turnkey dictionary\r |
| 803 | here codebase - 131072 + \ CodeSize, remember that base is HEX\r |
| 804 | (save-forth)\r |
| 805 | IF\r |
| 806 | ." TURNKEY failed!" cr abort\r |
| 807 | THEN\r |
| 808 | ;\r |
| 809 | \r |
| 970d32b5 |
810 | \ Now that we can load from files, load remainder of dictionary.\r |
| bb6b2dcd |
811 | \r |
| 812 | trace-include on\r |
| a8f5615d |
813 | \ Turn this OFF if you do not want to see the contents of the stack after each entry.\r |
| 814 | trace-stack off\r |
| bb6b2dcd |
815 | \r |
| 816 | include loadp4th.fth\r |
| 817 | \r |
| 818 | decimal\r |
| 819 | \r |
| 820 | : ;;;; ; \ Mark end of this file so FILE? can find things in here.\r |
| 821 | FREEZE \ prevent forgetting below this point\r |
| 822 | \r |
| 823 | .( Dictionary compiled, save in "pforth.dic".) cr\r |
| 824 | c" pforth.dic" save-forth\r |
projects / pforth / blame