home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware 1 2 the Maxx
/
sw_1.zip
/
sw_1
/
PROGRAM
/
FORTHCMP.ZIP
/
COPIES.4TH
< prev
next >
Wrap
Text File
|
1992-03-30
|
6KB
|
227 lines
\ This program can be used to create new screen files that are composed
\ of other screen files and blank screens.
\ Copyright (C) 1985, Thomas Almy. All rights reserved.
\ Users of ForthCMP are given permission to use or distribute this
\ program, as long as no charge is made and the credit message is maintained.
100 MSDOS
INCLUDE VARS
INCLUDE DOS1
DECIMAL
1024 CONSTANT B/SCR ( Bytes per Forth screen )
B/SCR 1- NOT CONSTANT BLOCKMASK ( Mask of block size )
VARIABLE JUSTONE ( TRUE IF ARGS PASSED IN COMMAND LINE )
VARIABLE FILESIZE ( MAX SCREEN NUMBER IN FILE )
VARIABLE BUFST ( STARTING ADDRESS OF OUTPUT BUFFER )
VARIABLE BUFP ( POINTER INTO OUTPUT BUFFER )
VARIABLE BUFE ( END OF OUTPUT BUFFER )
HCB INFILE
HCB OUTFILE
VARIABLE CBUF
: EMIT CBUF C! stderr CBUF 1 write DROP ;
: TYPE stderr -ROT write DROP ;
: CS:TYPE TYPE ;
0 0 IN/OUT : PROMPT ." > " ;
0 0 IN/OUT
: CANCEL #TIB @ >IN ! ." (remainder of input line ignored)" CR ;
1 1 IN/OUT
: UPC ( char -- uppercase.char )
DUP ASCII a >= IF DUP ASCII z <= IF BL - THEN THEN ;
1 1 IN/OUT
: INRANGE? ( screen -- successflag )
FILESIZE @ U> NOT ;
1 0 IN/OUT
: ADD.DEFAULT.EXTENSION ( handle -- )
2 + DUP >R 1+ ( ext string )
BEGIN COUNT DUP ASCII . = IF DROP BEGIN COUNT DUP 0=
IF R> DROP 2DROP EXIT THEN DUP ASCII \ = SWAP ASCII / = OR UNTIL 1 THEN
0= UNTIL
DUP 1- ASCII . C<- ( replace null with dot )
CNT" SCR" 0 DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
DROP ( extension address )
DUP 0 C<- ( delimit string )
R@ - 1- R> C! ( set length byte )
;
0 0 IN/OUT
: INIT.BUFFER
DP @ 256 + DUP BUFP !
BUFST ! ( buffer starts at beginning of free memory )
S0 @ 128 - BUFST @ - BLOCKMASK AND
BUFST @ + BUFE ! ( end of blocks )
;
0 0 IN/OUT
: FLUSH.OUT
OUTFILE BUFST @ BUFP @ BUFST @ - DUP >R FWRITE R> <> IF
." ERROR: DISK FULL" OUTFILE FCLOSE bye THEN
BUFST @ BUFP !
;
0 0 IN/OUT
: CLOSE.FILE
BUFP @ BUFST @ <> IF FLUSH.OUT THEN
OUTFILE HCB>H stdout <> IF OUTFILE FCLOSE DROP THEN
;
0 1 IN/OUT
: WRITE.CHARS ( -- ptr AT WHICH ONE IS TO WRITE B/SCR CHARACTERS )
BUFE @ BUFP @ = IF FLUSH.OUT THEN
BUFP @ DUP B/SCR + BUFP ! ;
0 0 IN/OUT
: HELLO
." FORTH SCREEN COPY PROGRAM" CR
." Copyright (C) 1985 by Thomas Almy. All rights reserved." CR
;
0 0 IN/OUT
: USAGE
." USAGE: copies destfile { sourcefile { options }}" CR
." where options are:" CR
." +N M-N M- -N or +bN" CR
." Use destfile=`-' for standard output" CR
bye
;
0 0 IN/OUT
: OPEN.FILE
BL WORD C@ 0= IF USAGE THEN ( file must be specified )
HELLO
HERE @ ASCII - 8 << 1+ = IF ( use STD-OUTPUT )
stdout OUTFILE !
ELSE
HERE OUTFILE NAME>HCB
OUTFILE ADD.DEFAULT.EXTENSION
OUTFILE O_RD FOPEN 0= IF ( file open successful!)
OUTFILE FCLOSE DROP ( so close it! )
." Destination file exists. Delete?" KEY DUP EMIT CR
UPC ASCII Y <> IF ." Aborting..." bye THEN
THEN
OUTFILE 0 FMAKE IF ( create failed )
." ERROR -- couldn't create destination file" bye THEN
THEN
BL WORD C@ IF ( more on command line )
JUSTONE ON
ELSE ( no more on command line )
PROMPT
QUERY
BL WORD C@ 0= IF OUTFILE FCLOSE bye THEN
THEN
;
0 0 IN/OUT
: GET.COMMAND.LINE
129 TIB 127 CMOVE
128 C@ #TIB !
;
0 1 IN/OUT
: GET.COMMAND.WORD ( -- flag , leave word at HERE )
BL WORD C@ IF -1 ELSE
JUSTONE @ IF 0 ELSE
PROMPT QUERY BL WORD C@ THEN THEN ;
0 0 IN/OUT
: OPEN.INPUT.FILE
HERE INFILE NAME>HCB
INFILE ADD.DEFAULT.EXTENSION
INFILE O_RD FOPEN IF ( failed )
." File " INFILE .FNAME ." not found" CR
CANCEL FILESIZE OFF EXIT THEN
INFILE 0 0 2 FSEEK B/SCR M/MOD 1- FILESIZE ! DROP
;
2 0 IN/OUT
: COPY.SCREENS ( first last -- )
OVER INRANGE? OVER INRANGE? AND 0= IF
." Screens out of range" CR CANCEL 2DROP
ELSE
2DUP MAX 1+ -ROT MIN
INFILE OVER B/SCR M* 0 FSEEK 2DROP
DO INFILE WRITE.CHARS B/SCR FREAD B/SCR <> IF ." READ ERROR" THEN LOOP
THEN
;
1 0 IN/OUT
: COPY.BLANKS ( count -- )
0 ?DO WRITE.CHARS B/SCR BL FILL LOOP
;
: ATDELIM? ( dblint ptr valid.delimiter -- int -1 OR 0 )
SWAP C@ <> IF ." INVALID SPECIFIER: " HERE COUNT TYPE CR
CANCEL 2DROP 0
ELSE DROP -1
THEN ;
VARIABLE T1 ( Temporaries for INSTR )
VARIABLE T2
: INSTR ( countedstring character -- position -1 or 0 )
T1 C! ( save character )
T2 OFF ( found flag )
COUNT 0 ?DO COUNT T1 C@ = IF I SWAP T2 ON LEAVE THEN LOOP
DROP ( address ) T2 @ ;
1 0 IN/OUT
: RANGE.OF.SCREENS ( signPosition --- )
CASE ( depending on sign position )
0 OF HERE C@ 1 = IF 0 FILESIZE @ COPY.SCREENS ( whole file )
ELSE 0 0. HERE 1+ CONVERT ( - num )
BL ATDELIM? IF COPY.SCREENS THEN
THEN ENDOF
HERE C@ 1- OF ( up to end : NUM - )
0. HERE CONVERT
ASCII - ATDELIM? IF FILESIZE @ COPY.SCREENS THEN ENDOF
0. HERE CONVERT DUP >R ASCII - ATDELIM? IF
0. R> CONVERT BL ATDELIM? IF COPY.SCREENS THEN
ELSE R> DROP THEN
ENDCASE
;
0 0 IN/OUT
: SINGLE.SCREEN
HERE 2+ C@ UPC ASCII B = IF ( blanks )
0. HERE 2+ CONVERT BL ATDELIM? IF
COPY.BLANKS THEN
ELSE
0. HERE 1+ CONVERT BL ATDELIM? IF
DUP COPY.SCREENS THEN
THEN
;
0 0 IN/OUT
: EXECUTE.COMMAND
HERE ASCII - INSTR IF ( "-" means range of screens )
RANGE.OF.SCREENS
ELSE HERE 1+ C@ ASCII + = IF ( single scren or blank screens )
SINGLE.SCREEN
ELSE OPEN.INPUT.FILE THEN THEN ;
: MAIN
INIT.BUFFER
GET.COMMAND.LINE
OPEN.FILE
BEGIN
EXECUTE.COMMAND
GET.COMMAND.WORD 0=
UNTIL
CLOSE.FILE
bye
;
INCLUDE DOS2
INCLUDE FORTHLIB
END