|
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: 30267 (0x763b)
Types: TextFile
Names: »RTPSTD35.PAS«
└─⟦783187a02⟧ Bits:30010525 DVBS1.SW2114.src.2.6-3 RTP compiler source SW2104+SW2114 Disk#3 30/1-92 HHA
└─⟦this⟧ »RTPSTD\RTPSTD35.PAS«
└─⟦ca921ce75⟧ Bits:30010528 DVBS1.SW2114.src.2.6-6 RTP Compiler Source SW2104+SW2114 Disk 3 92.02.03 HEJ HHA
└─⟦this⟧ »RTPSTD\RTPSTD35.PAS«
program rtpstd35(input, output); \r
{$U+}\r
\r
{ This program will split RTP environment source to Transputer }\r
{ with open routine assembler code to environment and open routines }\r
\r
{ first parameter specify source file, default 'rtpstd35.scr' }\r
{ second parameter specify environment file, default 'rtpstd35.env' }\r
{ third parameter specify open routines file, default 'rtpope35.lib' }\r
\r
(* decoding rtp programs *)\r
type rtp_keyword_string = string[10];\r
\r
const\r
key_function = 0;\r
key_procedure = 1;\r
key_external = 2;\r
key_begin = 3;\r
key_and = 4;\r
key_code = 5;\r
key_comment1_start = 6;\r
key_comment1_end = 7;\r
key_comment2_start = 8;\r
key_comment2_end = 9;\r
key_comment3_start = 10;\r
\r
key_first = key_function;\r
key_last = key_comment3_start;\r
\r
key_last_name = key_code;\r
key_finis = 11;\r
\r
\r
const\r
code_record = 1;\r
finis_record = 2;\r
pushproc_record = 3;\r
jump_record = 4;\r
cjump_record = 5;\r
label_record = 6;\r
\r
\r
\r
var rtp_keywords: array[0..20] of rtp_keyword_string; \r
rtp_keyword_copy: array[0..20] of boolean;\r
rtp_line: string[128]; \r
\r
i: integer; \r
key: integer;\r
\r
rtp_in_routine: boolean;\r
\r
(* decoding T414 assampler code *) \r
const inst_length = 15;\r
type\r
instruction_string = string[inst_length];\r
hexstring = string[100];\r
alfastring = string[12];\r
var instructions: array[0..2000] of record\r
name: instruction_string;\r
code_value: integer;\r
direct: boolean;\r
cycles: integer;\r
end;\r
\r
next_instruction: integer;\r
\r
type bytefile = file of byte;\r
\r
var\r
src_name, env_name, ope_name, ope_tmp_name, lib_name: string[12];\r
src, env: text;\r
ope, ope_tmp: bytefile;\r
lib_file: bytefile;\r
\r
rtp35 : boolean; \r
end_inst, val_inst, opr_inst, pfix_inst, nfix_inst: integer;\r
push_proc_inst, cjump_inst, jump_inst, label_inst: integer;\r
opr_inst_val, pfix_inst_val, nfix_inst_val: integer;\r
instruction: instruction_string;\r
next_ch, lookahead_ch: char;\r
write_space: boolean;\r
\r
open_code: array[0..200] of 0..255;\r
open_address, last_open_address: integer;\r
open_code_address: integer;\r
open_entry: integer;\r
open_entries: array[0..100] of integer;\r
\r
next_def_label, next_use_label: integer;\r
def_label: array[0..20] of record\r
name: instruction_string; \r
where:integer;\r
end;\r
use_label: array[0..20] of record\r
where, size, def: integer;\r
end;\r
next_const: integer;\r
const_table: array[0..200] of record\r
name: instruction_string;\r
value: integer;\r
end;\r
\r
procedure error(s: hexstring; x: instruction_string; v: integer);\r
begin\r
writeln;\r
write('ERROR: ',s);\r
if x <> ' ' then write(' READ: "', x, '"');\r
if v <> 0 then write(' (',v:1,')');\r
writeln; \r
halt;\r
end;\r
\r
procedure write_int(var f: bytefile; i: integer);\r
var b: byte;\r
begin\r
b:= i AND 255;\r
write(f, b);\r
b:= i SHR 8;\r
write(f, b);\r
end;\r
\r
procedure write_byte(var f: bytefile; i: integer);\r
var b: byte;\r
begin\r
b:= i AND 255;\r
write(f, b);\r
end;\r
\r
procedure insert(n: instruction_string; c: integer; d: boolean; cyc: integer);\r
begin\r
if cyc >= 0 then\r
begin\r
with instructions[next_instruction] do\r
begin\r
name:= n;\r
code_value:= c;\r
direct:= d;\r
cycles:= cyc;\r
end;\r
next_instruction:= next_instruction + 1;\r
end;\r
end;\r
\r
function find(n: instruction_string): integer;\r
var i: integer;\r
begin\r
i:= 0;\r
while (i < next_instruction) and (instructions[i].name <> n) do\r
i:= i+1;\r
find:= i;\r
end;\r
\r
procedure init_instructions;\r
begin\r
\r
next_instruction:= 0;\r
\r
insert('end',0,false,0);\r
insert('val',0,false,0);\r
insert('pushproc',0,false,0);\r
insert('jump', 0, false, 0);\r
insert('cjump',0,false,0);\r
insert('label',0,false,0);\r
\r
(* direct instructions: 0 - 15, with argument *)\r
\r
insert('j',0,true,3);\r
insert('ldlp',1,true,1);\r
insert('pfix',2,true,1);\r
insert('ldnl',3,true,2);\r
\r
insert('ldc',4,true,1);\r
insert('ldnlp',5,true,1);\r
insert('nfix',6,true,1);\r
insert('ldl',7,true,2);\r
\r
insert('adc',8,true,1);\r
insert('call',9,true,7);\r
insert('cj',10,true,3);\r
insert('ajw',11,true,1);\r
\r
insert('eqc',12,true,2);\r
insert('stl',13,true,1);\r
insert('stnl',14,true,2);\r
insert('opr',15,true,0);\r
\r
(* oprator instruktions: 0 - 15 *)\r
\r
insert('rev',0,false,1);\r
insert('lb',1,false,5);\r
insert('bsub',2,false,1);\r
insert('endp',3,false,13);\r
\r
insert('diff',4,false,1);\r
insert('add',5,false,1);\r
insert('gcall',6,false,10);\r
insert('in',7,false,19);\r
\r
insert('prod',8,false,12);\r
insert('gt',9,false,1);\r
insert('wsub',10,false,2);\r
insert('out',11,false,19);\r
\r
insert('sub',12,false,1);\r
insert('startp',13,false,12);\r
insert('outbyt',14,false,23);\r
insert('outwor',15,false,23);\r
\r
(* oprator instruktions: 16 - 31 *)\r
\r
insert('seterr',16,false,1);\r
insert('#21#F1',17,false,-1);\r
insert('resetc',18,false,3);\r
insert('csub0',19,false,4);\r
\r
insert('#21#F4',20,false,-1);\r
insert('stopp',21,false,11);\r
insert('ladd',22,false,2);\r
insert('stlb',23,false,1);\r
\r
insert('sthf',24,false,1);\r
insert('norm',25,false,13);\r
insert('ldiv',26,false,35);\r
insert('ldpi',27,false,2);\r
\r
insert('stlf',28,false,1);\r
insert('xdble',29,false,2);\r
insert('ldpri',30,false,1);\r
insert('rem',31,false,37);\r
\r
(* oprator instruktions: 32 - 47 *)\r
\r
insert('ret',32,false,5);\r
insert('lend',33,false,10);\r
insert('ldtime',34,false,2);\r
insert('#22#F3',35,false,-1);\r
\r
insert('#22#F4',36,false,-1);\r
insert('#22#F5',37,false,-1);\r
insert('#22#F6',38,false,-1);\r
insert('#22#F7',39,false,-1);\r
\r
insert('#22#F8',40,false,-1);\r
insert('tester',41,false,3);\r
insert('testpr',42,false,2);\r
insert('tin',43,false,30);\r
\r
insert('div',44,false,39);\r
insert('#22#FD',45,false,-1);\r
insert('dist',46,false,23);\r
insert('disc',47,false,8);\r
\r
(* oprator instruktions: 48 - 63 *)\r
\r
insert('diss',48,false,4);\r
insert('lmul',49,false,33);\r
insert('not',50,false,1);\r
insert('xor',51,false,1);\r
\r
insert('bcnt',52,false,2);\r
insert('lshr',53,false,8);\r
insert('lshl',54,false,8);\r
insert('lsum',55,false,2);\r
\r
insert('lsub',56,false,2);\r
insert('runp',57,false,10);\r
insert('xword',58,false,4);\r
insert('sb',59,false,5);\r
\r
insert('gajw',60,false,2);\r
insert('savel',61,false,4);\r
insert('saveh',62,false,4);\r
insert('wcnt',63,false,5);\r
\r
(* oprator instruktions: 64 - 79 *)\r
\r
insert('shr',64,false,10);\r
insert('shl',65,false,10);\r
insert('mint',66,false,1);\r
insert('alt',67,false,2);\r
\r
insert('altwt',68,false,17);\r
insert('altend',69,false,4);\r
insert('and',70,false,1);\r
insert('enbt',71,false,8);\r
\r
insert('enbc',72,false,7);\r
insert('enbs',73,false,3);\r
insert('move',74,false,8);\r
insert('or',75,false,1);\r
\r
insert('csngl',76,false,3);\r
insert('ccnt1',77,false,3);\r
insert('talt',78,false,4);\r
insert('ldiff',79,false,2);\r
\r
(* oprator instruktions: 80 - 95 *)\r
\r
insert('sthb',80,false,1);\r
insert('taltwt',81,false,48);\r
insert('sum',82,false,1);\r
insert('mult',83,false,38);\r
\r
insert('sttime',84,false,1);\r
insert('stoper',85,false,2);\r
insert('cword',86,false,5);\r
insert('clther',87,false,1);\r
\r
insert('sthaer',88,false,1);\r
insert('tshaer',89,false,2);\r
insert('#25#FA',90,false,-1);\r
insert('#25#FB',91,false,-1);\r
\r
insert('#25#FC',92,false,-1);\r
insert('#25#FD',93,false,-1);\r
insert('#25#FE',94,false,-1);\r
insert('#25#FF',95,false,-1);\r
\r
end; \r
\r
function find_label(l: instruction_string): integer;\r
var i: integer;\r
begin\r
i:= 0;\r
def_label[next_def_label].name := l;\r
while def_label[i].name <> l do i:= i+1;\r
if i = next_def_label then \r
begin\r
def_label[i].where:= -1;\r
next_def_label:= next_def_label + 1;\r
end;\r
find_label:= i; \r
end;\r
\r
function find_const: integer;\r
var i: integer;\r
begin\r
i:= 0;\r
const_table[next_const].name:= instruction;\r
while const_table[i].name <> instruction do i:= i + 1;\r
if i = next_const then error('undefined constant', instruction, 0);\r
find_const:= const_table[i].value;\r
end;\r
\r
function hex(number,digits: integer): hexstring;\r
const\r
hexdigit: array[0..15] of char = '0123456789ABCDEF';\r
var\r
d: integer;\r
h: hexstring;\r
begin\r
h[0]:=chr(digits);\r
for d:=digits downto 1 do\r
begin\r
h[d]:=hexdigit[number and 15];\r
number:=number SHR 4;\r
end;\r
hex:=h;\r
end;\r
\r
function invershex(h: hexstring): hexstring;\r
var\r
i: byte;\r
begin\r
for i:=1 to ord(h[0]) do\r
case h[i] of\r
'0': h[i] := 'F'; '1': h[i] := 'E'; '2': h[i] := 'D'; '3': h[i] := 'C';\r
'4': h[i] := 'B'; '5': h[i] := 'A'; '6': h[i] := '9'; '7': h[i] := '8';\r
'8': h[i] := '7'; '9': h[i] := '6'; 'A': h[i] := '5'; 'B': h[i] := '4';\r
'C': h[i] := '3'; 'D': h[i] := '2'; 'E': h[i] := '1'; 'F': h[i] := '0';\r
end;\r
for i:=ord(h[0])+1 to 8 do h:= 'F' + h;\r
invershex:= h;\r
end; \r
\r
procedure read_src(var ch: char);\r
begin\r
(*\r
if next_ch = ' ' then begin next_ch:= lookahead_ch; lookahead_ch:= ' ' end;\r
*)\r
if next_ch = ' ' then\r
begin \r
if eof(src) then error('end of file', instruction, 0);\r
read(src, ch);\r
if ('a' <= ch) and ( ch <= 'z') then\r
else if ('A' <= ch) and ( ch <= 'Z') then ch:= chr( ord(ch) - ord('A') + ord('a') )\r
else if ('0' <= ch) and ( ch <= '9') then \r
else if (ch <> ':') and (ch <> '-') then\r
begin\r
if rtp35 then\r
begin\r
if ch <> '_' then ch:= ' ';\r
end else\r
if ch <> '.' then ch := ' ';\r
end;\r
if ch <> ' ' then \r
begin \r
(* ! * ) write(ch); (**) \r
write_space:= false;\r
end else\r
if not write_space then \r
begin \r
(* ! * ) write(' '); (**)\r
write_space:= true; \r
end; \r
end else\r
begin\r
(* ! * ) write('?',next_ch,'?'); (**)\r
ch:= next_ch;\r
next_ch:= ' ';\r
end;\r
\r
if false and ( ch='-') then begin\r
read(src, ch);\r
if ch='-' then begin readln( src ); ch:=' ' end\r
else begin \r
(* ! * ) \r
writeln;\r
writeln('LOOKAHEAD'); \r
(**)\r
lookahead_ch:= ch; ch:= '-' end;\r
end; \r
end;\r
\r
procedure skip;\r
var ch: char;\r
begin\r
repeat\r
read_src(ch);\r
until ch <> ' ';\r
(* ! * ) if ch='i' then write('SKIP'); (**)\r
next_ch:= ch;\r
end; \r
\r
procedure read_label;\r
var ch: char;\r
i: integer;\r
def: boolean;\r
begin\r
next_ch:= ' ';\r
instruction[0]:= chr(inst_length);\r
i:= 0;\r
repeat\r
i:= i + 1;\r
read_src(ch);\r
if i <= inst_length then\r
instruction[i]:= ch;\r
until (((ch < 'a') or (ch > 'z')) and (ch <> '.') and\r
((ch < '0') or (ch > '9')));\r
if i < inst_length then begin\r
delete(instruction, i, inst_length);\r
end;\r
(* ! * ) if ch='i' then write('READ LABEL'); (**)\r
next_ch:= ch;\r
end; \r
\r
procedure read_def_label;\r
var i:integer;\r
begin\r
read_label;\r
i:= find_label(instruction);\r
if def_label[i].where <> -1 then error('def label already used', instruction, next_use_label) else\r
def_label[i].where:= open_address;\r
end;\r
\r
procedure read_use_label;\r
var i:integer;\r
begin\r
read_label;\r
i:= find_label(instruction);\r
with use_label[next_use_label] do\r
begin\r
where:= open_address;\r
size:= 8;\r
open_address:= open_address + 7;\r
def:= i;\r
end;\r
next_use_label:= next_use_label + 1;\r
end;\r
\r
procedure read_name;\r
var ch: char;\r
i: integer;\r
name_char : char;\r
begin\r
if rtp35 then name_char:= '_' else name_char:= '.';\r
instruction[0]:= chr(inst_length);\r
i:= 0;\r
repeat\r
i:= i + 1;\r
read_src(ch);\r
(* ! * ) write(ch); (**)\r
if i <= inst_length then\r
instruction[i]:= ch;\r
until ((ch <> name_char)\r
and ((ch < 'a') or (ch > 'z'))) and ((ch < '0') or (ch > '9'));\r
if i < inst_length then begin\r
delete(instruction, i, inst_length);\r
end;\r
(* ! * ) if ch='i' then write('READ NAME'); (**)\r
next_ch:= ch;\r
writeln(instruction);\r
end; \r
\r
\r
\r
function read_instruction: integer;\r
begin\r
skip;\r
while next_ch = ':' do\r
begin\r
read_def_label;\r
skip;\r
end;\r
read_name;\r
read_instruction:= find( instruction );\r
end; \r
\r
function read_const_argument: integer;\r
var ch: char;\r
i, p: integer;\r
begin\r
skip;\r
instruction[0]:= chr(inst_length);\r
i:= 0;\r
repeat\r
i:= i + 1;\r
read_src(ch);\r
if i <= inst_length then \r
instruction[i]:= ch;\r
until (((ch < '0') or (ch > '9')) and (ch <> '-'));\r
if i < inst_length then begin\r
delete(instruction, i, inst_length);\r
end;\r
(* ! * ) if ch='i' then write('READ CONST ARG'); (**)\r
next_ch:= ch;\r
val( instruction, i, p );\r
if p <> 0 then begin\r
if rtp35 then else error('illegal argument', instruction, p);\r
read_const_argument:= 0;\r
end else read_const_argument:= i;\r
end;\r
\r
\r
function read_argument: integer;\r
var ch: char;\r
i, p: integer;\r
begin\r
skip;\r
if next_ch = '.' then \r
begin \r
read_use_label;\r
read_argument:= 0;\r
end else \r
if ('a' <= next_ch) and (next_ch <= 'z') then begin\r
read_name;\r
read_argument:= find_const; \r
end else read_argument:= read_const_argument;\r
end;\r
\r
procedure dump_code_arg(code_val, argument: integer);\r
var i, four_bit, ignore: integer;\r
nfix, started: boolean;\r
begin\r
if argument < 0 then ignore:= 15 else ignore:= 0;\r
for i:= 3 downto 1 do\r
begin\r
four_bit:= (argument shr (i*4)) AND 15;\r
if four_bit <> ignore then\r
begin\r
if ignore <> 15 then dump_code_arg(pfix_inst_val, four_bit) else\r
begin\r
dump_code_arg(nfix_inst_val, 16 - four_bit);\r
ignore:= -1;\r
end;\r
end;\r
end;\r
if ignore = 15 then dump_code_arg(nfix_inst_val, 0);\r
open_code[open_address]:= code_val * 16 + (argument and 15 );\r
(* ! * ) write(' ',hex(open_code[open_address],2)); (**)\r
open_address:= open_address + 1;\r
end;\r
\r
procedure check_labels;\r
var i, j, adjust_size:integer;\r
ok: boolean;\r
inst_val: integer;\r
begin\r
for j:=0 to next_def_label-1 do\r
if def_label[j].where = -1 then error('undefined label', def_label[j].name, 0); \r
repeat\r
ok:= true;\r
for i:=0 to next_use_label-1 do\r
with use_label[i] do\r
begin\r
inst_val:= open_code[ where + size - 1] SHR 4;\r
open_address:= where;\r
dump_code_arg(inst_val, def_label[ def ].where - where - size);\r
adjust_size:= where + size - open_address;\r
if adjust_size > 0 then\r
begin\r
ok:= false;\r
size:= size - adjust_size;\r
for j:= i + 1 to next_use_label - 1 do\r
use_label[j].where:= use_label[j].where - adjust_size;\r
for j:= 0 to next_def_label - 1 do\r
with def_label[j] do\r
if where >= open_address then \r
where:= where - adjust_size; \r
for j:= open_address + adjust_size to last_open_address do\r
open_code[j-adjust_size]:= open_code[j];\r
last_open_address:= last_open_address - adjust_size;\r
end; \r
end;\r
until ok;\r
end;\r
\r
procedure read_const;\r
var i:integer;\r
begin\r
read_label;\r
with const_table[next_const] do\r
begin\r
write(' VAL: ');\r
name:=instruction;\r
write(instruction, ',');\r
i:= read_instruction; (* skip IS *)\r
write(instruction, ',');\r
i:= read_const_argument;\r
value:= i;\r
writeln(instruction, ',', i:1);\r
end;\r
next_const:= next_const + 1;\r
if next_ch <> ':' then\r
repeat\r
next_ch:= ' ';\r
skip;\r
until next_ch=':';\r
next_ch:= ' ';\r
end;\r
\r
procedure dump_code_record;\r
begin\r
if open_address > 0 then begin\r
write_byte( ope_tmp, code_record );\r
write_byte( ope_tmp, open_address );\r
for i:=0 to open_address - 1\r
do write(ope_tmp, open_code[i]);\r
open_code_address:= open_code_address + 2 + open_address;\r
open_address:= 0;\r
end;\r
end; \r
\r
procedure dump_pushproc;\r
begin\r
dump_code_record;\r
write_byte( ope_tmp, pushproc_record );\r
open_code_address:= open_code_address + 1;\r
end; \r
\r
procedure dump_finis;\r
begin\r
dump_code_record;\r
write_byte( ope_tmp, finis_record );\r
(* ! *) writeln(' dump finis '); (**)\r
open_code_address:= open_code_address + 1;\r
end; \r
\r
procedure dump_cjump( no: integer ) ;\r
begin\r
dump_code_record;\r
write_byte( ope_tmp, cjump_record );\r
write_byte( ope_tmp, no );\r
open_code_address:= open_code_address + 2;\r
end; \r
\r
procedure dump_jump( no: integer ) ;\r
begin\r
dump_code_record;\r
write_byte( ope_tmp, jump_record );\r
write_byte( ope_tmp, no );\r
open_code_address:= open_code_address + 2;\r
end; \r
\r
procedure dump_label( no: integer ) ;\r
begin\r
dump_code_record;\r
write_byte( ope_tmp, label_record );\r
write_byte( ope_tmp, no );\r
open_code_address:= open_code_address + 2;\r
end; \r
\r
\r
procedure read_code_lines( routine_code: boolean );\r
var instruction_index, inst_val, argument: integer;\r
i: integer;\r
begin\r
next_use_label:= 0;\r
next_def_label:= 0;\r
repeat\r
(* ! * ) writeln; (**)\r
write_space:= true;\r
instruction_index:= read_instruction;\r
if instruction_index = next_instruction \r
then error('unknown instruction', instruction, 0) else\r
if instruction_index = val_inst then begin\r
read_const;\r
end else\r
if instruction_index = push_proc_inst then begin\r
dump_pushproc; \r
end else\r
if instruction_index = cjump_inst then begin\r
i:= read_const_argument;\r
dump_cjump( i ); \r
end else\r
if instruction_index = jump_inst then begin\r
i:= read_const_argument;\r
dump_jump( i ); \r
end else\r
if instruction_index = label_inst then begin\r
i:= read_const_argument;\r
dump_label( i );\r
end else\r
if instruction_index <> end_inst then\r
begin\r
with instructions[instruction_index] do\r
begin\r
if direct then \r
begin\r
inst_val:= instructions[ instruction_index].code_value; \r
argument:= read_argument;\r
end else begin\r
inst_val:= opr_inst_val;\r
argument:= code_value;\r
end;\r
end;\r
dump_code_arg( inst_val, argument );\r
end;\r
until instruction_index = end_inst;\r
last_open_address:= open_address - 1;\r
check_labels;\r
(* ! * ) writeln; write(' code to open routine ');\r
for i:=0 to last_open_address do\r
begin\r
if i mod 10 = 0 then writeln;\r
write(' ',hex(open_code[i],2));\r
end; (**)\r
open_address:= last_open_address + 1;\r
if routine_code then dump_finis;\r
end;\r
\r
procedure readlibname(var s: alfastring);\r
var i : integer;\r
b : byte;\r
begin\r
s := '';\r
for i := 1 to 12 do \r
begin\r
read(lib_file, b);\r
s := s + chr(b);\r
end;\r
end;\r
\r
procedure readlibint(var i : integer);\r
var b, b1: byte;\r
begin\r
if eof(lib_file) then i := 0 else\r
begin\r
read(lib_file, b);\r
read(lib_file,b1);\r
i := b1 + (b shl 8);\r
end;\r
end;\r
\r
procedure read_code35(no : integer; save : boolean);\r
var i : integer;\r
b : byte;\r
begin\r
open_address := 0;\r
for i := 1 to no do\r
begin\r
read(lib_file, b);\r
if (i > 16) and (save) then \r
begin\r
open_code[open_address] := b;\r
open_address := open_address + 1;\r
end;\r
end;\r
end;\r
\r
procedure read_proc_parameters;\r
var open_name, libprocname : alfastring;\r
parameters, libprocparameters : array[0..40] of integer;\r
i, openparameters, libparameters: integer;\r
descr_length, no_of_pages, page_size, last_page_length,\r
kind, dummy, j, code_length: integer;\r
first_on_lib : boolean;\r
begin\r
read_name;\r
open_name := instruction + ' ';\r
i := 0;\r
repeat\r
(* ! * ) writeln; (**)\r
write_space:= true;\r
parameters[i] := read_const_argument;\r
i := i+1;\r
until instruction = '';\r
openparameters := (i-1)div 2;\r
if parameters[0] <> openparameters then\r
begin\r
writeln(' parameter specification error ', parameters[0],\r
' ', openparameters);\r
halt;\r
end;\r
repeat \r
i := read_instruction;\r
until i = end_inst;\r
\r
reset(lib_file);\r
first_on_lib := true;\r
readlibint(descr_length);\r
while descr_length > 0 do\r
begin\r
readlibint(no_of_pages);\r
readlibint(page_size);\r
readlibint(last_page_length);\r
readlibint(kind);\r
readlibname(libprocname);\r
for i := 1 to 10 do readlibint(dummy);\r
readlibint(libparameters);\r
libprocparameters[0] := libparameters;\r
for i := 1 to libparameters*2 do readlibint(libprocparameters[i]);\r
if open_name <> libprocname then libparameters := openparameters+1;\r
if (openparameters = libparameters) then\r
begin\r
for i := 0 to openparameters do\r
if parameters[i] <> libprocparameters[i] then\r
libparameters := openparameters+1;\r
end;\r
\r
read_code35((no_of_pages-1)*page_size+last_page_length,\r
libparameters = openparameters);\r
\r
readlibint(kind);\r
for i := 1 to kind do\r
begin (* skip external uses *)\r
readlibname(libprocname);\r
readlibint(no_of_pages);\r
for j := 1 to no_of_pages*2 do readlibint(dummy);\r
readlibint(no_of_pages);\r
for j := 1 to no_of_pages*2 do readlibint(dummy);\r
end; \r
readlibint(no_of_pages);\r
for j := 1 to no_of_pages do\r
begin\r
readlibint(dummy);\r
if dummy <> 1 then\r
begin \r
writeln('more than one page'); halt;\r
end;\r
readlibint(i);\r
readlibint(dummy);\r
readlibint(dummy);\r
if i = 14 then\r
begin\r
open_address := dummy-16;\r
if first_on_lib then open_address := open_address-4; (* FUSK *)\r
end;\r
end; \r
first_on_lib := false; \r
if libparameters = openparameters then\r
begin (* open routine found *)\r
writeln(' open routine found ');\r
descr_length := 0;\r
end else \r
begin\r
open_address := 0;\r
end;\r
if descr_length > 0 then\r
begin\r
readlibint(descr_length);\r
if descr_length <= 0 then writeln('not found'); \r
end;\r
end;\r
\r
last_open_address:= open_address - 1;\r
(* ! *) writeln; write(' code to open routine ');\r
for i:=0 to last_open_address do\r
begin\r
if i mod 10 = 0 then writeln;\r
write(' ',hex(open_code[i],2));\r
end; (**)\r
open_address:= last_open_address + 1;\r
dump_code_record;\r
dump_finis;\r
end;\r
\r
procedure dump_ope;\r
var i:integer;\r
b: byte;\r
begin\r
reset(ope_tmp);\r
write_int(ope, open_code_address + open_entry * 2);\r
for i:= 0 to open_entry-1 do\r
write_int(ope, open_entry * 2 + open_entries[i]);\r
for i:= 1 to open_code_address do\r
begin\r
read(ope_tmp, b);\r
write(ope, b);\r
end;\r
end;\r
\r
(* rtp *)\r
\r
procedure rtp_keyword_init;\r
var i: integer;\r
begin\r
for i:= key_first to key_last do\r
begin\r
rtp_keywords[ i ]:= '';\r
rtp_keyword_copy[ i ]:= true;\r
end;\r
rtp_keywords[ key_function ]:= 'function';\r
rtp_keywords[ key_procedure ]:= 'procedure';\r
rtp_keywords[ key_external ]:= 'external';\r
rtp_keywords[ key_begin ] := 'begin';\r
rtp_keyword_copy[ key_begin ] := false;\r
rtp_keywords[ key_and ] := 'and';\r
rtp_keyword_copy[ key_and ] := false;\r
rtp_keywords[ key_code ] := 'code';\r
rtp_keyword_copy[ key_code ] := false;\r
rtp_keywords[ key_comment1_start ] := '(*';\r
rtp_keywords[ key_comment1_end ] := '*)';\r
rtp_keywords[ key_comment2_start ] := '<*';\r
rtp_keywords[ key_comment2_end ] := '*>';\r
rtp_keywords[ key_comment3_start ] := '--';\r
rtp_keywords[ key_finis ] := ' ';\r
end;\r
\r
function is_alfanum(ch: char): boolean;\r
begin\r
is_alfanum:= (('a' <= ch) and (ch <= 'z')) or\r
(('0' <= ch) and (ch <= '9'));\r
end;\r
\r
function is_rtp_keyword(i, p: integer):boolean;\r
var ok: boolean;\r
np: integer;\r
begin\r
ok:= true;\r
if p > 1 then ok:= not is_alfanum(rtp_line[p-1]);\r
np:= p + len(rtp_keywords[i]);\r
if np <= len(rtp_line) then ok:= not is_alfanum(rtp_line[np])\r
else ok:= eoln(src);\r
ok:= ok or (i > key_last_name);\r
(* ! * ) if not ok then begin\r
writeln;\r
writeln('-KEYWORD: ',i,' ',p,' ',np,' "',rtp_keywords[i],'" "',rtp_line,'"');\r
end; (**)\r
is_rtp_keyword:= ok;\r
end;\r
\r
procedure convert_rtp_line;\r
var i:integer;\r
ch: char;\r
begin\r
for i:=1 to len(rtp_line) do\r
begin\r
ch:= rtp_line[i];\r
if ('A' <= ch) and (ch <= 'Z') then rtp_line[i]:= chr( ord(ch) - ord('A') + ord('a'));\r
end;\r
end;\r
\r
function next_rtp_keyword: integer;\r
var help_line: string[64];\r
key_pos, key, i, p: integer;\r
begin\r
repeat\r
if len(rtp_line) = 0 then\r
begin\r
if eoln(src) then begin readln(src); writeln(env); end;\r
read(src, rtp_line);\r
convert_rtp_line;\r
(* ! * ) write('=', rtp_line); (**)\r
end else\r
if (len(rtp_line) <= 64) and (not eoln(src)) then\r
begin\r
read(src, help_line);\r
(* ! * ) write('*',help_line); (**) \r
rtp_line:= concat( rtp_line, help_line );\r
convert_rtp_line;\r
end;\r
key_pos:= maxint;\r
for i:= key_first to key_last do\r
begin\r
p:= pos( rtp_keywords[i], rtp_line );\r
if (p <> 0) and (p < key_pos)\r
then begin\r
if is_rtp_keyword(i, p) then\r
begin key_pos:= p; key:= i; end;\r
end;\r
end;\r
if key_pos = maxint then\r
begin\r
write(env, rtp_line);\r
if eof(src) then begin\r
key_pos:= 0;\r
key:= key_finis;\r
end else read(src, rtp_line);\r
end;\r
until key_pos < maxint;\r
next_rtp_keyword:= key;\r
p:= key_pos + len( rtp_keywords[ key ] );\r
if rtp_keyword_copy[ key ] \r
then write(env, copy( rtp_line, 1, p - 1))\r
else write(env, copy( rtp_line, 1, key_pos - 1));\r
delete( rtp_line, 1, p - 1 );\r
end;\r
\r
procedure rtp_skip_line(print: boolean);\r
begin\r
while not eoln(src) do\r
begin\r
if print then write(env, rtp_line);\r
read(src, rtp_line);\r
end;\r
readln(src);\r
if print then writeln(env, rtp_line);\r
rtp_line:= '';\r
end;\r
\r
\r
begin\r
write_space:= false;\r
open_address:= 0;\r
rtp35:= false;\r
if argcnt >= 1 then\r
begin\r
if argstr(1) = '35' then\r
begin\r
rtp35 := true;\r
open_address := 1;\r
end else if argstr(1) = '50' then\r
begin\r
open_address:= 1;\r
end;\r
end;\r
if argcnt>open_address+3 then\r
begin\r
writeln('Syntax: RTPSTD [35/50] [source-file [envirement-file [openroutines-file]]]'); \r
halt;\r
end;\r
if rtp35 then\r
begin\r
src_name:= 'rtpstd35.src';\r
env_name:= 'rtpstd35.env';\r
ope_name:= 'rtpope35.lib';\r
end else\r
begin\r
src_name:= 'rtpstd50.src';\r
env_name:= 'rtpstd50.env';\r
ope_name:= 'rtpope50.lib';\r
end;\r
ope_tmp_name:= 'rtpstd.tmp';\r
if argcnt >= open_address+1 then\r
begin\r
src_name:= argstr(1+open_address);\r
end;\r
if argcnt >= open_address+2 then\r
begin\r
env_name:= argstr(2+open_address);\r
end;\r
if argcnt >= open_address+3 then\r
begin\r
ope_name:= argstr(3+open_address);\r
end;\r
\r
assign(src,src_name); {$I-} reset(src) {$I+};\r
if iores>0 then\r
begin\r
writeln('SRC: "',src_name,'" does not exist'); halt;\r
end;\r
\r
if rtp35 then\r
begin\r
lib_name := ope_name;\r
open_address:= len(lib_name);\r
while open_address > 0 do\r
if lib_name[open_address] = '.' then open_address := 0 else\r
begin\r
delete(lib_name, open_address, 1);\r
open_address := open_address - 1;\r
end;\r
lib_name := lib_name+'src';\r
assign(lib_file,lib_name); {$I-} reset(lib_file) {$I+};\r
if iores>0 then\r
begin\r
writeln('LIB: "',lib_name,'" does not exist'); halt;\r
end;\r
end;\r
assign(env,env_name); rewrite(env);\r
assign(ope,ope_name); rewrite(ope);\r
assign(ope_tmp, ope_tmp_name); rewrite(ope_tmp);\r
next_ch:= ' ';\r
lookahead_ch:= ' ';\r
init_instructions;\r
opr_inst:= find('opr');\r
pfix_inst:= find('pfix');\r
nfix_inst:= find('nfix'); \r
end_inst:= find('end');\r
val_inst:= find('val');\r
push_proc_inst:= find('pushproc');\r
cjump_inst:= find('cjump');\r
jump_inst:= find('jump');\r
label_inst:= find('label');\r
opr_inst_val:= instructions[ opr_inst ].code_value;\r
pfix_inst_val:= instructions[ pfix_inst ].code_value;\r
nfix_inst_val:= instructions[ nfix_inst ].code_value;\r
next_const:= 0;\r
\r
open_address:= 0;\r
open_code_address:= 0; \r
open_entry:= 0;\r
\r
rtp_in_routine:= false;\r
rtp_keyword_init;\r
rtp_line:='';\r
repeat\r
key:= next_rtp_keyword;\r
case key of\r
key_function, key_procedure: rtp_in_routine:= true; \r
key_external: rtp_in_routine:= false;\r
key_code: read_code_lines( false );\r
key_begin: begin\r
write('.');\r
rtp_skip_line(false);\r
writeln(env,'openroutine;');\r
open_entries[ open_entry ]:= open_code_address;\r
(* ! *) writeln( 'open code address: ', open_code_address:1); (**)\r
if rtp35 then read_proc_parameters else read_code_lines( true );\r
open_entry:= open_entry + 1; \r
end;\r
key_and: if rtp_in_routine then begin\r
rtp_skip_line(false);\r
writeln(env,'openroutine;');\r
open_entries[ open_entry ]:= open_code_address;\r
(* ! *) writeln( 'open code address: ', open_code_address:1); (**)\r
open_entry:= open_entry + 1;\r
end;\r
key_finis: ;\r
key_comment1_start: repeat\r
key:= next_rtp_keyword;\r
until (key = key_comment1_end) or (key = key_finis);\r
key_comment2_start: repeat\r
key:= next_rtp_keyword;\r
until (key = key_comment2_end) or (key = key_finis);\r
key_comment3_start: rtp_skip_line(true);\r
otherwise ;\r
end;\r
until key=key_finis; \r
\r
dump_ope;\r
\r
close(src);\r
close(env);\r
close(ope);\r
\r
\r
END.\r