msdos.f

   1 \\r
   2 \ MSDOS.F\r
   3 \ FILES and BLOCK words for MS-DOS\r
   4 \\r
   5 \ by Wonyong Koh\r
   6 \\r
   7 \ MSDOS.F can be loaded as below:\r
   8 \\r
   9 \       << OPTIONAL.F\r
  10 \       << ASM8086.F\r
  11 \       << COREEXT.F\r
  12 \       << MSDOS.F\r
  13 \\r
  14 \ Then other files such as MULTI.F, HIOMULTI.F, etc. can be loaded as below:\r
  15 \\r
  16 \       BL PARSE MULTI.F    INCLUDED\r
  17 \       BL PARSE HIOMULTI.F INCLUDED\r
  18 \\r
  19 \ In HF86EXE.EXE system image can be saved using SYSTEM-SAVED\r
  20 \ or SAVE-SYSTEM-AS as below:\r
  21 \\r
  22 \       SAVE-SYSTEM-AS SAVE2.EXE\r
  23 \\r
  24 \ Don't forget to set up "'init-i/o" and "'boot" properly.\r
  25 \\r
  26 \ There is only one block buffer and only one file is assigned as BLOCK\r
  27 \ in current implementation.\r
  28 \\r
  29 \ 1996. 3. 1.\r
  30 \       DOS error code is offsetted by -512 to give 'ior'.\r
  31 \ 1997. 5. 26.\r
  32 \               Fix RESTORE-INPUT to restore BLK correctly.\r
  33 \r
  34 CHAR " PARSE CPU" ENVIRONMENT? DROP\r
  35 CHAR " PARSE 8086" COMPARE\r
  36 [IF]\r
  37     CR .( BLOCK and FILE words for MS-DOS are for 8086 RAM and EXE models only.)\r
  38     ABORT\r
  39 [THEN]\r
  40 \r
  41 CHAR " PARSE model" ENVIRONMENT? DROP\r
  42 CHAR " PARSE RAM Model" COMPARE\r
  43 CHAR " PARSE model" ENVIRONMENT? DROP\r
  44 CHAR " PARSE EXE Model" COMPARE AND\r
  45 [IF]\r
  46     CR .( BLOCK and FILE words for MS-DOS are for 8086 RAM and EXE models only.)\r
  47     ABORT\r
  48 [THEN]\r
  49 \r
  50 BASE @\r
  51 GET-ORDER  GET-CURRENT\r
  52 \r
  53 FORTH-WORDLIST SET-CURRENT\r
  54 WORDLIST WORDLIST-NAME DOS-WORDLIST\r
  55 DOS-WORDLIST SET-CURRENT\r
  56 GET-ORDER DOS-WORDLIST SWAP 1+ SET-ORDER\r
  57 \r
  58 DECIMAL\r
  59 -512 CONSTANT iorOffset\r
  60 VARIABLE MaxHandle      \ contains maximum DOS file handle\r
  61 0 MaxHandle !           \ to be used to calculate UNUSED data space.\r
  62 \r
  63 1024 CHARS CONSTANT 1K\r
  64 0 VALUE updated                 \ true if block is updated\r
  65 CREATE block-buffer 1K ALLOT    \ the only block buffer\r
  66 50 VALUE def#blocks             \ default # of blocks for a new mapped file\r
  67 -1 VALUE block-fid              \ BLOCK file id\r
  68 -1 VALUE current-block#\r
  69 NONSTANDARD-WORDLIST SET-CURRENT\r
  70 50 VALUE #blocks                \ maximum # of blocks\r
  71 DOS-WORDLIST SET-CURRENT\r
  72 \r
  73 VARIABLE error-class         0 error-class !\r
  74 VARIABLE recommanded-action  0 recommanded-action !\r
  75 VARIABLE error-locus         0 error-locus !\r
  76 \r
  77 : ?dupR>DropExit       ?DUP IF R> R> 2DROP EXIT THEN ;\r
  78 : ?dupR>Drop2NipExit   ?DUP IF R> R> 2DROP NIP NIP EXIT THEN ;\r
  79 : ?dupR>Drop4NipExit   ?DUP IF R> R> 2DROP NIP NIP NIP NIP EXIT THEN ;\r
  80 \r
  81 HEX\r
  82 CODE get-ior  ( -- ior )\r
  83     59 # AH MOV,\r
  84     BX BX XOR,\r
  85     21 INT,\r
  86     BH error-class ) MOV,\r
  87     BL recommanded-action ) MOV,\r
  88     CH error-locus ) MOV,\r
  89     AX BX MOV,\r
  90     iorOffset # BX ADD,\r
  91     NEXT,\r
  92 END-CODE\r
  93 \r
  94 CODE (open-file)  ( asciiz fam -- fileid ior )\r
  95     3D # AH MOV,\r
  96     BL AL MOV,\r
  97     DX POP,\r
  98     21 INT,\r
  99     AX PUSH,\r
 100     1 L# JC,\r
 101     BX BX XOR,\r
 102     NEXT,\r
 103 1 L:\r
 104     ' get-ior # JMP,\r
 105 END-CODE\r
 106 \r
 107 CODE (create-file)  ( asciiz -- fileid ior )\r
 108     3C # AH MOV,\r
 109     CX CX XOR,          \ CX = 0 ; normal read/write\r
 110     BX DX MOV,\r
 111     21 INT,\r
 112     AX PUSH,\r
 113     1 L# JC,\r
 114     BX BX XOR,\r
 115     NEXT,\r
 116 1 L:\r
 117     ' get-ior # JMP,\r
 118 END-CODE\r
 119 \r
 120 CODE (delete-file)  ( asciiz -- ior )\r
 121     41 # AH MOV,\r
 122     BX DX MOV,\r
 123     21 INT,\r
 124     1 L# JC,\r
 125     BX BX XOR,\r
 126     NEXT,\r
 127 1 L:\r
 128     ' get-ior # JMP,\r
 129 END-CODE\r
 130 \r
 131 CODE (reposition-file)  ( ud fileid reposition_method -- ud ior )\r
 132     \ reposition_method;\r
 133     \   0 : offset from beginning of file\r
 134     \   1 : offset from present location\r
 135     \   2 : offset from end-of-file\r
 136     42 # AH MOV,\r
 137     BL AL MOV,          \ AL = reposition-method\r
 138     BX POP,             \ file handle\r
 139     CX POP,             \ CX:DX = offset\r
 140     DX POP,\r
 141     21 INT,\r
 142     AX PUSH,\r
 143     DX PUSH,\r
 144     1 L# JC,\r
 145     BX BX XOR,\r
 146     NEXT,\r
 147 1 L:\r
 148     ' get-ior # JMP,\r
 149 END-CODE\r
 150 \r
 151 CODE crlf=  ( char -- flag )\r
 152     BX AX MOV,\r
 153     -1 # BX MOV,\r
 154     0A # AL CMP,\r
 155     1 L# JZ,\r
 156     0D # AL CMP,\r
 157     1 L# JZ,\r
 158     BX INC,\r
 159 1 L:\r
 160     NEXT,\r
 161 END-CODE\r
 162 \r
 163 \ PAD is constant in EXE model.\r
 164 PAD BL PARSE /PAD ENVIRONMENT? DROP CHARS - CONSTANT S"buffer\r
 165 \r
 166 \               Returns file input buffer address\r
 167 \               Each text file has its own input buffer\r
 168 \                 below buffer for S" below PAD.\r
 169 \               In MS-DOS, a program can open up to 20 files.\r
 170 \                 Thus fileid(=DOS handle) is normally 5 to 20.\r
 171 \               DOS handle 0 : standard input (CON)\r
 172 \                          1 : standard output (CON)\r
 173 \                          2 : standard output for error message (CON)\r
 174 \                          3 : standard serial interface (AUX)\r
 175 \                          4 : standard printer (PRN)\r
 176 \               <-/fileid6buffer/fileid5buffer/S"buffer/PAD/TIB||memTop\r
 177 : input-buffer  ( -- c_addr )\r
 178     SOURCE-ID\r
 179     ?DUP IF 1+ ?DUP IF \ source-id = fileid, text file source\r
 180                 5 - [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
 181                 * S"buffer SWAP - EXIT THEN THEN\r
 182     \ source-id = 0, user input device source\r
 183     \ source-id = -1, string source\r
 184     SOURCE DROP ;\r
 185 \r
 186 FORTH-WORDLIST SET-CURRENT\r
 187 \   UNUSED      ( -- u )                                \ CORE EXT\r
 188 \               Return available data space in address units.\r
 189 : UNUSED\r
 190     S"buffer\r
 191     MaxHandle @ 5 - [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL * -\r
 192     HERE - ;    \ Available data space is HERE to assigned buffer addr\r
 193 DOS-WORDLIST SET-CURRENT\r
 194 \r
 195 CODE (file-status)  ( asciiz -- x ior )\r
 196     4300 # AX MOV,      \ get file attributes\r
 197     BX DX MOV,\r
 198     21 INT,\r
 199     CX PUSH,\r
 200     1 L# JC,\r
 201     BX BX XOR,\r
 202     NEXT,\r
 203 1 L:\r
 204     ' get-ior # JMP,\r
 205 END-CODE\r
 206 \r
 207 CODE (rename-file)  ( asciiz1 asciiz2 -- ior )\r
 208     56 # AH MOV,\r
 209     BX DX MOV,\r
 210     DS PUSH,\r
 211     ES POP,\r
 212     DI POP,\r
 213     21 INT,\r
 214     1 L# JC,\r
 215     BX BX XOR,\r
 216     NEXT,\r
 217 1 L:\r
 218     ' get-ior # JMP,\r
 219 END-CODE\r
 220 \r
 221 FORTH-WORDLIST SET-CURRENT\r
 222 \r
 223 \   BLK         ( -- a_addr )                           \ BLOCK\r
 224 \               a_addr is the address of a cell containing 0 or the\r
 225 \               mass-strorage block being interpreted. If BLK is 0, the input\r
 226 \               source is not a block and can be identified by SOURCE-ID .\r
 227 VARIABLE BLK  0 BLK !\r
 228 \r
 229 \   BIN         ( fam1 -- fam2 )                        \ FILE\r
 230 \               Modify file access method to binary.\r
 231 : BIN ;         \ Do nothing for MS-DOS handle functions.\r
 232 \r
 233 \   CLOSE-FILE  ( fileid -- ior )                       \ FILE\r
 234 \               Close the file identified by fileid.\r
 235 CODE CLOSE-FILE\r
 236     3E # AH MOV,        \ BX = file handle\r
 237     21 INT,\r
 238     1 L# JC,\r
 239     BX BX XOR,\r
 240     NEXT,\r
 241 1 L:\r
 242     ' get-ior # JMP,\r
 243 END-CODE\r
 244 \r
 245 \   OPEN-FILE   ( c_addr u fam -- fileid ior )          \ FILE\r
 246 \               Open a file with the name and file access method.\r
 247 : OPEN-FILE\r
 248     >R asciiz R> (open-file)\r
 249     DUP 0= IF OVER MaxHandle @ MAX MaxHandle ! THEN ;\r
 250 \r
 251 \   CREATE-FILE ( c_addr u fam -- fileid ior )          \ FILE\r
 252 \               Create a file with the given name and the file access\r
 253 \               method and return fileid.\r
 254 : CREATE-FILE\r
 255     >R  2DUP                    \ ca u ca u       R: fam\r
 256     asciiz (create-file)        \ ca u fileid ior R: fam\r
 257     ?dupR>Drop2NipExit\r
 258     CLOSE-FILE DROP  R> OPEN-FILE ;\r
 259 \r
 260 \   DELETE-FILE ( c_addr u -- ior )                     \ FILE\r
 261 \               Delete the named file.\r
 262 : DELETE-FILE\r
 263     asciiz (delete-file) ;\r
 264 \r
 265 \   FILE-POSITION ( fileid -- ud ior )                  \ FILE\r
 266 \               ud is the current file position for fileid.\r
 267 : FILE-POSITION\r
 268     >R 0 0 R> 1 (reposition-file) ;\r
 269 \r
 270 \   REPOSITION-FILE ( ud fileid -- ior )                \ FILE\r
 271 \               Reposition the file to ud.\r
 272 : REPOSITION-FILE\r
 273     0 (reposition-file) NIP NIP ;\r
 274 \r
 275 \   FILE-SIZE   ( fileid -- ud ior )                    \ FILE\r
 276 \               ud is the size of of fileid in characters.\r
 277 : FILE-SIZE\r
 278     DUP >R                      \ fid  R: fid\r
 279     FILE-POSITION               \ ud ior  R: fid\r
 280     ?dupR>DropExit                      \ save current position\r
 281     0 0 R@ REPOSITION-FILE      \ ud ior  R: fid\r
 282     ?dupR>DropExit                      \ reset file position\r
 283     0 0 R@ 2 (reposition-file)  \ ud ud' ior  R: fid\r
 284     ?dupR>Drop2NipExit                  \ size = distance from end of file\r
 285     2SWAP R> REPOSITION-FILE ;\r
 286 \r
 287 \   R/O         ( -- fam )                              \ FILE\r
 288 \               Put read-only method value on the stack.\r
 289 0 CONSTANT R/O\r
 290 \r
 291 \   W/O         ( -- fam )                              \ FILE\r
 292 \               Put write-only method value on the stack.\r
 293 1 CONSTANT W/O\r
 294 \r
 295 \   R/W         ( -- fam )                              \ FILE\r
 296 \               Put read/write method value on the stack.\r
 297 2 CONSTANT R/W\r
 298 \r
 299 \   READ-FILE   ( c_addr u1 fileid -- u2 ior )          \ FILE\r
 300 \               Read u1 consecutive characters to c_addr from the current\r
 301 \               position of the file.\r
 302 \               Results:\r
 303 \                   u2=u1, ior=0  \ read with no exception\r
 304 \                   u2<u1, ior=0  \ end-of-file\r
 305 \                   u2=0,  ior=0  \ FILE-POSITION equals FILE-SIZE\r
 306 \                   u2>=0, ior<>0 \ u2 is # chars read until exception occurs\r
 307 CODE READ-FILE\r
 308     3F # AH MOV,\r
 309     CX POP,\r
 310     DX POP,\r
 311     21 INT,\r
 312     AX PUSH,\r
 313     1 L# JC,\r
 314     BX BX XOR,\r
 315     NEXT,\r
 316 1 L:\r
 317     ' get-ior # JMP,\r
 318 END-CODE\r
 319 \r
 320 \   READ-LINE   ( c_addr u1 fileid -- u2 flag ior )     \ FILE\r
 321 \               Read the next line from the file.\r
 322 \               Results:\r
 323 \                   x x nonzero \ Something bad and unexpected happened                   l\r
 324 \                   0 false 0   \ End-of-file; no characters were read\r
 325 \                   0 true  0   \ A blank line was read\r
 326 \              0<u2<u1 true 0   \ The entire line was read\r
 327 \                   u1 true 0   \ A partial line was read; the rest would\r
 328 \                               \ not fit in the buffer, and can be acquired\r
 329 \                               \ by additional calls to READ-LINE.\r
 330 : READ-LINE\r
 331     >R OVER SWAP R@             \ ca ca u1 fid  R: fid\r
 332     READ-FILE                   \ ca u2 ior     R: fid\r
 333     ?dupR>DropExit                              \ exit on error\r
 334     DUP 0= IF NIP DUP DUP R> DROP EXIT THEN     \ 0 false 0, end-of-file\r
 335     DUP >R OVER + OVER          \ ca ca+u2 ca  R: fid u2\r
 336     DO   I C@                   \ ca char  R: fid u2 loop_index\r
 337          DUP 09 ( TAB ) = IF BL I C! THEN\r
 338          DUP 1A ( ctrl-Z ) = IF\r
 339             DROP I UNLOOP R> DROP\r
 340             SWAP -              \ ca'-ca (# chars before ctrl-Z)  R: fid\r
 341             DUP 0= 0=           \ u -1|0  R: fid\r
 342             R@ FILE-SIZE        \ u -1|0 ud ior  R: fid\r
 343             ?dupR>Drop2NipExit\r
 344             R> REPOSITION-FILE EXIT\r
 345          THEN\r
 346          crlf= IF I UNLOOP     \ ca ca'  R: fid u1\r
 347             TUCK CHAR+ DUP C@ crlf=\r
 348             IF CHAR+ THEN       \ ca' ca ca'+1|2  R: fid u1\r
 349             OVER -              \ ca' ca line_length  R: fid u1\r
 350             R> -                \ ca' ca #chars_to_roll_back  R: fid\r
 351             S>D R> 1 (reposition-file)  \ ca' ca ud ior\r
 352             DROP 2DROP          \ ca' ca ; adjust file position\r
 353             - TRUE 0 EXIT\r
 354          THEN\r
 355     LOOP                        \ ca  R: fid u2\r
 356     DROP R> TRUE 0 R> DROP ;    \ line terminator not found, partial lile read\r
 357 \r
 358 \   S"          Interpretation: ( 'ccc<">' -- c_addr u )        \ FILE\r
 359 \               Compilation:    ( 'ccc<">' -- )\r
 360 \               Run-time:       ( -- c_addr u )\r
 361 CHAR " PARSE model" ENVIRONMENT? DROP\r
 362 CHAR " PARSE RAM Model" COMPARE 0=\r
 363 [IF]\r
 364   : S"\r
 365       STATE @ IF POSTPONE S" EXIT THEN          \ CORE word S"\r
 366       S"buffer DUP [CHAR] " PARSE DUP >R        \ S"buf S"buf c_addr u  R: u\r
 367       ROT SWAP CHARS MOVE R>\r
 368       ; IMMEDIATE\r
 369 [THEN]\r
 370 \ Define non-IMMEDIATE S" using special compilation action mechanism\r
 371 \ Structure of words with special compilation action, CREATEd words and S",\r
 372 \ for default compilation behavior\r
 373 \       |compile_xt|name_ptr| execution_code |\r
 374 \ Structure of dictionary in data segment\r
 375 \       | xt | link | name |\r
 376 CHAR " PARSE model" ENVIRONMENT? DROP\r
 377 CHAR " PARSE EXE Model" COMPARE 0=\r
 378 [IF]\r
 379   :NONAME\r
 380       DROP              \ drop execution xt left for special compilation action\r
 381       POSTPONE S" ;\r
 382   code,                         \ store compilation xt\r
 383   ' S" xt>name DUP code,        \ store name pointer\r
 384   :NONAME\r
 385       [CHAR] " PARSE DUP >R     \ c_addr u  R: u\r
 386       CHARS S"buffer SWAP MOVE\r
 387       S"buffer R> ;\r
 388   SWAP                          \ execution_S"_xt S"_name_addr\r
 389   DUP C@                        \ get flags\r
 390   60 INVERT AND                 \ clear IMMEDIATE and COMPILE-ONLY flags\r
 391   80 OR                         \ set special compilation action flag\r
 392   OVER C!                       \ store flags\r
 393   cell- cell- !                 \ store new execution xt\r
 394 [THEN]\r
 395 \r
 396 \   SOURCE-ID   ( -- 0|-1|fileid )                      \ FILE\r
 397 \               Returns input source identifier: 0 for user input device,\r
 398 \               -1 for string (via EVALUATE), and fileid for text file.\r
 399 \\r
 400 \ INCLUDE-FILE and INCLUDED set SOURCE-ID to proper values.\r
 401 \r
 402 \   WRITE-FILE  ( c_addr u fileid -- ior )              \ FILE\r
 403 \               Write u characters from c_addr u to the file.\r
 404 HEX\r
 405 CODE WRITE-FILE\r
 406     40 # AH MOV,\r
 407     CX POP,\r
 408     DX POP,\r
 409     21 INT,\r
 410     1 L# JC,\r
 411     BX BX XOR,\r
 412     NEXT,\r
 413 1 L:\r
 414     ' get-ior # JMP,\r
 415 END-CODE\r
 416 \r
 417 CREATE cr-lf 0D C, 0A C, ALIGN\r
 418 \r
 419 \   WRITE-LINE  ( c_addr u fileid -- ior )              \ FILE\r
 420 \               Write u characters from c_addr followed by line terminator\r
 421 \               to the file.\r
 422 : WRITE-LINE\r
 423     DUP >R WRITE-FILE           \ ior  R: fid\r
 424     ?dupR>DropExit\r
 425     cr-lf 2 R> WRITE-FILE ;\r
 426 \r
 427 \   RESIZE-FILE ( ud fileid -- ior )                    \ FILE\r
 428 \               Set the size of the file to ud.\r
 429 : RESIZE-FILE\r
 430     DUP >R                      \ ud1 fid  R: fid\r
 431     FILE-SIZE                   \ ud1 ud2 ior  R: fid\r
 432     ?dupR>Drop4NipExit\r
 433     2OVER DNEGATE D+            \ ud1 ud2-ud1  R: fid\r
 434     NIP 0<      \ file_size < ud ?\r
 435     IF R@ FILE-SIZE             \ ud1 ud3 ior  R: fid\r
 436        ?dupR>Drop4NipExit\r
 437        2DUP R@ REPOSITION-FILE  \ ud1 ud3 ior  R: fid\r
 438        ?dupR>Drop4NipExit\r
 439        DNEGATE D+               \ ud1-ud3  R: fid\r
 440        BEGIN                    \ u_low u_high  R: fid\r
 441           ?DUP WHILE\r
 442              0 8000 R@ WRITE-FILE       \ u1 u2 ior  R: fid\r
 443              ?dupR>Drop2NipExit\r
 444              0 8000 R@ WRITE-FILE       \ u1 u2 ior  R: fid\r
 445              ?dupR>Drop2NipExit\r
 446              1-                         \ u1 u2-1  R: fid\r
 447           REPEAT                        \ u1  R: fid\r
 448        0 SWAP R> WRITE-FILE EXIT\r
 449     THEN                        \ ud1  R: fid\r
 450     R@ REPOSITION-FILE          \ ior  R: fid\r
 451     ?dupR>DropExit\r
 452     0 0 R> WRITE-FILE ;         \ writing 0 byte truncates the file in MS-DOS.\r
 453 \r
 454 \   FILE-STATUS ( c_addr u -- x ior )                   \ FILE EXT\r
 455 \               Return the status of the named file. If the file exists,\r
 456 \               ior is 0. x contains implementation-defined information\r
 457 \               about the file.\r
 458 : FILE-STATUS\r
 459     asciiz (file-status) ;\r
 460 \r
 461 \   FLUSH-FILE  ( fileid -- ior )                       \ FILE EXT\r
 462 \               Attempt to force any buffered information written to the file\r
 463 \               and update the directory.\r
 464 CODE FLUSH-FILE\r
 465     45 # AH MOV,\r
 466     21 INT,\r
 467     1 L# JC,\r
 468     AX BX MOV,\r
 469     3E # AH MOV,\r
 470     21 INT,\r
 471     1 L# JC,\r
 472     BX BX XOR,\r
 473     NEXT,\r
 474 1 L:\r
 475     ' get-ior # JMP,\r
 476 END-CODE\r
 477 \r
 478 \   RENAME-FILE ( c_addr1 u1 c_addr2 u2 -- ior )        \ FILE\r
 479 \               Rename the file named bye c_addr1 u1 to the name c_addr2 u2.\r
 480 : RENAME-FILE\r
 481     \ another asciiz buffer after PAD\r
 482     PAD [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL +\r
 483     DUP >R  SWAP 2DUP + 0 SWAP C! CHARS MOVE\r
 484     asciiz R>  (rename-file) ;\r
 485 \r
 486 \   SAVE-BUFFERS ( -- )                                 \ BLOCK\r
 487 \               Transfer the contents of each UPDATEd block buffer to mass\r
 488 \               storage. Mark all buffers as unmodified.\r
 489 : SAVE-BUFFERS\r
 490     updated IF\r
 491       current-block# 1K UM* block-fid REPOSITION-FILE THROW\r
 492       block-buffer 1K  block-fid WRITE-FILE THROW\r
 493       block-fid FLUSH-FILE THROW\r
 494       0 TO updated\r
 495     THEN ;\r
 496 \r
 497 \   BUFFER      ( u -- a_addr )                         \ BLOCK\r
 498 \               a_addr is the address of the first character of the block\r
 499 \               buffer assigned to block u. The contents of the block are\r
 500 \               unspecified.\r
 501 \               If block u is already in a block buffer, a_addr is the address\r
 502 \                   of that block buffer.\r
 503 \               If block u is not already in memory and there is an unassigned\r
 504 \                   block buffer, a_addr is the address of that block buffer.\r
 505 \               If block u is not already in memory and there are no\r
 506 \                   unassigned block buffer, unassign a block. If the block\r
 507 \                   in that buffer has been UPDATEd, transfer the block to\r
 508 \                   mass storage. a_addr is the address of that block buffer.\r
 509 \               At the conclusion of the operateion, the block buffer pointed\r
 510 \                   to by a_addr is the current block buffer and is assigned\r
 511 \                   to u.\r
 512 : BUFFER\r
 513     SAVE-BUFFERS\r
 514     TO current-block#  block-buffer ;\r
 515 \r
 516 DECIMAL\r
 517 \   BLOCK       ( u -- a_addr )                         \ BLOCK\r
 518 \               a_addr is the address of the first character of the block\r
 519 \               buffer assigned to mass-storage block u.\r
 520 \               If block u is already in a block buffer, a_addr is the address\r
 521 \                   of the block.\r
 522 \               If block u is not already in memory and there is an unassigned\r
 523 \                   block buffer, transfer block u from mass storage to an\r
 524 \                   unassigned block buffer. a_addr is the address of that\r
 525 \                   block buffer.\r
 526 \               If block u is not already in memory and there are no\r
 527 \                   unassigned block buffer, unassign a block. If the block\r
 528 \                   in that buffer has been UPDATEd, transfer the block to\r
 529 \                   mass storage and transfer block u from mass storage into\r
 530 \                   that buffer. a_addr is the address of that block buffer.\r
 531 \               At the conclusion of the operateion, the block buffer pointed\r
 532 \                   to by a_addr is the current block buffer and is assigned\r
 533 \                   to u.\r
 534 : BLOCK\r
 535     DUP current-block# = IF DROP block-buffer EXIT THEN\r
 536     DUP BUFFER DROP\r
 537     1K UM* block-fid REPOSITION-FILE THROW\r
 538     block-buffer 1K block-fid READ-FILE THROW\r
 539        1K = 0= IF ." Unexpected end of BLOCK file."\r
 540                   -33 THROW  THEN       \ block read exception\r
 541     block-buffer ;\r
 542 \r
 543 \   SAVE-INPUT  ( -- xn ... x1 n )                      \ CORE EXT\r
 544 \               Implementated as ( -- c_addr u >in source_id blk@ 5 )\r
 545 \               x1 through xn describe the current state of the input source\r
 546 \               specification for later use by RESTORE-INPUT .\r
 547 : SAVE-INPUT\r
 548     SOURCE  >IN @  SOURCE-ID  BLK @  5 ;\r
 549 \r
 550 \   RESTORE-INPUT ( xn ... x1 n -- flag )               \ CORE EXT\r
 551 \               Attempt to restore the input specification to the state\r
 552 \               described by x1 through xn. flag is true if the input\r
 553 \               source specification cannot be so restored.\r
 554 : RESTORE-INPUT\r
 555     DUP 5 = IF DROP  DUP IF BLOCK THEN\r
 556                BLK ! TO SOURCE-ID >IN ! sourceVar 2!\r
 557                FALSE EXIT\r
 558     THEN  0 DO DROP LOOP  TRUE ;\r
 559 \r
 560 \   EMPTY-BUFFERS ( -- )                                \ BLOCK EXT\r
 561 \               Unassign all block buffers. Do not transfer the contents of\r
 562 \               any UPDATEd block buffer to mass storage.\r
 563 : EMPTY-BUFFERS\r
 564     -1 TO current-block#\r
 565     0 TO updated ;\r
 566 \r
 567 \   EVALUATE    ( i*x c-addr u -- j*x )                 \ CORE, BLOCK\r
 568 \               Evaluate the string. Save the input source specification.\r
 569 \               Store -1 in SOURCE-ID. Store 0 in BLK.\r
 570 : EVALUATE   0 BLK !  EVALUATE ;\r
 571 \r
 572 \   FLUSH       ( -- )                                  \ BLOCK\r
 573 \               Perform the function of SAVE-BUFFERS, then unassign all block\r
 574 \               buffers.\r
 575 : FLUSH     SAVE-BUFFERS EMPTY-BUFFERS ;\r
 576 \r
 577 \   LOAD        ( i*x u -- j*x )                        \ BLOCK\r
 578 \               Save the current input-source specification. Store u in BLK\r
 579 \               (thus making block u the input source and setting the input\r
 580 \               source buffer to encompass its contents), set >IN to 0, and\r
 581 \               interpret. When the parse area is exhausted, restore the\r
 582 \               prior input source specification. Other stack effects are due\r
 583 \               to the words LOADed.\r
 584 : LOAD\r
 585     SAVE-INPUT\r
 586     DUP BEGIN ?DUP WHILE 1- ROT >R REPEAT  >R\r
 587     DUP BLK !  BLOCK 1K\r
 588     sourceVar 2!  0 >IN !\r
 589     interpret\r
 590     R> DUP BEGIN ?DUP WHILE 1- R> ROT ROT REPEAT\r
 591     RESTORE-INPUT\r
 592     IF ." Input source specification was not properly restored."\r
 593         -37 THROW       \ file I/O exception\r
 594     THEN ;\r
 595 \r
 596 \   SOURCE      ( -- c_addr u )                         \ CORE\r
 597 \\r
 598 : SOURCE\r
 599     BLK @ ?DUP IF BLOCK 1K EXIT THEN\r
 600     SOURCE ;                            \ old SOURCE\r
 601 \r
 602 \   UPDATE      ( -- )                                  \ BLOCK\r
 603 \               Mark the current block buffer as modified.\r
 604 : UPDATE\r
 605     current-block# -1 = IF\r
 606         ." There is no current block buffer."\r
 607         -35 THROW  THEN         \ invalid block number\r
 608     TRUE TO updated ;\r
 609 \r
 610 \   SCR         ( -- a_addr )                           \ BLOCK EXT\r
 611 \               a_addr is the address of a cell containing the block number\r
 612 \               of the block most recently LISTed.\r
 613 VARIABLE SCR  0 SCR !\r
 614 \r
 615 \   LIST        ( u -- )                                \ BLOCK EXT\r
 616 \               Display block u in an implementation-defined format.\r
 617 \               Store u in SCR.\r
 618 DECIMAL\r
 619 : LIST\r
 620     DUP SCR !  BLOCK  BASE @ DECIMAL SWAP\r
 621     16 0 DO  CR I 2 .R SPACE\r
 622              64  2DUP TYPE + LOOP  CR DROP\r
 623     BASE ! ;\r
 624 \r
 625 \   THRU        ( i*x u1 u2 -- j*x )                    \ BLOCK EXT\r
 626 \               LOAD the mass storage blocks numbered u1 through u2 in\r
 627 \               sequence. Other stack effects are due to the words LOADed.\r
 628 : THRU\r
 629     1+ SWAP DO I LOAD LOOP ;\r
 630 \r
 631 \   INCLUDE-FILE ( i*x fileid -- j*x )                  \ FILE\r
 632 \               Remove fileid, save the current input source specification\r
 633 \               including current value of SOURCE-ID. Store fileid in\r
 634 \               SOURCE-ID . Make the file specified by fileid the input\r
 635 \               source. Store 0 in BLK . Repeat read a line, fill the input\r
 636 \               buffer, set >IN 0 and interpret until the end of the file.\r
 637 \\r
 638 \               Each text file has its own input buffer below PAD.\r
 639 \               In MS-DOS, fileid is normally 5 to 20.\r
 640 DECIMAL\r
 641 : INCLUDE-FILE\r
 642     SAVE-INPUT\r
 643     DUP BEGIN ?DUP WHILE 1- ROT >R REPEAT  >R\r
 644     TO SOURCE-ID  input-buffer >R\r
 645     BEGIN\r
 646        R@ DUP [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
 647        SOURCE-ID                \ ca ca u1 fileid\r
 648        READ-LINE                \ ca u2 flag ior\r
 649        THROW\r
 650     WHILE\r
 651        sourceVar 2!  0 >IN !\r
 652        interpret\r
 653     REPEAT 2DROP  R> DROP\r
 654     R> DUP BEGIN ?DUP WHILE 1- R> ROT ROT REPEAT\r
 655     RESTORE-INPUT\r
 656     IF ." Input source specification was not properly restored."\r
 657         -37 THROW       \ file I/O exception\r
 658     THEN ;\r
 659 \r
 660 \   INCLUDED    ( i*x c_addr u -- j*x )                 \ FILE\r
 661 \               Open the named file and do INCLUDE-FILE .\r
 662 : INCLUDED\r
 663     R/O OPEN-FILE THROW\r
 664     DUP >R INCLUDE-FILE\r
 665     R> CLOSE-FILE THROW ;\r
 666 \r
 667 NONSTANDARD-WORDLIST SET-CURRENT\r
 668 \r
 669 \ for convenience, not to use in Standard program\r
 670 : INCLUDE  ( i*x 'filename<space>' -- j*x )\r
 671     BL PARSE INCLUDED ;\r
 672 \r
 673 FORTH-WORDLIST SET-CURRENT\r
 674 \r
 675 \   REFILL      ( -- flag )                     \ CORE EXT, BLOCK EXT, FILE EXT\r
 676 \               Extend the execution semantics of REFILL for block and file\r
 677 \               input.\r
 678 \               When the input source is a block, make the next block the input\r
 679 \                   source and current input buffer by adding one to the value\r
 680 \                   of BLK and setting >IN to 0. Return true if the new value\r
 681 \                   of BLK is a valid block number, otherwise false.\r
 682 \               On file input attempt to read the next line from the text-input file.\r
 683 \                   If sucessful, make the result the current input buffer, set\r
 684 \                   >IN to 0, and return true.\r
 685 : REFILL\r
 686     BLK @ IF 1+ DUP BLK ! BLOCK block-buffer 1K sourceVar 2!  0 >IN ! TRUE\r
 687              EXIT THEN\r
 688     SOURCE-ID -1 = IF 0 EXIT THEN\r
 689     SOURCE-ID 0= IF REFILL EXIT THEN    \ old REFILL\r
 690     input-buffer\r
 691     DUP [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
 692     SOURCE-ID                \ ca ca u1 fileid\r
 693     READ-LINE                \ ca u2 flag ior\r
 694     IF 2DROP DROP FALSE EXIT THEN\r
 695     IF sourceVar 2!  0 >IN ! TRUE EXIT THEN\r
 696     2DROP FALSE ;\r
 697 \r
 698 \   \           ( 'ccc<eol>' -- )                       \ CORE EXT, BLOCK EXT\r
 699 \               Extend the semantics of '\' for block.\r
 700 \               If BLK contains 0, parse and discard the remainder of the parse\r
 701 \                   area; otherwise parse and discard the portion of the parse\r
 702 \                   area corresponding to the remainder of the current line.\r
 703 DECIMAL\r
 704 : \   BLK @ IF  >IN @ 63 + -64 AND\r
 705       ELSE  SOURCE NIP\r
 706       THEN  >IN !  ; IMMEDIATE\r
 707 \r
 708 \   (           ( 'ccc<)>' -- )                         \ CORE, FILE\r
 709 \               Extend the semantics of '(' for file.\r
 710 \               Skip until ')' or end-of-file.\r
 711 : (\r
 712     BEGIN\r
 713        [CHAR] ) PARSE 2DROP\r
 714        SOURCE NIP >IN @ XOR IF EXIT THEN \ ')' is if source is not fully parsed\r
 715        SOURCE 1- CHARS + C@ [CHAR] ) = IF EXIT THEN\r
 716        REFILL 0=\r
 717     UNTIL ; IMMEDIATE\r
 718 \r
 719 \   [ELSE]      ( *<spaces>name...* - )         \ TOOLS EXT\r
 720 \               Skipping leading spaces, parse and discard words from the\r
 721 \               parse area, including nested [IF] ... [THEN] and [IF] ...\r
 722 \               [ELSE] ... [THEN], until the word [THEN] has been parsed\r
 723 \               and discared.\r
 724 : [ELSE]  ( -- )\r
 725    1 BEGIN                                      \ level\r
 726      BEGIN  PARSE-WORD  DUP  WHILE              \ level c-addr len\r
 727        2DUP  S" [IF]"  COMPARE 0= IF            \ level c-addr len\r
 728          2DROP 1+                               \ level'\r
 729        ELSE                                     \ level c-addr len\r
 730          2DUP  S" [ELSE]"  COMPARE 0= IF        \ level c-addr len\r
 731            2DROP 1- DUP IF 1+ THEN              \ level'\r
 732          ELSE                                   \ level c-addr len\r
 733            S" [THEN]"  COMPARE 0= IF            \ level\r
 734              1-                                 \ level'\r
 735            THEN\r
 736          THEN\r
 737        THEN ?DUP 0=  IF EXIT THEN               \ level'\r
 738      REPEAT  2DROP                              \ level\r
 739    REFILL 0= UNTIL                              \ level\r
 740    DROP ;  IMMEDIATE\r
 741 \r
 742 \   [IF]        ( flag | flag *<spaces>name...* -- )    \ TOOLS EXT\r
 743 \               If flag is true, do nothing. Otherwise, Skipping leading\r
 744 \               spaces, parse and discard words from the parse area,\r
 745 \               including nested [IF] ... [THEN] and [IF] ... [ELSE] ...\r
 746 \               [THEN], until either the word [ELSE] or [THEN] has been\r
 747 \               parsed and discared.\r
 748 : [IF]  ( flag -- )                             \ TOOLS EXT\r
 749    0= IF POSTPONE [ELSE] THEN ;  IMMEDIATE\r
 750 \r
 751 HEX\r
 752 \   TIME&DATE   ( -- +n1 +n2 +n3 +n4 +n5 +n6 )          \ FACILITY EXT\r
 753 \               Return the current time and date. +n1 is the second {0...59},\r
 754 \               +n2 is the minute {0...59}, +n3is the hour {0...23}, +n4 is\r
 755 \               the day {1...31} +n5 is the month {1...12}, and +n6 is the\r
 756 \               year(e.g., 1991).\r
 757 CODE TIME&DATE\r
 758     BX PUSH,\r
 759     BX BX XOR,\r
 760     2C # AH MOV,\r
 761     21 INT,\r
 762     DH BL MOV,\r
 763     BX PUSH,            \ second\r
 764     CL BL MOV,\r
 765     BX PUSH,            \ minute\r
 766     CH BL MOV,\r
 767     BX PUSH,            \ hour\r
 768     2A # AH MOV,\r
 769     21 INT,\r
 770     DL BL MOV,\r
 771     BX PUSH,            \ day\r
 772     DH BL MOV,\r
 773     BX PUSH,            \ month\r
 774     CX BX MOV,          \ year\r
 775     NEXT,\r
 776 END-CODE\r
 777 \r
 778 DOS-WORDLIST SET-CURRENT\r
 779 \r
 780 HERE CHAR " PARSE insufficient disk space" HERE pack" TO HERE           \ 27h 39\r
 781 HERE CHAR " PARSE cannot complete file operation (out of input)" HERE pack" TO HERE\r
 782 HERE CHAR " PARSE code page mismatch" HERE pack" TO HERE\r
 783 HERE CHAR " PARSE sharing buffer overflow" HERE pack" TO HERE\r
 784 HERE CHAR " PARSE FCB unavailable" HERE pack" TO HERE\r
 785 HERE CHAR " PARSE disk change invalid" HERE pack" TO HERE\r
 786 HERE CHAR " PARSE lock violation" HERE pack" TO HERE\r
 787 HERE CHAR " PARSE sharing violation" HERE pack" TO HERE\r
 788 HERE CHAR " PARSE general failure" HERE pack" TO HERE\r
 789 HERE CHAR " PARSE read fault" HERE pack" TO HERE\r
 790 HERE CHAR " PARSE write fault" HERE pack" TO HERE\r
 791 HERE CHAR " PARSE printer out of paper" HERE pack" TO HERE\r
 792 HERE CHAR " PARSE sector not found" HERE pack" TO HERE\r
 793 HERE CHAR " PARSE unknown media type (non-DOS disk)" HERE pack" TO HERE\r
 794 HERE CHAR " PARSE seek error" HERE pack" TO HERE\r
 795 HERE CHAR " PARSE bad request structure length" HERE pack" TO HERE\r
 796 HERE CHAR " PARSE data error (CRC)" HERE pack" TO HERE\r
 797 HERE CHAR " PARSE unknown command" HERE pack" TO HERE\r
 798 HERE CHAR " PARSE drive not ready" HERE pack" TO HERE\r
 799 HERE CHAR " PARSE unknown unit" HERE pack" TO HERE\r
 800 HERE CHAR " PARSE disk write-protected" HERE pack" TO HERE\r
 801 HERE CHAR " PARSE no more files" HERE pack" TO HERE\r
 802 HERE CHAR " PARSE not same device" HERE pack" TO HERE\r
 803 HERE CHAR " PARSE attempted to remove current directory" HERE pack" TO HERE\r
 804 HERE CHAR " PARSE invalid drive" HERE pack" TO HERE\r
 805 HERE CHAR " PARSE reserved" HERE pack" TO HERE\r
 806 HERE CHAR " PARSE data invalid" HERE pack" TO HERE\r
 807 HERE CHAR " PARSE access code invalid" HERE pack" TO HERE\r
 808 HERE CHAR " PARSE format invalid" HERE pack" TO HERE\r
 809 HERE CHAR " PARSE environment invalid (usually >32K in length)" HERE pack" TO HERE\r
 810 HERE CHAR " PARSE memory block address invalid" HERE pack" TO HERE\r
 811 HERE CHAR " PARSE insufficient memory" HERE pack" TO HERE\r
 812 HERE CHAR " PARSE memory control block destroyed" HERE pack" TO HERE\r
 813 HERE CHAR " PARSE invalid handle" HERE pack" TO HERE\r
 814 HERE CHAR " PARSE access denied" HERE pack" TO HERE\r
 815 HERE CHAR " PARSE too many open files (no handles available)" HERE pack" TO HERE\r
 816 HERE CHAR " PARSE path not found" HERE pack" TO HERE\r
 817 HERE CHAR " PARSE file not found" HERE pack" TO HERE\r
 818 HERE CHAR " PARSE function number invalid" HERE pack" TO HERE\r
 819 HERE CHAR " PARSE no error" HERE pack" TO HERE                          \ 0\r
 820 \r
 821 CREATE DOSErrorMsgTbl\r
 822     , , , , , , , , , , , , , , , , , , , ,\r
 823     , , , , , , , , , , , , , , , , , , , ,\r
 824 \r
 825 FORTH-WORDLIST SET-CURRENT\r
 826 \r
 827 DECIMAL\r
 828 : QUIT\r
 829     BEGIN\r
 830       rp0 rp!  0 BLK !  0 TO SOURCE-ID  0 TO bal  POSTPONE [\r
 831       BEGIN CR REFILL DROP SPACE                \ REFILL returns always true\r
 832             ['] interpret CATCH ?DUP 0=\r
 833       WHILE STATE @ 0= IF .prompt THEN\r
 834       REPEAT\r
 835       DUP -1 XOR IF                                     \ ABORT\r
 836       DUP -2 = IF SPACE abort"msg 2@ TYPE    ELSE       \ ABORT"\r
 837       SPACE errWord 2@ TYPE\r
 838       SPACE [CHAR] ? EMIT SPACE\r
 839       DUP [ 1 iorOffset + ] LITERAL\r
 840           [ 40 iorOffset + ] LITERAL\r
 841                  WITHIN IF iorOffset - CELLS DOSErrorMsgTbl +\r
 842                          @ COUNT TYPE        ELSE       \ DOS error\r
 843       DUP -1 -58 WITHIN IF ." Exeption # " . ELSE       \ undefined exeption\r
 844       CELLS THROWMsgTbl + @ COUNT TYPE       THEN THEN THEN THEN\r
 845       sp0 sp!\r
 846     AGAIN ;\r
 847 \r
 848 : BYE   block-fid FLUSH-FILE THROW  BYE ;\r
 849 \r
 850 NONSTANDARD-WORDLIST SET-CURRENT\r
 851 \r
 852 : MAPPED-TO-BLOCK  ( c_addr u -- )\r
 853     -1 TO block-fid\r
 854     2DUP R/W OPEN-FILE  ?DUP IF\r
 855       NIP       \ drop invalid fileid\r
 856       DUP [ 2 iorOffset + ] LITERAL\r
 857       <> IF     \ not 'file not found error', cannot map block to BLOCKS.BLK\r
 858         -1 TO block-fid\r
 859         ." Cannot map BLOCK to " ROT ROT TYPE [CHAR] . EMIT\r
 860         THROW THEN\r
 861       DROP  ." Create " 2DUP TYPE ."  for BLOCK"\r
 862       2DUP R/W CREATE-FILE THROW\r
 863       HERE 1K BL FILL\r
 864       def#blocks 0 DO DUP HERE 1K ROT WRITE-FILE THROW  LOOP\r
 865       DUP FLUSH-FILE THROW\r
 866     THEN\r
 867     DUP FILE-SIZE THROW\r
 868     1K UM/MOD TO #blocks DROP   \ store file-size/1K in #blocks\r
 869     TO block-fid 2DROP ;\r
 870 \r
 871 BL PARSE BLOCKS.BLK MAPPED-TO-BLOCK\r
 872 \ new boot word, jump into new QUIT\r
 873 \r
 874 HEX\r
 875 CHAR " PARSE model" ENVIRONMENT? DROP\r
 876 CHAR " PARSE RAM Model" COMPARE 0=\r
 877 [IF]\r
 878   : DOSCommand>PAD\r
 879       80 PAD OVER C@ 1+ CHARS MOVE ;\r
 880 [THEN]\r
 881 CHAR " PARSE model" ENVIRONMENT? DROP\r
 882 CHAR " PARSE EXE Model" COMPARE 0=\r
 883 [IF]\r
 884   : DOSCommand>PAD\r
 885       CS@ 10 -  \ PSP segment\r
 886       80 2DUP LC@ 1+ 0 DO 2DUP LC@ PAD I + C! CHAR+ LOOP 2DROP ;\r
 887 [THEN]\r
 888 \r
 889 : newboot ( -- )\r
 890     0 MaxHandle !       \ to be used to calculate UNUSED data space.\r
 891     DOSCommand>PAD\r
 892     hi  S" BLOCKS.BLK" MAPPED-TO-BLOCK  QUIT ;\r
 893 \r
 894 ' newboot TO 'boot\r
 895 \r
 896 CHAR " PARSE model" ENVIRONMENT? DROP\r
 897 CHAR " PARSE EXE Model" COMPARE 0=\r
 898 [IF]\r
 899   DOS-WORDLIST SET-CURRENT\r
 900   HEX\r
 901   CREATE EXEHead\r
 902       5A4D ,            \ file ID for .EXE file\r
 903       0 , 0 ,           \ * file size (remainder and # of 512B pages)\r
 904       0 , 20 ,          \ no relocatable item, head is 20h paragraphs (512B)\r
 905       2000 ,            \ 128 KB needs to be allocated\r
 906       0FFFF ,           \ max paragraphs to allocate\r
 907       0 , 0 ,           \ stack relative segment and initial stack pointer\r
 908       0 ,               \ checksum\r
 909       06 , 0 ,          \ initial relative CS:IP\r
 910       1C ,              \ offset in bytes of the relocation pointer table\r
 911       0 ,               \ overlay number, 0 for main program\r
 912       0 , 0 ,           \ Total is 32 bytes.\r
 913 \r
 914   \   xWrite-file  ( code_space_addr u fileid -- ior )\r
 915   \               Write u characters from c_addr u to the file.\r
 916   CODE xWrite-file\r
 917       40 # AH MOV,\r
 918       CX POP,\r
 919       DX POP,\r
 920       CS DI MOV,\r
 921       DS PUSH,\r
 922       DI DS MOV,\r
 923       21 INT,\r
 924       DS POP,\r
 925       1 L# JC,\r
 926       BX BX XOR,\r
 927       NEXT,\r
 928   1 L:\r
 929       ' get-ior # JMP,\r
 930   END-CODE\r
 931 \r
 932   NONSTANDARD-WORDLIST SET-CURRENT\r
 933 \r
 934   : SYSTEM-SAVED  ( c-addr u -- )\r
 935       W/O CREATE-FILE THROW ( fileid ) >R\r
 936       #order DUP @ #order0 SWAP 1+ CELLS MOVE   \ adjust default search order\r
 937       HERE 0F + 4 RSHIFT        \ data_paragraphs\r
 938       1000                      \ data_paragraphs code_paragraphs\r
 939       + 0 20 UM/MOD OVER IF 1+ THEN     \ add 1 if partial page\r
 940       1+                                \ one head page\r
 941                                 \ mod16 #pages\r
 942       EXEHead 4 + !             \ mod16\r
 943       4 LSHIFT  EXEHead 2 + !\r
 944       HERE 200 0 FILL  EXEHead HERE 20 MOVE\r
 945       HERE 200 R@ WRITE-FILE THROW\r
 946       0    8000 R@ xWrite-file THROW\r
 947       8000 8000 R@ xWrite-file THROW\r
 948       0 HERE 0F + 0FFF0 AND R@ WRITE-FILE THROW\r
 949       R> CLOSE-FILE THROW ;\r
 950 \r
 951   : SAVE-SYSTEM-AS  ( 'name' -- )\r
 952       BL PARSE SYSTEM-SAVED ;\r
 953 [THEN]\r
 954 \r
 955 envQList SET-CURRENT\r
 956 -1 CONSTANT BLOCK\r
 957 -1 CONSTANT BLOCK-EXT\r
 958 -1 CONSTANT FILE\r
 959 -1 CONSTANT FILE-EXT\r
 960 \r
 961 SET-CURRENT  SET-ORDER\r
 962 BASE !\r
 963 \r
 964 QUIT\r
 965 \r
 966 << CON\r