|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 20655 (0x50af)
Types: TextFile
Names: »CHRCONV.PAS«
└─⟦e2123b2a1⟧ Bits:30010498 DVBS1.SW2103.src.1.8-1 Pascal TOOLS JTAS 1989-04-26 LEIF NIELSEN E.d.
└─⟦this⟧ »CHRCONV.PAS«
{[A=20,I=2,L=4,E=3,W=1-100] PASCFORM directive}\r
PROGRAM chrconv;\r
{ Convert characters, governed by table which is read in.\r
------------------------------------------------------------------------------\r
Date. Init. Vers. Explanation:\r
\r
1989-02-03 LEI 1.0 First version.\r
1989-02-17 LEI 1.1 Inserted DETAB handling + HELP info.\r
1989-04-17 LEI 1.2 Small correction to DETAB handling.\r
------------------------------------------------------------------------------}\r
\r
USES\r
Dos,\r
DosUtil,\r
Help,\r
Param;\r
\r
LABEL\r
99;\r
\r
CONST\r
Version = ('1.2');\r
Max_Str = 10; { Max length replacement string alowed }\r
Max_TAB_pos = 255; { highest position where tabulator is accepted }\r
MaxParam = 2;\r
MaxOption = 2;\r
\r
ParamList : ARRAY[1..MaxParam] OF ParamRec =\r
((Kind:KnownFile; Defined:FALSE; KeyWord:'I'; NumVal:0; TextVal:''),\r
(Kind:FileType; Defined:FALSE; KeyWord:'O'; NumVal:0; TextVal:''));\r
\r
OptionList : ARRAY[1..MaxOption] OF ParamRec =\r
((Kind:FileType; Defined:FALSE ;KeyWord:'TABLE'; NumVal:0; TextVal:'COPY.CHT'), (*Table*)\r
(Kind:OnOff; Defined:FALSE ;KeyWord:'XRAY'; NumVal:0; TextVal:'OFF') ); (*test*)\r
\r
\r
VAR\r
Source: FILE;\r
\r
CONST\r
RecSize = 128;\r
BufSize = 160;\r
BufPos: word = RecSize;\r
BufNo: word = BufSize;\r
RecsRead: word = 1;\r
BytePos: longint = 0;\r
Lgt_source_file: longint = -2;\r
\r
VAR\r
InputBuffer: ARRAY [1..BufSize, 1..RecSize] OF byte;\r
\r
name: STRING[80]; { xxx Indtil videre her, selv om det ikke er kЏnt }\r
\r
\r
FUNCTION GetFileSize( name: STRING): longint;\r
VAR\r
f: FILE OF byte;\r
\r
BEGIN\r
Assign(f, name);\r
{$I-}\r
Reset(f);\r
{$I+}\r
IF IOResult <> 0 THEN\r
GetFileSize := -1\r
ELSE BEGIN\r
GetFileSize := FileSize(f);\r
Close(f);\r
END {if};\r
END (* GetFileSize *);\r
\r
PROCEDURE OpenByteFile(name: STRING);\r
BEGIN\r
assign(source, name);\r
reset(source, RecSize);\r
\r
Lgt_Source_file := GetFileSize(name);\r
BufPos := 1;\r
BufNo := 1;\r
BlockRead(Source, InputBuffer, BufSize, RecsRead);\r
BytePos := 0;\r
\r
END; (* OpenByteFile *)\r
\r
FUNCTION GetByte(VAR Byt: byte): boolean;\r
BEGIN\r
Byt := InputBuffer[ BufNo, BufPos ];\r
BytePos := BytePos + 1;\r
GetByte := Lgt_Source_file >= BytePos;\r
BufPos := BufPos + 1;\r
IF BufPos > RecSize THEN\r
BEGIN\r
BufPos := 1;\r
BufNo := BufNo + 1;\r
IF BufNo > BufSize THEN\r
BEGIN\r
BufNo := 1;\r
IF RecsRead > 0 THEN\r
BlockRead(Source, InputBuffer, BufSize, RecsRead);\r
END;\r
END;\r
END; (* GetByte *)\r
\r
FUNCTION LookAhead(VAR Byt: byte): boolean;\r
BEGIN\r
IF Lgt_Source_file >= BytePos THEN\r
BEGIN\r
LookAhead := true;\r
Byt := InputBuffer[ BufNo, BufPos ];\r
END\r
ELSE\r
BEGIN\r
lookAhead := false;\r
byt := 0;\r
END;\r
END; (* LookAhead *)\r
\r
\r
FUNCTION strwzero( i: longint; size, base: integer ): STRING;\r
VAR\r
k, l, m, low : longint;\r
temp: STRING[34];\r
CONST\r
digit: ARRAY [ 0..15 ] OF char =\r
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',\r
'A', 'B', 'C', 'D', 'E', 'F' );\r
BEGIN\r
temp[0] := chr(size);\r
FOR k := 1 TO size DO\r
temp[k] := '0';\r
\r
k := abs(i);\r
IF i < 0 THEN\r
BEGIN\r
low := 2;\r
temp[1] := '-';\r
END\r
ELSE\r
low := 1;\r
\r
l := size + 1;\r
WHILE ( k <> 0 ) AND ( l > low ) DO\r
BEGIN\r
l := l - 1;\r
temp[l] := digit[ k MOD base ];\r
k := k DIV base;\r
END;\r
IF k <> 0 THEN { overflow }\r
temp[low] := '*';\r
strwzero := temp;\r
END;\r
\r
PROCEDURE PrintDate(VAR f: text);\r
VAR\r
d, m, y, dow: word;\r
\r
BEGIN\r
GetDate(y, m, d, dow);\r
write(f, strwzero( y, 4, 10), '-', strwzero( m, 2, 10) );\r
write(f, '-', strwzero( d, 2, 10) );\r
\r
END {PrintDate};\r
\r
PROCEDURE PrintTime(VAR f: text);\r
VAR\r
h, m, s, ds: word;\r
\r
BEGIN\r
GetTime(h, m, s, ds);\r
write(f, strwzero( h, 2, 10), ':', strwzero( m, 2, 10) );\r
{ write(f, ':', strwzero( s, 2, 10) ); }\r
END {PrintTime};\r
\r
\r
CONST\r
NUL = 0;\r
HT = 9;\r
LF = 10;\r
CR = 13;\r
EM = 25;\r
SUB = 26; { DOS EOF character }\r
ESC = 27;\r
DEL = 127;\r
E_O_F = 256;\r
CRLF = 257;\r
LFCR = 258;\r
\r
TYPE\r
proces_type = ( cpy, stop, tab, cr_found, lf_found );\r
\r
VAR\r
byt, tmp_byt: byte;\r
typ: proces_type;\r
\r
out_pos, next, i, j, k: integer;\r
\r
res_ch: ARRAY [NUL..LFCR] OF STRING[Max_Str];\r
\r
res_type: ARRAY[NUL..LFCR] OF proces_type;\r
res_type_cr, res_type_lf, res_type_ht: proces_type;\r
\r
Pos_increment: ARRAY[NUL..LFCR] OF integer;\r
Next_TAB_pos: ARRAY[1..Max_TAB_pos] OF integer;\r
\r
test_requested: boolean;\r
\r
Table_file: STRING[80];\r
tab_fil: text;\r
outpfile: STRING[80];\r
Out_fil: text;\r
O_buff: ARRAY[1..4096] OF byte;\r
\r
line, tmp_line: STRING;\r
\r
\r
PROCEDURE ReportError( err_str: STRING);\r
BEGIN\r
writeln( '--- ERROR --- ', err_str);\r
halt;\r
END;\r
\r
PROCEDURE read_callparameters;\r
VAR\r
i, k: integer;\r
key_text: STRING;\r
dir_st: DirStr;\r
name_st: NameStr;\r
ext_st: ExtStr;\r
\r
\r
BEGIN\r
\r
IF ParamCount = 0 THEN\r
BEGIN { The user must give at least the output file as parameter }\r
Showhelp;\r
Halt;\r
END;\r
\r
GetParams( Paramlist, MaxParam, OptionList, MaxOption);\r
\r
test_requested := OptionList[2].TextVal = 'ON';\r
\r
\r
name := ParamList[1].TextVal;\r
\r
IF ParamList[2].Defined THEN\r
outpfile := ParamList[2].TextVal\r
ELSE\r
ReportError(' No output file name defined. ');\r
\r
FileMode := FM_readOnly;\r
OpenByteFile( name);\r
\r
assign(output, '');\r
rewrite(output);\r
\r
write(' CHRCONV v. ', version, ' At: ');\r
PrintDate(output); write(' '); PrintTime(output); writeln;\r
writeln(' Input file: ', FExpand(name) );\r
writeln(' Output file: ', FExpand(outpfile) );\r
\r
IF OptionList[1].Defined THEN\r
BEGIN\r
Table_file := OptionList[1].TextVal;\r
FSplit( Table_file, dir_st, name_st, ext_st);\r
IF ( length(ext_st) = 0 ) AND ( pos('.', Table_file) = 0 ) THEN\r
ext_st := '.CHT';\r
Table_file := dir_st + name_st + ext_st;\r
\r
IF GetFileSize( Table_file ) < 1 THEN\r
BEGIN { try to find table same place as program }\r
tmp_line := name_st + ext_st;\r
\r
FSplit( ProgFileName, dir_st, name_st, ext_st);\r
Table_file := dir_st + tmp_line;\r
END;\r
\r
IF test_requested THEN\r
writeln( 'Table-file used: ', Table_file);\r
\r
IF GetFileSize(Table_file) < 1 THEN\r
ReportError(' Table file empty or not found: '+ Table_file);\r
END;\r
\r
END (* READ_CALLPARAMETERS *);\r
\r
\r
PROCEDURE decode_line( line: STRING);\r
VAR\r
tmp_line: STRING;\r
\r
PROCEDURE decode_chr( l: STRING);\r
VAR\r
i, k, code, no, number: integer;\r
line: STRING;\r
\r
BEGIN\r
\r
line := l;\r
\r
i := Pos('=', line);\r
IF i = 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
\r
Val( copy(line, 1, i-1), no, code);\r
IF ( code <> 0 ) OR ( no < NUL ) OR ( no > LFCR ) THEN\r
ReportError(' Table input illegal : '+ l);\r
\r
k := Pos('(', line);\r
IF k = 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
\r
IF k > i + 1 THEN\r
BEGIN\r
tmp_line := copy(line, i+1, k-i-1);\r
CASE MatchOptionStr(tmp_line, 5, 'COPY STOP TAB ') OF\r
\r
-1: ReportError(' Option not unique: '+ tmp_line + ' In: '+ l);\r
\r
0: ReportError(' Option not found: '+ tmp_line + ' In: '+ l);\r
\r
1: res_type[no] := cpy;\r
\r
2: res_type[no] := stop;\r
\r
3: res_type[no] := tab;\r
\r
END;\r
END\r
ELSE\r
res_type[no] := cpy;\r
\r
i := pos(')', line);\r
line := copy(line, k+1, i-k-1 );\r
IF i = 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
\r
res_ch[no] := '' ;\r
number := 0;\r
\r
WHILE ( length(line) > 0 ) AND ( number < 10 ) DO\r
BEGIN\r
k := pos(',', line);\r
IF k = 0 THEN k := length(line) + 1;\r
val(copy(line, 1, k-1), i, code);\r
IF code <> 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
res_ch[no] := res_ch[no] + chr(i);\r
number := number + 1;\r
line := copy(line, k+1, 255);\r
END;\r
\r
IF length(line) > 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
\r
END {decode_chr};\r
\r
PROCEDURE decode_tab( l: STRING);\r
VAR\r
i, j, k, code, no, nxt: integer;\r
line: STRING;\r
\r
PROCEDURE settab(tab_pos: integer);\r
VAR\r
i: integer;\r
\r
BEGIN\r
i := nxt;\r
IF i < 1 THEN i := 1;\r
WHILE ( i <= Max_TAB_pos ) AND ( i < tab_pos ) DO\r
BEGIN\r
Next_TAB_pos[i] := tab_pos;\r
i := i + 1;\r
END;\r
END;\r
\r
BEGIN\r
\r
FOR i := 1 TO Max_TAB_pos DO\r
Next_TAB_pos[i] := i+1;\r
\r
line := l;\r
i := Pos('=', line);\r
IF i = 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
line := copy(line, i+1, 255);\r
\r
nxt := 0;\r
\r
WHILE ( nxt < Max_TAB_pos ) AND ( length(line) > 0 ) DO\r
BEGIN\r
k := 1;\r
IF line[1] = '*' THEN\r
k := 2;\r
\r
j := pos(',', line);\r
IF j = 0 THEN\r
j := length(line)+1;\r
Val( copy(line, k, j-k), no, code);\r
IF code <> 0 THEN\r
ReportError(' Table input illegal : '+ l);\r
line := copy(line, j+1, 255 );\r
\r
IF k = 2 THEN\r
BEGIN\r
IF ( no <= 0 ) OR ( next >= Max_TAB_pos ) THEN\r
ReportError(' Table input illegal : '+l);\r
WHILE nxt < Max_TAB_pos DO\r
BEGIN\r
settab(nxt + no);\r
nxt := nxt + no;\r
END\r
END\r
ELSE\r
BEGIN\r
IF no <= nxt THEN\r
ReportError(' Table input illegal : '+ l)\r
ELSE\r
BEGIN\r
settab(no);\r
nxt := no;\r
END;\r
END;\r
END { while };\r
\r
IF length(line) > 0 THEN\r
ReportError('Table input illegal : '+ l);\r
\r
IF test_requested THEN\r
FOR i := 1 TO max_TAB_pos DO\r
writeln('TAB info ', i:4, next_TAB_pos[i]:4 );\r
\r
END {decode_tab};\r
\r
\r
BEGIN\r
\r
IF ( '0'<= line[1]) AND ( line[1] <= '9') THEN\r
decode_chr( line )\r
ELSE\r
BEGIN\r
i := pos('=', line);\r
IF i = 0 THEN\r
i := length(line)+1;\r
tmp_line := copy(line, 1, i-1);\r
\r
CASE MatchOptionStr( tmp_line, 7, 'UNIQUE FOLD DELETE DETAB ') OF\r
\r
-1: ReportError(' Option not unique: '+ line);\r
\r
0: ReportError(' Option not found: '+ line);\r
\r
1: BEGIN\r
FOR i := 0 TO 255 DO\r
BEGIN\r
res_ch[i] := chr(i);\r
res_type[i] := cpy;\r
END;\r
res_ch[CRLF] := chr(CR) + chr(LF);\r
res_type[CRLF] := cpy;\r
res_ch[LFCR] := chr(LF) + chr(CR);\r
res_type[LFCR] := cpy;\r
res_ch[E_O_F] := '';\r
END;\r
\r
2: BEGIN\r
FOR i := 0 TO 255 DO\r
BEGIN\r
res_ch[i] := chr(i);\r
res_type[i] := cpy;\r
END;\r
FOR i := 128 TO 255 DO\r
res_ch[i] := chr(i-128);\r
\r
res_ch[CRLF] := chr(CR) + chr(LF);\r
res_type[CRLF] := cpy;\r
res_ch[LFCR] := chr(LF) + chr(CR);\r
res_type[LFCR] := cpy;\r
res_ch[E_O_F] := '';\r
END;\r
\r
3: BEGIN\r
FOR i := 0 TO 255 DO\r
BEGIN\r
res_ch[i] := '' ;\r
res_type[i] := cpy;\r
END;\r
res_ch[CRLF] := '' ;\r
res_type[CRLF] := cpy;\r
res_ch[LFCR] := '' ;\r
res_type[LFCR] := cpy;\r
res_ch[E_O_F] := '';\r
END;\r
\r
4: decode_tab( line);\r
\r
END { case };\r
END;\r
\r
END {Decode_line};\r
\r
PROCEDURE print_table(VAR f:text);\r
VAR\r
i, j, k: integer;\r
Detab_found: boolean;\r
\r
BEGIN\r
\r
Write(f, 'Constructed input Table, made at: ' );\r
printdate(f); Write(f, ' '); printtime(f); writeln(f);\r
Writeln(f, 'UNIQUE');\r
\r
Detab_found := false;\r
\r
i := 1; k := -1;\r
WHILE i < max_TAB_pos DO\r
BEGIN\r
IF ( next_TAB_pos[i] <> i + 1 ) AND ( next_TAB_pos[i] <= max_TAB_pos ) THEN\r
BEGIN\r
IF next_TAB_pos[i] <> k THEN\r
IF NOT Detab_found THEN\r
BEGIN\r
Write(f, 'DETAB = ' );\r
Detab_found := true;\r
write(f, next_TAB_pos[i]:4 );\r
END\r
ELSE\r
write(f, ',', next_TAB_pos[i]:4 );\r
k := next_TAB_pos[i];\r
\r
IF next_TAB_pos[i] < i THEN\r
ReportError('----- SYSTEM error ------ Next_TAB_pos ');\r
END;\r
i := i + 1;\r
END;\r
Writeln(f );\r
\r
FOR i := NUL TO LFCR DO\r
IF ( res_type[i] <> cpy ) OR ( length(res_ch[i]) <> 1 ) OR\r
( res_ch[i] <> chr(i) ) THEN\r
BEGIN\r
write(f, i:3, ' = ');\r
IF res_type[i] = cpy THEN\r
write(f, 'Copy ( ')\r
ELSE IF res_type[i] = tab THEN\r
write(f, 'Tab ( ')\r
ELSE\r
write(f, 'Stop ( ');\r
\r
FOR k := 1 TO length(res_ch[i]) DO\r
BEGIN\r
write(f, ord(res_ch[i,k]):3 );\r
IF k < length(res_ch[i]) THEN\r
write(f, ', ')\r
ELSE\r
write(f, ' ');\r
END;\r
writeln(f, ') ' );\r
END;\r
\r
END { Decode_line};\r
\r
\r
BEGIN { MAIN program }\r
\r
\r
read_callParameters;\r
\r
{ Preset table to work like COPY }\r
FOR i := 0 TO 255 DO\r
BEGIN\r
res_ch[i] := chr(i);\r
res_type[i] := cpy;\r
END;\r
\r
res_ch[CRLF] := chr(CR) + chr(LF);\r
res_type[CRLF] := cpy;\r
res_ch[LFCR] := chr(LF) + chr(CR);\r
res_type[LFCR] := cpy;\r
\r
res_ch[SUB] := chr(SUB);\r
res_type[SUB] := stop;\r
\r
res_ch[E_O_F] := '';\r
\r
FOR i := 1 TO Max_TAB_pos DO\r
Next_TAB_pos[i] := i + 1;\r
\r
IF OptionList[1].Defined THEN\r
BEGIN\r
{ Read in table_file, and install changes to table }\r
FileMode := FM_ReadOnly;\r
assign(tab_fil, Table_file);\r
reset(tab_fil);\r
\r
\r
WHILE NOT eof(tab_fil) DO\r
BEGIN\r
readln(tab_fil, line);\r
\r
tmp_line := UpperStr(line);\r
line := '';\r
FOR i := 1 TO length(tmp_line) DO\r
IF tmp_line[i] > chr(32) THEN\r
line := line + tmp_line[i];\r
\r
IF test_requested THEN\r
writeln('Table input: ', line);\r
\r
IF length(line) > 0 THEN\r
Decode_line( line);\r
\r
END {while};\r
END;\r
\r
{ Set length of part after last LF to negative value, or length of string }\r
FOR i := NUL TO LFCR DO\r
BEGIN\r
Pos_increment[i] := length( res_ch[i]);\r
IF pos(chr(LF), res_ch[i]) <> 0 THEN\r
BEGIN\r
tmp_line := res_ch[i];\r
REPEAT\r
k := pos(chr(LF), tmp_line);\r
tmp_line := copy( tmp_line, k+1, 255);\r
UNTIL pos(chr(LF), tmp_line) = 0;\r
\r
Pos_increment[i] := - ( length(tmp_line) + 1);\r
END;\r
END;\r
\r
IF test_requested THEN\r
print_table(output);\r
\r
res_type_cr := res_type[CR];\r
res_type[CR] := cr_found;\r
res_type_lf := res_type[LF];\r
res_type[LF] := lf_found;\r
\r
\r
FileMode := FM_Write;\r
assign(Out_fil, outpfile);\r
SetTextBuf(Out_fil, O_buff);\r
rewrite(Out_fil);\r
\r
out_pos := 1;\r
\r
WHILE GetByte(byt) DO\r
BEGIN\r
typ := res_type[byt];\r
\r
CASE typ OF\r
\r
cpy:\r
BEGIN\r
write(Out_fil, res_ch[byt]);\r
out_pos := out_pos + Pos_increment[byt];\r
IF Pos_increment[byt] < 0 THEN\r
out_pos := - Pos_increment[byt] { LF pressent in res_ch string };\r
END;\r
\r
stop:\r
BEGIN\r
write(Out_fil, res_ch[byt]);\r
GOTO 99;\r
END;\r
\r
tab:\r
BEGIN\r
IF ( out_pos < Max_TAB_pos ) AND ( Pos_increment[byt] > 0 ) THEN\r
BEGIN\r
Next := Next_TAB_pos[out_pos];\r
WHILE out_pos < next DO\r
BEGIN\r
write(Out_fil, res_ch[byt]);\r
out_pos := out_pos + Pos_increment[byt];\r
END;\r
END\r
ELSE\r
BEGIN { write translated string once }\r
write(Out_fil, res_ch[byt]);\r
out_pos := out_pos + Pos_increment[byt];\r
IF Pos_increment[byt] < 0 THEN\r
out_pos := - Pos_increment[byt] { LF pressent in res_ch string };\r
END;\r
END;\r
\r
cr_found:\r
BEGIN\r
IF LookAhead( tmp_byt ) AND ( tmp_byt = LF ) THEN\r
BEGIN\r
IF GetByte(byt) THEN ;\r
write(Out_fil, res_ch[CRLF]);\r
IF res_type[CRLF] = stop THEN GOTO 99;\r
out_pos := out_pos + Pos_increment[CRLF];\r
IF Pos_increment[CRLF] < 0 THEN\r
out_pos := - Pos_increment[CRLF] { LF pressent in res_ch string };\r
END\r
ELSE\r
BEGIN\r
write(Out_fil, res_ch[CR]);\r
IF res_type_cr = stop THEN GOTO 99;\r
out_pos := out_pos + Pos_increment[CR];\r
IF Pos_increment[CR] < 0 THEN\r
out_pos := - Pos_increment[CR] { LF pressent in res_ch string };\r
END;\r
END;\r
\r
lf_found:\r
BEGIN\r
IF LookAhead( byt ) AND ( byt = CR ) THEN\r
BEGIN\r
IF GetByte(byt) THEN ;\r
write(Out_fil, res_ch[LFCR]);\r
IF res_type[LFCR] = stop THEN GOTO 99;\r
out_pos := out_pos + Pos_increment[LFCR];\r
IF Pos_increment[LFCR] < 0 THEN\r
out_pos := - Pos_increment[LFCR] { LF pressent in res_ch string };\r
END\r
ELSE\r
BEGIN\r
write(Out_fil, res_ch[LF]);\r
IF res_type_lf = stop THEN GOTO 99;\r
out_pos := out_pos + Pos_increment[LF];\r
IF Pos_increment[LF] < 0 THEN\r
out_pos := - Pos_increment[LF] { LF pressent in res_ch string };\r
END;\r
END;\r
\r
\r
\r
ELSE\r
BEGIN\r
Writeln('--- System - E R R O R --- in type ', ord(typ));\r
END;\r
\r
END {case};\r
END {while};\r
\r
write(Out_fil, res_ch[E_O_F]);\r
\r
99:\r
close(Out_fil);\r
close(Source);\r
\r
END.\r
\r