dos_compilers/DX-FORTH v430/FCOPY.SCR

\ FCOPY - Information                                                                                                           A filecopy utility to demonstrate the use of the disk functions.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ Load screen                                                   FORTH DEFINITIONS  DECIMAL                                      APPLICATION                                                                                                                     2 LOAD                          \ compile program                                                                               TURNKEY MAIN FCOPY              \ create turnkey application                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    \ H1 H2 HELP ARGV                                               \ File handles                                                  VARIABLE H1     VARIABLE H2                                                                                                     \ Show help                                                     : HELP  ( -- )                                                    ." Usage:  FCOPY infile outfile" CR                             ." Filecopy utility" CR ;                                                                                                     \ Parse blank delimited argument from commandline.              : ARGV  ( n -- adr u -1 | 0 )                                     0 0 ROT  128 COUNT  ROT 0 ?DO                                     2NIP  BL SKIP  2DUP BL SCAN                                     ROT OVER -  -ROT  LOOP                                        2DROP DUP IF -1 ELSE AND THEN ;                               -->                                                             \ GETARG FERROR BUFSIZE GET                                     \ Get argument, if none show help and exit                      : GETARG  ( n -- adr u )  ARGV 0= IF  HELP ABORT THEN ;                                                                         \ Display filename and exit                                     : FERROR  ( n -- )  ARGV IF  TYPE THEN  ABORT ;                                                                                 \ Buffer size - use max available memory, allow for stack etc   : BUFSIZE  ( -- u )                                               UNUSED  500 - ;                                                                                                               \ Read u1 chars from input file,  u2 = #chars actually read     : GET  ( u1 -- u2 )  PAD SWAP  H1 @  READ-FILE                    ABORT" read error" ;                                          -->                                                                                                                             \ PUT COPY-FILE                                                 \ Write u chars to output file                                  : PUT  ( u -- )  PAD SWAP  H2 @  WRITE-FILE                       ABORT" write error: probably out of disk space" ;                                                                             \ Copy loop                                                     : COPY-FILE  ( -- )                                               BEGIN                                                             BUFSIZE  GET  ?DUP                                            WHILE ( not end-of-file )                                         PUT                                                           REPEAT ;                                                      -->                                                                                                                                                                                                                                                             \ OPEN-FILES CLOSE-FILES MAIN                                   \ Open source and destination files                             : OPEN-FILES  ( -- )                                              1 GETARG  R/O OPEN-FILE                       \ open 1st        IF ." can't open: "  1 FERROR THEN  H1 !      \ save handle     2 GETARG  R/W CREATE-FILE                     \ create 2nd      IF ." can't create: "  2 FERROR THEN  H2 ! ;  \ save handle                                                                   \ Close source and destination files                            : CLOSE-FILES  ( -- )                                             H1 @  CLOSE-FILE DROP                                           H2 @  CLOSE-FILE IF ." error closing: " 2 FERROR THEN ;                                                                       : MAIN  ( -- )                                                    CR ." FCOPY" CR                                                 OPEN-FILES COPY-FILE CLOSE-FILES  ." file copied" CR ;