Радио-86РК/Радио 07-90/Обработка файлов на компьютерах IBM/Листинг 1
|
Данный материал защищён авторскими правами!
Использование материала заявлено как добросовестное, исключительно для образовательных некоммерческих целей. Автор: А. ДОЛГИЙ |
program RK86;
type STR2 = string[2]; STR4 = string[4]; TXT = text;
FILE_OF_BYTE = file of byte;
const KEYBAS1: STR4 = #$D3#$D3#$D3#$D3;
KEYBAS2: STB4 = #$D3#$D3#$D3#$00;
KEYED: STB4 = #$e6#$E6#$E6#$E6;
var R: file; S: FILE_OF_BYTE; T: TXT;
RNAME, SNAME, TNAME: string[14];
OPTION: array[1..10] of string[40];
LINE: string[72]; KEY; STR4;
BUF: аrrаy[1..128] of char;
I, J, RD: integer; B: byte; FINAL: boolean;
function HEXCHAR(B: byte): char;
var B1: byte;
begin
B1:= (B and $F) or $30; If В1 > $39 then B1:= B1 + $7;
HEXCHAR:= CHR(B1);
end;
function HEXBYTE(B: byte): STR2;
begin
HEXBYTE:= HEXCHAR(B shr 4) + HEXCHAR(B)
end;
function HEXINT(I: integer): STR4;
begin
HEXINT:= HEXBYTE(HI(I)) + HEXBYTE(LO(I))
end;
function RDINT(var F: FILE_OF_BYTE): integer;
var H, L: byte;
begin
READ(F,L); READ(F,H); RDINT:= L + H shl 8
end;
function LESS(I, J: integer): boolean;
begin
LESS:= (HI(I) < HI(J)) or ((HI(I) = HI(J)) and (LO(I) < LO(J)))
end;
function TRAHSRUS(B: byte): char;
const RUS: array[1..31] of char =
'ЮАБЦДЕФГХИИКЛМНОПЯРСТУЖСВЬЫЗШЭШЧ';
begin
If В in ($60..$7E) then TRANSRUS:= RUS(B - $5F)
else TRAHSRUS:= CHR(B);
end;
function OPTSEL(NOPT: byte): byte;
const DOTLINE: string (40) =
'-------------------------------------------------------------';
var I,N: byte; c: char;
begin
WRITELN(DOTLINE);
for I:= 1 to NOPT do WRITELN(I: 2.' - ',OPTION(I));
WRITELN(DOTLINE); WRITE(' ? ' );
repeat
READ(KBD,C);N:= ORD(C) - $30;
until N in (1..NOPT);
WRITELN(C); OPTSEL:= N;
end;
procedure NAMETEXT;
begin
WRITE('B КАКОЙ ФАЙЛ ЗАПИСАТЬ ? '); READLN(TNAME);
ASSIGN(T, TNAME); REWRITE(T) ;
end;
procedure BASIC_MICRON;
var CSUM, CSUMR, NOPT, I, ADR, N, ERRCNT, LINEСNТ,
LINENR: integer; WNAME: string(14); E, W: TXT; B: byte;
FINISH, EXIT: boolean;
procedure KEYWORD(var F: TXT;B: byte);
const TOKEN: array[0..91] of string(8) = (
'CLS', 'FOR', 'NEXT', 'DATA', 'INPUT', 'DIM', 'READ',
'CUR', 'GOTO', 'RUN', 'IF', 'RESTORE', 'GOSUB','RETURN',
'REN', 'STOP', 'OUT', 'ON', 'PLOT', 'LINE', 'POKE',
'PRINT', 'OFF', 'CONT', 'LIST', 'CLEAR', 'CLOAD', 'CSAVE',
'NEW', 'TAB(', 'TO', 'SPC(', 'FN', 'THЕN', 'NOT', 'STEP',
'+','-','*','/',',','AND', 'OR', '>','=','<', 'SGN',
'INT', 'ABS', 'USR', 'FRE', 'INP', 'POS', 'SQR', 'RND',
'LOG', 'EXP', 'COS', 'SIN', 'ТАN', 'АТN', 'PEEK', 'LEN',
'STR*', 'VAL', 'ASC', 'CHR*', 'LEFT*', 'RIGHT*', 'MID*',
'SCREEN$(', 'INKEY*', 'AT', '&', 'BEEP', 'PAUSE',
'VERIFY', 'НОMЕ', 'EDIT', 'DELETE', 'MERGE', 'AUTO',
'HIMEM', '@', 'ASN', 'ADDR', 'PI', 'RENUM', 'ACS', 'LG',
'LPRINT', 'LLIST');
begin
WRITE(F,TOKEN(B - 128))
end;
procedure ERRMSG(ERNR: byte);
begin
If ERRCNT = 0 then begin
WRITELN(E); WRITELN(E,'ОШИБКИ И ПРЕДУПРЕЖДЕНИЯ:')
end;
WRITE(E,'СТРОКА', LINENR: 10.' : ');
саsе ERNR of
1,2: WRITE(E,HEXBYTE(B));
3..5: KEYWORD (E, В);
end;
саsе ERNR of
1: begin
WRITE(E,' - ПСЕВДОГРАФИЧЕСЕЙ КОД');
WRITELN(E, ' ЭАМЕНЕН НА Ш' )
end;
2: begin
WRITE(E, ' - ЗАПРЕШЕННЫЙ КОД' );
WRITELN(E, ' ЗАМЕНЕН НА #');
end;
3: begin
WRITE(E,' - В BASIC-80');
WRITELN(E,' HE РЕАЛИЗОВАН');
end;
4: begin
WRITE(E,' - В BASIC-80 РАБОТАЕТ ИНАЧЕ. ');
WRITELN(E,' ЧЕМ В BASIC MICRON')
end:
5: begin
WRITE(E, ' - ДИРЕКТИВА ОПЕРАТОРА');
WRITELN(E,' B ПРОГРАММЕ' );
end:
end;
ERRCNT:= ERRCNT + 1;
end;
begin
ОРТION[3]:= 'ЗАПИСАТЬ ТЕКСТ ПРОГРАММЫ';
OPTION[4]:= 'ЗАПИСАТЬ ОШИБКИ И ПРЕДУПРЕ1ДЕНИЯ';
WRITELN; WRITELN('BASIC*MICRON : ',LINE);
NOPT:= 3; EXIT:= false;
repeat
саsе OPTSEL (NOPT) of
1: begin EXIT:= true; FINAL:= true end;
2: begin EXIT:= true; FINAL:= false end;
3: begin
FINISH:= false; NAMETEXT;
RESET(S); repeat READ(S,B) until B = 0;
ASSIGN(E,'ERR.ORS'); REWRITE(E);
I:= 1; CSUM:= 0; LINECNT:= 0; ERRCNT:= 0;
repeat;
READ(S,B); CSUM:= CSUM + B;
case I of
1: ADR:= B;
2: begin
ADR:= ADR + B shl 8
if ADR 0 then FINISH true
end
3: LINENR:= B;
4: begin
LINENR:= LINENR + B shl 8;
case LINENR of
0..9: N:= 1;
10..99: N:= 2;
100..999: N:= 3;
1000..9999: N:= 4;
10000..32767: N:= 5;
end;
WRITE(T,LINENR N '); LINECNT:= LINECNT + 1;
end
else case B of
0: begin I:= 0; WRITELN(T); end
1,7,9,11,13,23,27,31: begin WRITE(T,'Ш'); ERRMSG(1); end
8,10,12,24,20,220,255: begin WRITE(T #'); ERRMSG(2); end
32,127: WRITE(T,TRANSRUS(B));
128,133,146,147,154,155,198,200,205,208,211,217: begin KEYWORD(T,B); ERRMSG(3); end
144,148,153,177,179,189,218: begin KEYWORD(T,B); ERRMSG(4); end
137,151,152,156,208,207,209,210,215,219: begin KEYWORD(T,B); ERRMSG(5); end
else KEYWORD(T,B)
end
end
I:= I + l;
until FINISH Or EOF(S);
WRITELN; WRITE('B ФАЙЛ ',TNAME,' ЗАПИСАНО');
WRITELN(LINECNT,' CTPOK');
WRITELN('НОМЕР ПОСЛЕДНЕЙ СТР0КИ ',LINENR);
if not FINISH then begin
WRITELN('КОНЕЦ ПРОГРАММЫ НЕ НАЙДЕН');
WRITELN(T);
end
if ERRCNT > 0 then begin
WRITELN(ERRCNT,' ошибок/предупреждении');
NOPT:= 4;
end else begin CLOSE(E); ERASE(E); NOPT:= 3; end
end
4: begin
RESET(E); WRITE('B КАКОЙ ФАЙЛ ЗАПИСАТЬ ?');
READLN(WNAME);
if WNAME = TNAME then while not EOF(E) do begin
READLN(E,LINE); WRITELN(T,LINE);
end else begin
ASSIGN(W,WNAME); REWRITE(W);
while not EOF(E) do begin
READLN(E,LINE); WRITELN(W,LINE);
end;
end
CLOSE(W); CLOSE(E); ERASE(E); NOPT:= 3;
end
end
CLOSE(T);
until EXIT
end
procedure ED_MICRON
var LEN: Integer; В: byte; EXIT: boolean;
begin
ОРТION[3]:= 'ЗАПИСАТЬ ТЕКСТ';
READ(S,В); LEN:= RDINT(S);
WRITELN; WRITELN('ЕD_MИКРОН',LINE);
WRITELN(LEN,' БАЙТ'); EXIT:= false;
repeat
саsе OPTSEL(3) of
1: begin EXIT:= true; FINAL:= true; end
2: begin EXIT:= true; FINAL:= False; end
3: begin
NAMETEXT:= SEEK(S,3); READ(S,B);
While (B <> $FF) and not EOF(S) do begin
WRITE(T,TRANSRUS(B));
If B = $0D then WRITE(T,#$0A); READ(S,B);
end
if B <> $FF then begin
WRITELN(T); WRITELN('HE НАЙДЕН КОНЕЦ ТЕКСТА'); end
CLOSE(T);
end
end
until EXIT;
end
procedure MONITOR
var ADR, BEGADR, EHDADR, CSUM, CSUMR, I, FI, LA, NOPT,
CT, CS, FSIZE, PS: integer; NADR, STR4, ВТ: string[3]
B: byte; CH, D: char; ER, EXIT: boolean;
procedure LSPAS,
var I,J: integer; FIN: boolean;
procedure KEYWORD(var F: TXT; B: byte)
const ТOKEN: array[1 31] of string(9) (
'FOR','TO','DO','IF','THEN','ELSE','BEGIN','END',
'OF', 'DIV','MOD','READ','WRITE','MEM','CALL',
'REPEAT','WHILE','UNTIL','OR','AND','NOT','CASE',
'CONST','VAR','FUNCTION','PROCEDURE','DOWNTO',
'INTEGER','ARRAY','SHL','SHR');
begin WRITE(F,TOKEN(B,128) end
begin
WRITELN; WRITE(' ПАСКАЛЬ LS '); SEEK(S,6); READ(S,B);
while B <> $0D do begin
WRITE(TRANSRUS(B)); READ(S,B);
end
WRITELN; NAMETEXT:= I + 1; FIN:= false; SEEK(S,15);
repeat
READ(S,B);
case I of
1: if B = 1 then FIN:= true;
2,3: else case B of
$05: WRITE(T,'(*');
$0D: begin WRITELN(T) I:= 0; end
$12: WRITE(T,'*)');
$20: If I <> 4 then WRITE(T,'.');
$21..$7E: WRITE(T,TRANSRUS(B));
$80..$9F: KEYWORD(T,B) ;
$FF: begin
READ(S,B);
for J:= 1 to B + 1 do WRITE(T,' ');
end
end
end
I:= I + 1;
until FIN;
CLOSE(T);
end
function CHECK(CT: integer): integer;
vаг SL,SH: integer; B: byte;
begin
SL:= 0; SH:= 0;
while CT <> 1 do begin
READ(S,B); SL:= SL + B; SH:= SH + B + HI(SL); SL:= SL and $FF;
CT:= CT + 1;
end
READ(S,B); SL:= (SL + B) and $FF;
CHECK:=SL + (LO(SH) shl 8);
end
begin
ОРТION[3]:= ' ЗАПИСАТЬ DUMP';
OPTION[4]:= ' ЗАПИСАТЬ HEX';
FSIZE:= FILESIZE(S); WRITELN;
BEGADR:= ORD(KEY[2]) + ORD(KEY[1]) shl 8;
ENDADR:= ORD(KEY[4]) + ORD(KEY[3]) shl 8;
If LESS(ENDADR,BEGADR) then begin
WRITELN(FSIZE,' БАИТ ТИП ФАЙЛА IE ОПРЕДЕЛЕН');
repeat
WRITE('ВВЕДИТЕ НАЧАЛЬНЫЙ АДРЕС (HEX)');
NADR:= 0000; READLN(NADR); BEGADR:= 0; ЕR:= false;
for I:= 1 to LENGTH(NADR) do begin
D:= NADR[I];
case D of
0..9: B: ORD(D) = $30;
A..F: B: ORD(D) = $37;
else ER true
end
BEGADR:= B + BEGADR shl 4;
end
ENDADR:= BEGADR + FSIZE;
ЕR:= ЕR or LESS(ENDADR,BEGADR);
if ЕR then WRITE(' ОШИВКА!');
until not ER
end else begin
WRITELN(' ФАЙЛ MOHUTOPA.');
If (FSIZE-4) < (ЕNDADR-BEGADR) then begin
WRITE(' Данных меньше чем задано адресами');
WRITELN(HEXINT(BEGADR),НЕХINT(ЕNDАDR));
ENDADR:= FSIZE + BEGADR - 4;
end
SEEK(S,4);
end
WRITELN('НАЧАЛО ->',HEXINT(BEGADR));
WRITELN('КОНЕЦ ->',HEXINT(ENDADR));
WRITE('КОНТР CYMMA ->'); PS:= FILEPOS(S);
CSUM:= CHECK(ENDADR,BEGADR); WRITE(HEXINT(CSUM));
B:= $0 while not (EOF(S) or (B $E6)) do READ(S,B);
If LESS(FILEPOS(S),FSIZE) then begin
CSUMR:= SWAP(RDINT(S));
if CSUM <> CSUMR Then begin
WRITELN(' ? ');
end else
WRITELN;
WRITELN(' ',HEXINT(CSUMR));
end else begin
WRITELN;
WRITE('В ИСХОДНЫХ ДАННЫХ КОНТРОЛЬНАЯ СУММА ');
WRITELN(' ОТСУТСТВУЕТ');
end;
repeat
SEEK(S,4);
if (BEGADR = $3003) and (RDINT(5) = ENDADR) then begin
NOPT:= 5;
OPTION[5]:= 'Обработать как ПАСКАЛЬ-ПРОГРАММУ';
end else NOPT:= 4;
SEEK(S,PS); EXIT:= false;
case OPTSEL(NOPT) of
1: begin EXIT:= true; FINAL:= true end;
2: begin EXIT:= tгue; FINAL:= false end;
3: begin
NAMETEXT; ADR:= BEGADR;
repeat
LINE:= HEXINT(ADR) + ' ';
FI:= АDR and $F; LA:= ENDADR - ADR;
If LA > $0F then LA:= $0F;
for I:= 0 to 15 do begin
if I in [FI..LA] then begin
READ(S,B); ADR:= ADR + 1; BT:= HEXBYTE(B) + ' ';
if B in [ $20..$7E] then CH:= TRANSRUS(B);
else CH:= '.';
end else begin BT:= ' '; CH:= ' ' end;
INSERT(BT,LINE,I*3+7); LINE:= LINE + CH;
end;
while LINE[LENGTH(LINE)] = ' ' do
DELETE(LINE,LENGTH(LINE),1);
WRITELN(T,LINE);
until LESS(ENDADR,ADR);
end;
4: begin
NAMETEXT; ADR:= BEGADR;
repeat
FI:= ADR and $0F; LA:= ENDADR - ADR;
If LA > $0F then LA:= $0F; CT:= LA - FI + 1;
LINE:= ':' + HEXBYTE(CT) + HEXINT(ADR) + '00';
CS:= CT + HI(ADR) + LO(ADR);
for I:= 1 to CT do begin
READ(S,B); ADR:= ADR + 1; LINE:= LINE + HEXBYTE(B);
CS:= CS + B;
end;
LINE:= LINE + HEXBYTE(LO(-CS)); WRITELN(T,LINE);
Until LESS(ENDADR,ADR);
WRITELN(T,':00000000');
end;
5: LSPAS;
end;
until EXIT;
CLOSE(T);
end;
begin
CLRSCR;
WRITELN('**ASD-88*************************************');
WRITELN('* *'); *');
WRITELN('* ОБРАБОТКА ФАЙЛОВ РАДИО-86РК *');
WRITELN('* *'); *');
WRITELN('*************************************VЗ. 1***');
FINAL:= false;
ОPTION[1]:= 'Закончить работу';
OPTION[2]:= 'Перейти к обработке другого файла':
repeat
WRITELN; WRITE('Какой файл обработать ?');
READLN(RNAME); ASSIGN(R,RNAME); RESET(R);
ASSIGN(S,'XXXXXXXX.XXX'); REWRITE(S);
BLOCKREAD(R,BUF,1,RD); KEY:= COPY(BUF,1,4);
J:= 1; LINE:= ' ';
If (KEY = KEYBAS1) or (KEY + KEYED) then begin
LINE:= COPY(BUF,5,POS(#00,BUF)-5);
repeat
BLOCREAD(R,BUF,1,RD); J:= POS(#$E6,BUF);
until J > 0;
end;
repeat
for I:= J to l28 do begin
B:= ORD(BUF(I)); WRITE(S,B);
end;
BLOCKREAD(R,BUF,1,RD); J:= 1;
until RD:= 0;
CLOSE(R);
RESET(S);
If (KEY = KEYBAS1) or (KEY = KEYBAS2) then BASIC_MICROH
else If KEY = KEYED then ED_MICRON else MONITOR;
until FINAL;
CLOSE(S); ERASE(S);
end.