optional.f

   1 \\r
   2 \ OPTIONAL.F\r
   3 \ Optional wordset words for 8086 hForth\r
   4 \\r
   5 \ by Wonyong Koh\r
   6 \\r
   7 \ 1997. 7. 11.\r
   8 \       Fix D.R . Thank Benjamin Hoyt.\r
   9 \ 1997. 2. 28.\r
  10 \       Facelift to be used with other CPUs.\r
  11 \ 1996. 12. 6.\r
  12 \       Fix 'compiles>' for colon-sys.\r
  13 \ 1996. 11. 29.\r
  14 \       Remove PICK which was added in assembly source.\r
  15 \       Revise CASE, ENDCASE, OF, ENDOF, RETRY for control-flow stack.\r
  16 \       Revise '.xt' due to the removal of 'do."' and change of 'doS"'.\r
  17 \ 1995. 12. 26.\r
  18 \       Revise xt>name.\r
  19 \ 1995. 11. 25.\r
  20 \       Add RETRY described by Dr. Astle\r
  21 \               in Forth Dimensions 17(4), 19-21 (1995).\r
  22 \ 1995. 11. 7\r
  23 \       Fix ?DO.\r
  24 \ 1995. 10. 30.\r
  25 \       Check validity of xt in 'xt>name'. '-1 @' generates exception.\r
  26 \ 1995. 10. 17.\r
  27 \       Replace < with U< in the definition of MARKER for RAM and EXE\r
  28 \               models. U< should be used to compare addresses.\r
  29 \       Fix < to U< in the definition of xtSEE\r
  30 \ 1995. 10. 9.\r
  31 \       Rename WORDLIST-NAME which more consistant along VARIABLE, CONSTANT\r
  32 \               than NAME-WORDLIST\r
  33 \ 1995. 7. 21.\r
  34 \       Make HERE VALUE type and remove 'hereP'. Revise 'xhere'\r
  35 \               and remove 'TOxhere'.\r
  36 \       Make SOURCE-ID VALUE type, replace TOsource-id with\r
  37 \               "TO SOURCE-ID" and remove TOsource-id .\r
  38 \ 1995. 6. 11.\r
  39 \       Fix 'enough?'.\r
  40 \ 1995. 6. 3.\r
  41 \       Fix 'xtSEE' for RAM and EXE model.\r
  42 \\r
  43 \ Dictionary structures of hForth ROM, RAM and EXE models are all\r
  44 \ different.\r
  45 \  o  WORDLIST allocate empty wordlist dynamically in RAM and EXE model. Thus,\r
  46 \     there is no limit on maximum number of wordlist for RAM and EXE model.\r
  47 \     Maximum number os wordlists are limited to 10 in ROM model.\r
  48 \  o  -1 SET-ORDER is hard coded to put NONSTANDARD-WORDLIST and\r
  49 \     FORTH-WORDLIST into the search order stack for RAM model.\r
  50 \  o  MARKER is revised for combined code and name space for RAM model.\r
  51 \  o  'xt>name' are different\r
  52 \  o  PAD, xtSEE, xDUMP are different.\r
  53 \r
  54 BASE @\r
  55 DECIMAL\r
  56 \r
  57 \ **********************\r
  58 \ Optional String wordset\r
  59 \ **********************\r
  60 \r
  61 \   COMPARE     ( c-addr1 u1 c-addr2 u2 -- -1|0|1 )     \ STRING\r
  62 \               Compare the two strings. Return 0 if two strings are identical;\r
  63 \               -1 if ca1 u1 is smaller than ca2 u2; 1 otherwise.\r
  64 : COMPARE\r
  65     ROT 2DUP SWAP - >R          \ ca1 ca2 u2 u1  R: u1-u2\r
  66     MIN same? ?DUP\r
  67     IF R> DROP EXIT THEN\r
  68     R> DUP IF 0< 2* 1+ THEN ;\r
  69 \r
  70 \ **********************\r
  71 \ Optional Prgramming-Tools wordset\r
  72 \ **********************\r
  73 \r
  74 \   [ELSE]      ( *<spaces>name...* - )         \ TOOLS EXT\r
  75 \               Skipping leading spaces, parse and discard words from the\r
  76 \               parse area, including nested [IF] ... [THEN] and [IF] ...\r
  77 \               [ELSE] ... [THEN], until the word [THEN] has been parsed\r
  78 \               and discared.\r
  79 : [ELSE]  ( -- )\r
  80    1 BEGIN                                      \ level\r
  81      BEGIN  PARSE-WORD  DUP  WHILE              \ level c-addr len\r
  82        2DUP  S" [IF]"  COMPARE 0= IF            \ level c-addr len\r
  83          2DROP 1+                               \ level'\r
  84        ELSE                                     \ level c-addr len\r
  85          2DUP  S" [ELSE]"  COMPARE 0= IF        \ level c-addr len\r
  86            2DROP 1- DUP IF 1+ THEN              \ level'\r
  87          ELSE                                   \ level c-addr len\r
  88            S" [THEN]"  COMPARE 0= IF            \ level\r
  89              1-                                 \ level'\r
  90            THEN\r
  91          THEN\r
  92        THEN ?DUP 0=  IF EXIT THEN               \ level'\r
  93      REPEAT  2DROP                              \ level\r
  94    REFILL 0= UNTIL                              \ level\r
  95    DROP ;  IMMEDIATE\r
  96 \r
  97 \   [IF]        ( flag | flag *<spaces>name...* -- )    \ TOOLS EXT\r
  98 \               If flag is true, do nothing. Otherwise, Skipping leading\r
  99 \               spaces, parse and discard words from the parse area,\r
 100 \               including nested [IF] ... [THEN] and [IF] ... [ELSE] ...\r
 101 \               [THEN], until either the word [ELSE] or [THEN] has been\r
 102 \               parsed and discared.\r
 103 : [IF]  ( flag -- )                             \ TOOLS EXT\r
 104    0= IF POSTPONE [ELSE] THEN ;  IMMEDIATE\r
 105 \r
 106 \   [THEN]      ( -- )\r
 107 \               Do nothing.\r
 108 : [THEN]  ( -- )  ;  IMMEDIATE\r
 109 \r
 110 \ **********************\r
 111 \ Optional Search-Order wordset -- complete\r
 112 \ **********************\r
 113 \r
 114 \   SET-CURRENT   ( wid -- )                    \ SEARCH\r
 115 \               Set the compilation wordlist to the wordlist identified by wid.\r
 116 : SET-CURRENT   current ! ;\r
 117 \r
 118 \   DEFINITIONS   ( -- )                        \ SEARCH\r
 119 \               Make the compilation wordlist the same as the first wordlist\r
 120 \               in the search order.\r
 121 : DEFINITIONS   #order CELL+ @ SET-CURRENT ;\r
 122 \r
 123 \   GET-ORDER   ( -- widn .. wid1 n )           \ SEARCH\r
 124 \               Return the number of wordlist in the search order and the\r
 125 \               wordlist identifiers widn ... wid1 .\r
 126 : GET-ORDER\r
 127     #order @ DUP\r
 128     IF 1- 0 SWAP DO I CELLS #order CELL+ + @ -1 +LOOP\r
 129        #order @\r
 130     THEN ;\r
 131 \r
 132 \   SET-ORDER   ( widn .. wid1 n -- )           \ SEARCH\r
 133 \               Set the search order to the wordlist identified by widn ...\r
 134 \               wid1. Later wordlist wid1 will be searched first, with wordlist\r
 135 \               widn searched last. If n is 0, empty the search order. If n\r
 136 \               is -1, set the search order to the implementation-defined\r
 137 \               minimum search order.\r
 138 \r
 139 CHAR " PARSE model" ENVIRONMENT? DROP\r
 140 CHAR " PARSE ROM Model" COMPARE 0=\r
 141 [IF]\r
 142   : SET-ORDER\r
 143       DUP -1 =\r
 144       IF  DROP [ #order var0 - sysVar0 + ] LITERAL  #order\r
 145           [ BL PARSE WORDLISTS ENVIRONMENT? DROP 1+ ] LITERAL CELLS\r
 146           MOVE EXIT                                                  THEN\r
 147       DUP [ BL PARSE WORDLISTS ENVIRONMENT? DROP ] LITERAL >\r
 148           IF -49 THROW THEN\r
 149       DUP #order !\r
 150       ?DUP IF 0 DO I CELLS #order CELL+ + ! LOOP THEN ;\r
 151 [THEN]\r
 152 CHAR " PARSE model" ENVIRONMENT? DROP\r
 153 CHAR " PARSE RAM Model" COMPARE 0=\r
 154 CHAR " PARSE model" ENVIRONMENT? DROP\r
 155 CHAR " PARSE EXE Model" COMPARE 0= OR\r
 156 [IF]\r
 157   : SET-ORDER\r
 158       DUP -1 =\r
 159       IF DROP                   \ restore default # of search order\r
 160          #order0 DUP @ #order SWAP 1+ CELLS MOVE EXIT THEN\r
 161       DUP [ BL PARSE WORDLISTS ENVIRONMENT? DROP ] LITERAL >\r
 162           IF -49 THROW THEN\r
 163       DUP #order !\r
 164       ?DUP IF 0 DO #order I CELLS + CELL+ ! LOOP THEN ;\r
 165 [THEN]\r
 166 \r
 167 \   WORDLIST    ( -- wid )                      \ SEARCH\r
 168 \               Create a new empty wordlist and return its identifier wid.\r
 169 \               The new wordlist is returned from a preallocated pool for\r
 170 \               RAM/ROM system in this implementation since they need to be\r
 171 \               initialized after SAVE-SYSTEM. It may be dynamically allocated\r
 172 \               in RAM only system.\r
 173 \\r
 174 \               structure of a wordlist\r
 175 \               //lastWord/next_wordlist/wordlist_name//\r
 176 \r
 177 CHAR " PARSE model" ENVIRONMENT? DROP\r
 178 CHAR " PARSE ROM Model" COMPARE 0=\r
 179 [IF]\r
 180   : WORDLIST\r
 181       FORTH-WORDLIST                    \ the first wordlist\r
 182       BEGIN CELL+ DUP @ WHILE @ REPEAT\r
 183       DUP CELL+ CELL+ DUP @ IF          \ pre-allocated wordlist is available?\r
 184           -49 THROW THEN                \ search-order overflow\r
 185       DUP ROT ! ;                       \ attach a wordlist to wordlist link\r
 186 [THEN]\r
 187 CHAR " PARSE model" ENVIRONMENT? DROP\r
 188 CHAR " PARSE RAM Model" COMPARE 0=\r
 189 CHAR " PARSE model" ENVIRONMENT? DROP\r
 190 CHAR " PARSE EXE Model" COMPARE 0= OR\r
 191 [IF]\r
 192   : WORDLIST\r
 193       FORTH-WORDLIST                    \ the first wordlist\r
 194       BEGIN CELL+ DUP @ WHILE @ REPEAT  \ find end of wordlist link\r
 195       HERE SWAP !                       \ attach a wordlist to wordlist link\r
 196       HERE 0 ,                          \ no word in this wordlist yet\r
 197       0 ,                               \ this is end of wordlist link\r
 198       0 , ;                     \ no name is assigned to this wordlist yet.\r
 199 [THEN]\r
 200 \r
 201 \   ALSO        ( -- )                          \ SEARCH EXT\r
 202 \               Transform the search order widn ... wid2, wid1 into widn ...\r
 203 \               wid2, wid1, wid1.\r
 204 : ALSO   GET-ORDER OVER SWAP 1+ SET-ORDER ;\r
 205 \r
 206 \   FORTH       ( -- )\r
 207 \               Transform the search order widn ... wid2, wid1 into widn ...\r
 208 \               wid2, wid_FORTH-WORDLIST.\r
 209 : FORTH   GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ;\r
 210 \r
 211 \   ONLY        ( -- )\r
 212 \               Set the search order to the implementation-defined minimum\r
 213 \               search order.\r
 214 : ONLY   -1 SET-ORDER ;\r
 215 \r
 216 \   PREVIOUS    ( -- )\r
 217 \               Transform the search order widn ... wid2, wid1 into widn ...\r
 218 \               wid2.\r
 219 : PREVIOUS   GET-ORDER NIP 1- SET-ORDER ;\r
 220 \r
 221 NONSTANDARD-WORDLIST SET-CURRENT\r
 222 \r
 223 \   .name       ( c-addr -- )\r
 224 \               Display name of a word.\r
 225 : .name   COUNT 31 AND TYPE SPACE ;\r
 226 \r
 227 \   WORDLIST-NAME   ( wid -- )\r
 228 \               Name a wordlist. Used to attach a name to a new wordlist\r
 229 \               returned by WORDLIST to be displayed by ORDER.\r
 230 : WORDLIST-NAME   DUP CONSTANT  lastName SWAP CELL+ CELL+ ! ;\r
 231 \r
 232 \   .wordlist   ( c-addr -- )\r
 233 \               Display name of a wordlist.\r
 234 : .wordlist\r
 235     8 SPACES DUP CELL+ CELL+ @ ?DUP\r
 236     IF .name DROP CR EXIT THEN . CR ;\r
 237 \r
 238 FORTH-WORDLIST SET-CURRENT\r
 239 \r
 240 \   ORDER       ( -- )                          \ SEARCH EXT\r
 241 \               Display the wordlists in the search order from the first\r
 242 \               to the last. Also display the wordlist into which new\r
 243 \               definitions will be placed.\r
 244 : ORDER\r
 245     CR ." Search-Order:" CR\r
 246     GET-ORDER 0 DO .wordlist LOOP\r
 247     ." Current:" CR\r
 248     GET-CURRENT .wordlist ;\r
 249 \r
 250 envQList SET-CURRENT\r
 251 -1 CONSTANT SEARCH-ORDER\r
 252 -1 CONSTANT SEARCH-ORDER-EXT\r
 253 FORTH-WORDLIST SET-CURRENT\r
 254 \r
 255 \ **********************\r
 256 \ Optional Core Extention wordset\r
 257 \ **********************\r
 258 \r
 259 NONSTANDARD-WORDLIST SET-CURRENT\r
 260 CHAR " PARSE model" ENVIRONMENT? DROP\r
 261 CHAR " PARSE RAM Model" COMPARE 0=\r
 262 [IF]\r
 263     : xhere   HERE ;\r
 264     : code,   , ;\r
 265 [THEN]\r
 266 \r
 267 FORTH-WORDLIST SET-CURRENT\r
 268 \r
 269 \   .(          ( "ccc<)>" -- )                 \ CORE EXT\r
 270 \               Output following string up to next ) .\r
 271 : .(   [CHAR] ) PARSE TYPE ; IMMEDIATE\r
 272 \r
 273 \   D.R         ( d n -- )                      \ DOUBLE\r
 274 \               Display d right-justified in field of width n.\r
 275 : D.R   >R (d.) R> OVER -  SPACES  TYPE ;\r
 276 \r
 277 \   .R          ( n1 n2 -- )                    \ CORE EXT\r
 278 \               Display n right-justified in field of width n2.\r
 279 : .R   >R S>D R> D.R ;\r
 280 \r
 281 \   FALSE       ( -- false )                    \ CORE EXT\r
 282 \               Return a false flag.\r
 283 0 CONSTANT FALSE\r
 284 \r
 285 \   HEX         ( -- )                          \ CORE EXT\r
 286 \               Set contents of BASE to sixteen.\r
 287 : HEX   16 BASE ! ;\r
 288 \r
 289 \   U>          ( u1 u2 -- flag )               \ CORE  EXT\r
 290 \               flag is true if and only if u1 is greater than u2.\r
 291 : U>   SWAP U< ;\r
 292 \r
 293 \   MARKER      ( "<spaces>name" -- )           \ CORE EXT\r
 294 \               Create a definition with name. The new definition will\r
 295 \               restore on execution all dictionary allocations and search\r
 296 \               order pointers to the state they had just prior to the\r
 297 \               definition of name.\r
 298 CHAR " PARSE model" ENVIRONMENT? DROP\r
 299 CHAR " PARSE ROM Model" COMPARE 0=\r
 300 [IF]\r
 301   : MARKER\r
 302       ROMB @ ROMT @ RAMB @ RAMT @\r
 303       CREATE , , , , GET-CURRENT ,\r
 304              FORTH-WORDLIST                       \ start of wordlist link\r
 305              BEGIN CELL+ DUP @ WHILE @ REPEAT     \ find end of wordlist link\r
 306              , GET-ORDER DUP , 0 DO , LOOP\r
 307       DOES>       DUP @ RAMT ! CELL+ DUP @ RAMB !\r
 308             CELL+ DUP @ ROMT ! CELL+ DUP @ ROMB !\r
 309             CELL+ DUP @ SET-CURRENT\r
 310             CELL+ DUP @ 0 SWAP !                  \ restore end of wordlist link\r
 311             CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
 312                        DROP R> SET-ORDER          \ restore search order\r
 313             FORTH-WORDLIST    \ start of wordlist link\r
 314             BEGIN DUP @       \ last word name field of wordlist\r
 315                   BEGIN  DUP npVar @ @ U<\r
 316                   WHILE  cell- @\r
 317                   REPEAT OVER !       \ restore search order pointer\r
 318                   CELL+ @ ?DUP 0=     \ repeat to next wordlist\r
 319             UNTIL ;\r
 320 [THEN]\r
 321 CHAR " PARSE model" ENVIRONMENT? DROP\r
 322 CHAR " PARSE RAM Model" COMPARE 0=\r
 323 [IF]\r
 324   : MARKER\r
 325       HERE\r
 326       CREATE , GET-CURRENT ,\r
 327              FORTH-WORDLIST                       \ start of wordlist link\r
 328              BEGIN CELL+ DUP @ WHILE @ REPEAT     \ find end of wordlist link\r
 329              , GET-ORDER DUP , 0 DO , LOOP\r
 330       DOES>       DUP @ TO HERE\r
 331             CELL+ DUP @ SET-CURRENT\r
 332             CELL+ DUP @ 0 SWAP !                  \ restore end of wordlist link\r
 333             CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
 334                        DROP R> SET-ORDER          \ restore search order\r
 335             FORTH-WORDLIST    \ start of wordlist link\r
 336             BEGIN DUP @       \ last word name field of wordlist\r
 337                   BEGIN  DUP HERE U>\r
 338                   WHILE  cell- @\r
 339                   REPEAT OVER !       \ restore search order pointer\r
 340                   CELL+ @ ?DUP 0=     \ repeat to next wordlist\r
 341             UNTIL ;\r
 342 [THEN]\r
 343 CHAR " PARSE model" ENVIRONMENT? DROP\r
 344 CHAR " PARSE EXE Model" COMPARE 0=\r
 345 [IF]\r
 346   : MARKER\r
 347       HERE xhere\r
 348       CREATE , , GET-CURRENT ,\r
 349              FORTH-WORDLIST                       \ start of wordlist link\r
 350              BEGIN CELL+ DUP @ WHILE @ REPEAT     \ find end of wordlist link\r
 351              , GET-ORDER DUP , 0 DO , LOOP\r
 352       DOES>       DUP @ TO xhere  CELL+ DUP @ TO HERE\r
 353             CELL+ DUP @ SET-CURRENT\r
 354             CELL+ DUP @ 0 SWAP !                  \ restore end of wordlist link\r
 355             CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
 356                        DROP R> SET-ORDER          \ restore search order\r
 357             FORTH-WORDLIST    \ start of wordlist link\r
 358             BEGIN DUP @       \ last word name field of wordlist\r
 359                   BEGIN  DUP HERE U>\r
 360                   WHILE  cell- @\r
 361                   REPEAT OVER !       \ restore search order pointer\r
 362                   CELL+ @ ?DUP 0=     \ repeat to next wordlist\r
 363             UNTIL ;\r
 364 [THEN]\r
 365 \r
 366 \   PAD         ( -- a-addr )                   \ CORE EXT\r
 367 \               Return the address of a temporary buffer. See REFILL\r
 368 \               |PAD|TIB|RAMTop\r
 369 CHAR " PARSE model" ENVIRONMENT? DROP\r
 370 CHAR " PARSE ROM Model" COMPARE 0=\r
 371 [IF]\r
 372   : PAD   npVar @ [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 3 * NEGATE ] LITERAL + ;\r
 373 [THEN]\r
 374 CHAR " PARSE model" ENVIRONMENT? DROP\r
 375 CHAR " PARSE RAM Model" COMPARE 0=\r
 376 [IF]\r
 377   : PAD   memTop [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 2* NEGATE ] LITERAL + ;\r
 378 [THEN]\r
 379 CHAR " PARSE model" ENVIRONMENT? DROP\r
 380 CHAR " PARSE EXE Model" COMPARE 0=\r
 381 [IF]\r
 382   : PAD   memTop [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 2* NEGATE ] LITERAL + ;\r
 383 [THEN]\r
 384 \r
 385 \   TRUE        ( -- true )                     \ CORE EXT\r
 386 \               Return a true flag.\r
 387 -1 CONSTANT TRUE\r
 388 \r
 389 \   U.R         ( u n -- )                      \ CORE EXT\r
 390 \               Display u right-justified in field of width n.\r
 391 : U.R   0 SWAP D.R ;\r
 392 \r
 393 HEX\r
 394 \r
 395 \   CASE        ( C: -- case-sys )              \ CORE EXT\r
 396 \               Run-time: ( -- )\r
 397 \               Mark the start of CASE ... OF ... ENDOF ... ENDCASE structure.\r
 398 \               On run-time, continue execution.\r
 399 : CASE ( C: -- case-mark )\r
 400     0 3         \ case type is 3\r
 401     bal+ ; COMPILE-ONLY IMMEDIATE\r
 402 \r
 403 \   ENDCASE     ( C: case-sys -- )              \ CORE EXT\r
 404 \               Run-time: ( x -- )\r
 405 \               Mark the end of CASE ... OF ... ENDOF ... ENDCASE structure.\r
 406 \               On run-time, discard the case selector x and continue execution.\r
 407 : ENDCASE ( C: case-mark of-orig ... of-orig -- )\r
 408     POSTPONE DROP\r
 409     BEGIN  DUP 2 =      \ of-orig type is 2\r
 410     WHILE  1- POSTPONE THEN\r
 411     REPEAT\r
 412     3 - IF -22 THROW THEN       \ control structure mismatch\r
 413     DROP bal- ; COMPILE-ONLY IMMEDIATE\r
 414 \r
 415 \   OF          ( C: -- of-sys )                \ CORE EXT\r
 416 \               Run-time: ( x1 x2 -- |x1 )\r
 417 \               Mark the start of OF ... ENDOF part of CASE structure.\r
 418 \               On run-time if two values on the stack are not equal, discard\r
 419 \               the top value and continue execution following the next ENDOF.\r
 420 \               Otherwise discard both values and continue execution in line.\r
 421 : OF ( C: -- of-orig )\r
 422     POSTPONE OVER  POSTPONE =  POSTPONE IF  POSTPONE DROP\r
 423     1+          \ change orig type 1 to of-sys type 2\r
 424     ; COMPILE-ONLY IMMEDIATE\r
 425 \r
 426 \   ENDOF       ( C: case-sys1 of-sys -- case-sys2 )    \ CORE EXT\r
 427 \               Run-time: ( -- )\r
 428 \               Mark the end of OF ... ENDOF part of CASE structre.\r
 429 \               On run-time, continue execution following ENDCASE .\r
 430 : ENDOF ( C: of-orig1 -- of-orig2 )\r
 431     1-  POSTPONE ELSE  1+       \ of-orig type is 2; orig type is 1\r
 432     ; COMPILE-ONLY IMMEDIATE\r
 433 \r
 434 \   UNUSED      ( -- u )                                \ CORE EXT\r
 435 \               Return available data space in address units.\r
 436 : UNUSED    PAD HERE - ;    \ Available data space is HERE to PAD\r
 437 \r
 438 \ **********************\r
 439 \ Optional Prgramming-Tools wordset -- complete\r
 440 \ **********************\r
 441 \r
 442 DECIMAL\r
 443 \r
 444 \   .S          ( -- )                          \ TOOLS\r
 445 \               Display the values on the data stack.\r
 446 : .S   CR DEPTH ?DUP\r
 447        IF   1- 0 SWAP          \ 0 depth-1\r
 448             DO  I PICK\r
 449                 BASE @ 10 = IF . ELSE U. THEN\r
 450             -1 +LOOP\r
 451        THEN ." <sp " ;\r
 452 \r
 453 \   ?           ( a-addr -- )                   \ TOOLS\r
 454 \               Display the contents at a-addr.\r
 455 \\r
 456 : ?    @ BASE @ 10 = IF . EXIT THEN U. ;\r
 457 \r
 458 NONSTANDARD-WORDLIST SET-CURRENT\r
 459 \r
 460 \   enough?     ( -- flag )\r
 461 \               Return false if no input, else pause and if CR return true.\r
 462 : enough?   EKEY? DUP IF EKEY 2DROP EKEY 13 ( CR) = THEN ;\r
 463 \r
 464 FORTH-WORDLIST SET-CURRENT\r
 465 \r
 466 \   DUMP        ( addr u -- )                   \ TOOLS\r
 467 \               Display the contents of u consecutive address units starting\r
 468 \               at addr.\r
 469 \\r
 470 : DUMP  ?DUP\r
 471         IF   BASE @ >R HEX\r
 472              1- 16 / 1+\r
 473              0 DO CR DUP DUP 0 <# # # # # #> TYPE SPACE SPACE\r
 474                   16 0 DO DUP C@ 0 <# # # #> TYPE SPACE CHAR+ LOOP\r
 475                   SPACE SWAP\r
 476                   16 0 DO   DUP C@ 127 AND DUP 0 BL WITHIN\r
 477                             OVER 127 = OR\r
 478                             IF DROP [CHAR] . THEN\r
 479                             EMIT CHAR+\r
 480                        LOOP DROP\r
 481                   enough? IF LEAVE THEN\r
 482              LOOP\r
 483              R> BASE !\r
 484         THEN DROP ;\r
 485 \r
 486 NONSTANDARD-WORDLIST SET-CURRENT\r
 487 \r
 488 CHAR " PARSE model" ENVIRONMENT? DROP\r
 489 CHAR " PARSE EXE Model" COMPARE 0=\r
 490 [IF]\r
 491   \   xDUMP       ( code-addr u -- )\r
 492   \               Display the contents of u consecutive address units\r
 493   \               starting at the code addr.\r
 494   \\r
 495   : xDUMP ?DUP\r
 496           IF   BASE @ >R HEX\r
 497                1- 16 / 1+\r
 498                0 DO CR DUP 0 <# # # # # #> TYPE SPACE SPACE\r
 499                     8 0 DO DUP code@ 0 <# # # # # #> TYPE SPACE  CELL+ LOOP\r
 500                     enough? IF LEAVE THEN\r
 501                LOOP\r
 502                R> BASE !\r
 503           THEN DROP ;\r
 504 [THEN]\r
 505 \r
 506 \   xt>name     ( xt -- c-addr | 0 )\r
 507 \               Remove xt from the stack and return the name address if xt\r
 508 \               is execution token of valid word; otherwise return 0.\r
 509 CHAR " PARSE model" ENVIRONMENT? DROP\r
 510 CHAR " PARSE ROM Model" COMPARE 0=\r
 511 [IF]\r
 512   : xt>name\r
 513       DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN  \ xt should be aligned\r
 514       >R                        \ save xt\r
 515       FORTH-WORDLIST            \ Start of wordlist link\r
 516       BEGIN DUP @               \ last word name field of wordlist\r
 517             BEGIN DUP name>xt R@ XOR\r
 518             WHILE cell- @ ?DUP 0=\r
 519             UNTIL               \ continue until the end of wordlist\r
 520             ELSE  SWAP R> 2DROP EXIT    \ found\r
 521             THEN  CELL+ @ ?DUP 0=\r
 522       UNTIL                     \ continue to next wordlist\r
 523       R> DROP 0 ;               \ not found\r
 524 [THEN]\r
 525 CHAR " PARSE model" ENVIRONMENT? DROP\r
 526 CHAR " PARSE RAM Model" COMPARE 0=\r
 527 [IF]\r
 528   : xt>name\r
 529       DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN  \ xt should be aligned\r
 530       DUP cell- @               \ xt c-addr\r
 531       DUP ALIGNED OVER XOR IF 2DROP 0 EXIT THEN\r
 532       SWAP OVER name>xt = AND ;\r
 533 [THEN]\r
 534 CHAR " PARSE model" ENVIRONMENT? DROP\r
 535 CHAR " PARSE EXE Model" COMPARE 0=\r
 536 [IF]\r
 537   : xt>name\r
 538       DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN  \ xt should be aligned\r
 539       DUP cell- code@   \ xt c-addr\r
 540       DUP ALIGNED OVER XOR IF 2DROP 0 EXIT THEN\r
 541       SWAP OVER name>xt = AND ;\r
 542 [THEN]\r
 543 \r
 544 \   .xt         ( a-addr1 xt -- a-addr2 )\r
 545 \               Display name of a xt if xt is valid and display string\r
 546 \               constant and adjust a-addr1 to the end of string if xt is\r
 547 \               not POSTPONEd 'doS"' ; otherwise display the xt as a number.\r
 548 CHAR " PARSE model" ENVIRONMENT? DROP\r
 549 CHAR " PARSE ROM Model" COMPARE 0=\r
 550 CHAR " PARSE model" ENVIRONMENT? DROP\r
 551 CHAR " PARSE RAM Model" COMPARE 0= OR\r
 552 [IF]\r
 553   : .xt\r
 554       DUP\r
 555       IF DUP xt>name ?DUP\r
 556           IF .name DUP >R ['] doS" =\r
 557              IF DUP cell- @ ['] doLIT XOR\r
 558                 IF DUP CELL+ SWAP cell- @ 2DUP TYPE + ALIGNED\r
 559                    cell- [CHAR] " EMIT SPACE       THEN THEN\r
 560              R> DUP  ['] branch = OVER ['] 0branch = OR\r
 561                 OVER ['] doLOOP = OR SWAP ['] do+LOOP = OR\r
 562              IF DUP cell- @ ['] doLIT XOR\r
 563                 IF CELL+ DUP @ OVER CELL+ - .      THEN THEN\r
 564              EXIT\r
 565           THEN\r
 566       THEN U. ;\r
 567 [THEN]\r
 568 CHAR " PARSE model" ENVIRONMENT? DROP\r
 569 CHAR " PARSE EXE Model" COMPARE 0=\r
 570 [IF]\r
 571   : .xt\r
 572       DUP\r
 573       IF DUP xt>name ?DUP\r
 574           IF .name\r
 575              DUP  ['] branch = OVER ['] 0branch = OR\r
 576              OVER ['] doLOOP = OR SWAP ['] do+LOOP = OR\r
 577              IF DUP cell- code@ ['] doLIT XOR\r
 578                 IF CELL+ DUP code@ OVER CELL+ - .  THEN THEN\r
 579              EXIT\r
 580           THEN\r
 581       THEN U. ;\r
 582 [THEN]\r
 583 \r
 584 \   xtSEE       ( xt -- )\r
 585 \               Display human-readable representation of xt.\r
 586 CHAR " PARSE model" ENVIRONMENT? DROP\r
 587 CHAR " PARSE ROM Model" COMPARE 0=\r
 588 [IF]\r
 589   : xtSEE   >R lastName\r
 590             BEGIN  DUP COUNT 31 AND + ALIGNED CELL+ CELL+ \ na na'\r
 591                    DUP name>xt R@ U>\r
 592             WHILE  NIP\r
 593             REPEAT DROP name>xt R>\r
 594             2DUP U> 0= IF NIP xhere SWAP THEN   \ end-of-code xt\r
 595             CR BASE @ >R HEX\r
 596             BEGIN ?call ?DUP\r
 597                   IF ." call-" .xt THEN\r
 598                   DUP @ .xt enough? 0=\r
 599             WHILE CELL+ 2DUP U> 0=\r
 600             UNTIL THEN 2DROP  R> BASE ! ;\r
 601 [THEN]\r
 602 CHAR " PARSE model" ENVIRONMENT? DROP\r
 603 CHAR " PARSE RAM Model" COMPARE 0=\r
 604 [IF]\r
 605   \ Following definition is less dependent on dictionary structure although\r
 606   \ slower. It only assumes xt of a word is larger than xt of previously\r
 607   \ defined words. This works for ROM model also.\r
 608   : xtSEE   >R xhere >R           \ Search all wordlist to find end of xt.\r
 609             FORTH-WORDLIST        \ Find smallest link pointer larger than xt.\r
 610             BEGIN DUP\r
 611                   BEGIN @ ?DUP\r
 612                   WHILE DUP name>xt R@ U<\r
 613                         IF R> OVER name>xt R@ U>\r
 614                            IF DROP DUP name>xt THEN\r
 615                            >R\r
 616                         THEN\r
 617                         cell-\r
 618                   REPEAT\r
 619                   CELL+ @ ?DUP 0=               \ continue to next wordlist\r
 620             UNTIL R> R>                         \ end-of-code xt\r
 621             CR BASE @ >R HEX\r
 622             BEGIN ?call ?DUP\r
 623                   IF ." call-" .xt THEN\r
 624                   DUP @ .xt enough? 0=\r
 625             WHILE CELL+ 2DUP U> 0=\r
 626             UNTIL THEN 2DROP  R> BASE ! ;\r
 627 [THEN]\r
 628 CHAR " PARSE model" ENVIRONMENT? DROP\r
 629 CHAR " PARSE EXE Model" COMPARE 0=\r
 630 [IF]\r
 631   \ Following definition is less dependent on dictionary structure although\r
 632   \ slower. It only assumes xt of a word is larger than xt of previously\r
 633   \ defined words. This works for ROM model also.\r
 634   : xtSEE   >R xhere >R           \ Search all wordlist to find end of xt.\r
 635             FORTH-WORDLIST        \ Find smallest link pointer larger than xt.\r
 636             BEGIN DUP\r
 637                   BEGIN @ ?DUP\r
 638                   WHILE DUP name>xt R@ U<\r
 639                         IF R> OVER name>xt R@ U>\r
 640                            IF DROP DUP name>xt THEN\r
 641                            >R\r
 642                         THEN\r
 643                         cell-\r
 644                   REPEAT\r
 645                   CELL+ @ ?DUP 0=               \ continue to next wordlist\r
 646             UNTIL R> R>                         \ end-of-code xt\r
 647             CR BASE @ >R HEX\r
 648             BEGIN ?call ?DUP\r
 649                   IF ." call-" .xt THEN\r
 650                   DUP code@ .xt enough? 0=\r
 651             WHILE CELL+ 2DUP U> 0=\r
 652             UNTIL THEN 2DROP  R> BASE ! ;\r
 653 [THEN]\r
 654 \r
 655 FORTH-WORDLIST SET-CURRENT\r
 656 \r
 657 \   SEE         ( "<spaces>name" -- )           \ TOOLS\r
 658 \               Display human-readable representation of the name's definition.\r
 659 : SEE   (') 1+ IF ." IMMEDIATE-word" THEN  xtSEE ;\r
 660 \r
 661 NONSTANDARD-WORDLIST SET-CURRENT\r
 662 \r
 663 \   WORDLIST-WORDS    ( wid -- )\r
 664 \               List the definition names in wordlist identified by wid.\r
 665 : WORDLIST-WORDS\r
 666     CR 0 >R\r
 667     BEGIN @ ?DUP\r
 668     WHILE DUP .name  R> 1+ >R\r
 669           cell-                 \ pointer to next word\r
 670     enough? UNTIL\r
 671     THEN  SPACE R> . ." words " ;\r
 672 \r
 673 \   NONSTANDARD-WORDS   ( -- )\r
 674 \               List the definition names in NONSTANDARD-WORDLIST.\r
 675 : NONSTANDARD-WORDS   NONSTANDARD-WORDLIST WORDLIST-WORDS ;\r
 676 \r
 677 FORTH-WORDLIST SET-CURRENT\r
 678 \r
 679 \   WORDS       ( -- )                          \ TOOLS\r
 680 \               List the definition names in the first wordlist of the\r
 681 \               search order.\r
 682 : WORDS   #order CELL+ @ WORDLIST-WORDS ;\r
 683 \r
 684 envQList SET-CURRENT\r
 685 -1 CONSTANT TOOLS\r
 686 FORTH-WORDLIST SET-CURRENT\r
 687 \r
 688 \ **********************\r
 689 \ Nonstandard system utility word\r
 690 \ **********************\r
 691 \r
 692 NONSTANDARD-WORDLIST SET-CURRENT\r
 693 \r
 694 \   SAVE-SYSTEM   ( -- )\r
 695 \               Save current state of the system. There must be a way\r
 696 \               to preserve the memory image. Use non-volatile RAM or\r
 697 \               DEBUG.EXE to store the image in MS-DOS.\r
 698 \r
 699 CHAR " PARSE model" ENVIRONMENT? DROP\r
 700 CHAR " PARSE ROM Model" COMPARE 0=\r
 701 [IF]\r
 702   : SAVE-SYSTEM\r
 703       var0 sysVar0 [ sysVar0End sysVar0 - ] LITERAL MOVE ;\r
 704 [THEN]\r
 705 CHAR " PARSE model" ENVIRONMENT? DROP\r
 706 CHAR " PARSE RAM Model" COMPARE 0=\r
 707 [IF]\r
 708   : SAVE-SYSTEM\r
 709       #order DUP @ #order0 SWAP 1+ CELLS MOVE ;\r
 710 [THEN]\r
 711 \r
 712 CHAR " PARSE model" ENVIRONMENT? DROP\r
 713 CHAR " PARSE ROM Model" COMPARE 0=\r
 714 [IF]\r
 715 \r
 716   \ **********************\r
 717   \ RAM/ROM System Only\r
 718   \ **********************\r
 719 \r
 720   \   RAM         ( -- )\r
 721   \               Set data space in RAM area.\r
 722   : RAM   RAMB TO hereVar ;\r
 723 \r
 724   \   ROM         ( -- )\r
 725   \               Set data space in ROM area.\r
 726   : ROM   ROMB TO hereVar ;\r
 727 \r
 728   \   RAM/ROM@    ( -- ram/rom-id )\r
 729   \               Return RAM/ROM identifier which will be consumed by RAM/ROM!\r
 730   : RAM/ROM@   hereVar ;\r
 731 \r
 732   \ RAM/ROM!      ( ram/rom-id -- )\r
 733   \               Set HERE according to RAM/ROM identifier on the stack.\r
 734   : RAM/ROM!   TO hereVar ;\r
 735 [THEN]\r
 736 \r
 737 \   RETRY       ( -- )\r
 738 \               Compile unconditional jump to the start of the current\r
 739 \               definition. Described by Dr. Astle in Forth Dimensions\r
 740 \               17(4), 19-21 (1995).\r
 741 : RETRY   bal 1- 2* PICK 1+ IF -22 THROW THEN\r
 742                      \ control structure mismatch; colon-sys type is -1\r
 743           bal 1- 2* 1+ PICK       \ xt of current definition\r
 744           ?call DROP POSTPONE branch COMPILE, ; IMMEDIATE COMPILE-ONLY\r
 745 \r
 746 CHAR " PARSE model" ENVIRONMENT? DROP\r
 747 CHAR " PARSE EXE Model" COMPARE 0=\r
 748 [IF]\r
 749   DECIMAL\r
 750   \ Structure of CREATEd word:\r
 751   \   |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
 752   : doCompiles>\r
 753       lastName DUP C@ 128 ( =seman) <\r
 754       IF -12 THROW THEN         \ argument type mismatch\r
 755       name>xt cell- cell- code! ;\r
 756   \  compiles>  ( xt colon-sys -- colon-sys )\r
 757   \             Assign xt as special compilation action of the last CREATEd\r
 758   \             word. It is the user's responsibility to match the special\r
 759   \             compilation action and the execution action.\r
 760   \         Example: '2CONSTANT' can be defined as following:\r
 761   \         :NONAME   EXECUTE POSTPONE 2LITERAL ;\r
 762   \         : 2CONSTANT   CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
 763   : compiles>   ROT POSTPONE LITERAL POSTPONE doCompiles> ; IMMEDIATE\r
 764 [THEN]\r
 765 \r
 766 FORTH-WORDLIST SET-CURRENT\r
 767 \r
 768 BASE !\r
 769 \r
 770 CHAR " PARSE FILE" ENVIRONMENT?\r
 771 [IF]\r
 772   0= [IF] << CON [THEN]\r
 773 [ELSE] << CON\r
 774 [THEN]\r