Program rtpstd35(input, output);
{$U+    dollar U is illegal in TURBO Pascal  }

{ (C) Copyrigth  1992   DANOSI     }

{ This program will split RTP environment source and library source   }
{ with open routine assembler code to environment and open routines   }

{ first parameter specify source file,        default 'rtpstd35.scr'  }
{ second parameter specify environment file,  default 'rtpstd35.env'  }
{ third parameter specify open routines file, default 'rtpope35.lib'  }

{ File with open routines, compiled RC8000,           'rtpope35.src'  }

{---------------------------------------------------------------
--
--   90.06.09   1.1   EBK   Program RTPSTD35
--   92.06.16   1.2   HEJ   Room for 140 open routines, list of not found.
--   92.08.14   1.3   BB    If a recordfield name ends with an RTP
--                          keyword and the following char was not an
--                          alfanumeric, the whole fieldname xxx<RTPkey>
--                          was doomed an RTPkeyword
--   92.08.20   1.4   BB    Increased size of open routines body from 200
--                          to 400 bytes
--   92.08.24   1.5   BB    Room for 200 open routines.
--
--
--
----------------------------------------------------------------
}

(* decoding rtp programs *)
type rtp_keyword_string = string[10];

const
  key_function = 0;
  key_procedure = 1;
  key_external = 2;
  key_begin = 3;
  key_and = 4;
  key_code = 5;
  key_comment1_start = 6;
  key_comment1_end = 7;
  key_comment2_start = 8;
  key_comment2_end = 9;
  key_comment3_start = 10;

  key_first = key_function;
  key_last = key_comment3_start;

  key_last_name = key_code;
  key_finis = 11;


const
     code_record = 1;
     finis_record = 2;
     pushproc_record = 3;
     jump_record = 4;
     cjump_record = 5;
     label_record = 6;

     max_nf_cnt   = 20;


var  rtp_keywords: array[0..20] of rtp_keyword_string;
     rtp_keyword_copy: array[0..20] of boolean;
     rtp_line: string[128];  

     i: integer; 
     key: integer;
     
     rtp_in_routine: boolean;

(* decoding T414 assampler code *)  
const inst_length = 15;
type
  instruction_string = string[inst_length];
  hexstring = string[100];
  alfastring = string[12];
var instructions: array[0..2000] of record
                    name: instruction_string;
                    code_value: integer;
                    direct: boolean;
                    cycles: integer;
                  end;

    next_instruction: integer;

type bytefile = file of byte;

var
    src_name, env_name, ope_name, ope_tmp_name, lib_name: string[12];
    src, env: text;
    ope, ope_tmp: bytefile;
    lib_file: bytefile;

    rtp35 : boolean;
    end_inst, val_inst, opr_inst, pfix_inst, nfix_inst: integer;
    push_proc_inst, cjump_inst, jump_inst, label_inst: integer;
    opr_inst_val, pfix_inst_val, nfix_inst_val: integer;
    instruction: instruction_string;
    next_ch, lookahead_ch: char;
    write_space: boolean;

    nf_cnt   : integer;
    notfound : array [ 1..max_nf_cnt ] of alfastring;
    
    open_code: array[0..400] of 0..255;
    open_address, last_open_address: integer;
    open_code_address: integer;
    open_entry: integer;
    open_entries: array[0..2000] of integer;

    next_def_label, next_use_label: integer;
    def_label: array[0..20] of record
                 name: instruction_string;
                 where:integer;
               end;
    use_label: array[0..20] of record
                 where, size, def: integer;
               end;
    next_const: integer;
    const_table: array[0..200] of record
                   name: instruction_string;
                   value: integer;
                 end;

procedure error(s: hexstring; x: instruction_string; v: integer);
begin
  writeln;
  write('ERROR: ',s);
  if x <> '      ' then write('   READ: "', x, '"');
  if v <> 0 then write('   (',v:1,')');
  writeln;
  halt;
end;

procedure write_int(var f: bytefile; i: integer);
var b: byte;
begin
  b:= i AND 255;
  write(f, b);
  b:= i SHR 8;
  write(f, b);
end;

procedure write_byte(var f: bytefile; i: integer);
var b: byte;
begin
  b:= i AND 255;
  write(f, b);
end;

procedure insert(n: instruction_string; c: integer; d: boolean; cyc: integer);
begin
  if cyc >= 0 then
  begin
    with instructions[next_instruction] do
    begin
      name:= n;
      code_value:= c;
      direct:= d;
      cycles:= cyc;
    end;
    next_instruction:= next_instruction + 1;
  end;
end;

function find(n: instruction_string): integer;
var i: integer;
begin
  i:= 0;
  while (i < next_instruction) and (instructions[i].name <> n) do
    i:= i+1;
  find:= i;
end;

procedure init_instructions;
begin

  next_instruction:= 0;

  insert('end',0,false,0);
  insert('val',0,false,0);
  insert('pushproc',0,false,0);
  insert('jump', 0, false, 0);
  insert('cjump',0,false,0);
  insert('label',0,false,0);

    (* direct instructions: 0 - 15, with argument *)

  insert('j',0,true,3);
  insert('ldlp',1,true,1);
  insert('pfix',2,true,1);
  insert('ldnl',3,true,2);

  insert('ldc',4,true,1);
  insert('ldnlp',5,true,1);
  insert('nfix',6,true,1);
  insert('ldl',7,true,2);

  insert('adc',8,true,1);
  insert('call',9,true,7);
  insert('cj',10,true,3);
  insert('ajw',11,true,1);

  insert('eqc',12,true,2);
  insert('stl',13,true,1);
  insert('stnl',14,true,2);
  insert('opr',15,true,0);

    (* oprator instruktions: 0 - 15 *)

  insert('rev',0,false,1);
  insert('lb',1,false,5);
  insert('bsub',2,false,1);
  insert('endp',3,false,13);

  insert('diff',4,false,1);
  insert('add',5,false,1);
  insert('gcall',6,false,10);
  insert('in',7,false,19);

  insert('prod',8,false,12);
  insert('gt',9,false,1);
  insert('wsub',10,false,2);
  insert('out',11,false,19);

  insert('sub',12,false,1);
  insert('startp',13,false,12);
  insert('outbyt',14,false,23);
  insert('outwor',15,false,23);

    (* oprator instruktions: 16 - 31 *)

  insert('seterr',16,false,1);
  insert('#21#F1',17,false,-1);
  insert('resetc',18,false,3);
  insert('csub0',19,false,4);

  insert('#21#F4',20,false,-1);
  insert('stopp',21,false,11);
  insert('ladd',22,false,2);
  insert('stlb',23,false,1);

  insert('sthf',24,false,1);
  insert('norm',25,false,13);
  insert('ldiv',26,false,35);
  insert('ldpi',27,false,2);

  insert('stlf',28,false,1);
  insert('xdble',29,false,2);
  insert('ldpri',30,false,1);
  insert('rem',31,false,37);

    (* oprator instruktions: 32 - 47 *)

  insert('ret',32,false,5);
  insert('lend',33,false,10);
  insert('ldtime',34,false,2);
  insert('#22#F3',35,false,-1);

  insert('#22#F4',36,false,-1);
  insert('#22#F5',37,false,-1);
  insert('#22#F6',38,false,-1);
  insert('#22#F7',39,false,-1);

  insert('#22#F8',40,false,-1);
  insert('tester',41,false,3);
  insert('testpr',42,false,2);
  insert('tin',43,false,30);

  insert('div',44,false,39);
  insert('#22#FD',45,false,-1);
  insert('dist',46,false,23);
  insert('disc',47,false,8);

    (* oprator instruktions: 48 - 63 *)

  insert('diss',48,false,4);
  insert('lmul',49,false,33);
  insert('not',50,false,1);
  insert('xor',51,false,1);

  insert('bcnt',52,false,2);
  insert('lshr',53,false,8);
  insert('lshl',54,false,8);
  insert('lsum',55,false,2);

  insert('lsub',56,false,2);
  insert('runp',57,false,10);
  insert('xword',58,false,4);
  insert('sb',59,false,5);

  insert('gajw',60,false,2);
  insert('savel',61,false,4);
  insert('saveh',62,false,4);
  insert('wcnt',63,false,5);

    (* oprator instruktions: 64 - 79 *)

  insert('shr',64,false,10);
  insert('shl',65,false,10);
  insert('mint',66,false,1);
  insert('alt',67,false,2);

  insert('altwt',68,false,17);
  insert('altend',69,false,4);
  insert('and',70,false,1);
  insert('enbt',71,false,8);

  insert('enbc',72,false,7);
  insert('enbs',73,false,3);
  insert('move',74,false,8);
  insert('or',75,false,1);

  insert('csngl',76,false,3);
  insert('ccnt1',77,false,3);
  insert('talt',78,false,4);
  insert('ldiff',79,false,2);

    (* oprator instruktions: 80 - 95 *)

  insert('sthb',80,false,1);
  insert('taltwt',81,false,48);
  insert('sum',82,false,1);
  insert('mult',83,false,38);

  insert('sttime',84,false,1);
  insert('stoper',85,false,2);
  insert('cword',86,false,5);
  insert('clther',87,false,1);

  insert('sthaer',88,false,1);
  insert('tshaer',89,false,2);
  insert('#25#FA',90,false,-1);
  insert('#25#FB',91,false,-1);

  insert('#25#FC',92,false,-1);
  insert('#25#FD',93,false,-1);
  insert('#25#FE',94,false,-1);
  insert('#25#FF',95,false,-1);

end;

function find_label(l: instruction_string): integer;
var i: integer;
begin
  i:= 0;
  def_label[next_def_label].name := l;
  while def_label[i].name <> l do i:= i+1;
  if i = next_def_label then 
  begin
    def_label[i].where:= -1;
    next_def_label:= next_def_label + 1;
  end;
  find_label:= i; 
end;

function find_const: integer;
var i: integer;
begin
  i:= 0;
  const_table[next_const].name:= instruction;
  while const_table[i].name <> instruction do i:= i + 1;
  if i = next_const then error('undefined constant', instruction, 0);
  find_const:= const_table[i].value;
end;

function hex(number,digits: integer): hexstring;
const
  hexdigit: array[0..15] of char = '0123456789ABCDEF';
var
  d: integer;
  h: hexstring;
begin
  h[0]:=chr(digits);
  for d:=digits downto 1 do
  begin
    h[d]:=hexdigit[number and 15];
    number:=number SHR 4;
  end;
  hex:=h;
end;

function invershex(h: hexstring): hexstring;
var
  i: byte;
begin
  for i:=1 to ord(h[0]) do
    case h[i] of
      '0': h[i] := 'F'; '1': h[i] := 'E'; '2': h[i] := 'D'; '3': h[i] := 'C';
      '4': h[i] := 'B'; '5': h[i] := 'A'; '6': h[i] := '9'; '7': h[i] := '8';
      '8': h[i] := '7'; '9': h[i] := '6'; 'A': h[i] := '5'; 'B': h[i] := '4';
      'C': h[i] := '3'; 'D': h[i] := '2'; 'E': h[i] := '1'; 'F': h[i] := '0';
    end;
  for i:=ord(h[0])+1 to 8 do h:= 'F' + h;
  invershex:= h;
end; 
    
procedure read_src(var ch: char);
begin
  (*
  if next_ch = ' ' then begin next_ch:= lookahead_ch; lookahead_ch:= ' ' end;
  *)
  if next_ch = ' ' then
  begin 
    if eof(src) then error('end of file', instruction, 0);
    read(src, ch);
    if ('a' <= ch) and ( ch <= 'z') then
    else if ('A' <= ch) and ( ch <= 'Z') then ch:= chr( ord(ch) - ord('A') + ord('a') )
    else if ('0' <= ch) and ( ch <= '9') then 
    else if (ch <> ':') and (ch <> '-') then
    begin
      if rtp35 then
      begin
        if ch <> '_' then ch:= ' ';
      end else
      if ch <> '.' then ch := ' ';
    end;
    if ch <> ' ' then 
    begin 
      (* ! * ) write(ch); (**) 
      write_space:= false;
    end else
    if not write_space then 
    begin
      (* ! * ) write(' '); (**)
      write_space:= true; 
    end; 
  end else
  begin
    (* ! * ) write('?',next_ch,'?'); (**)
    ch:= next_ch;
    next_ch:= ' ';
  end;
  
  if false and ( ch='-') then begin
    read(src, ch);
    if ch='-' then begin readln( src ); ch:=' ' end
    else begin 
     (* ! * ) 
     writeln;
     writeln('LOOKAHEAD');
     (**)
    lookahead_ch:= ch; ch:= '-' end;
  end; 
end;

procedure skip;
var ch: char;
begin
  repeat
    read_src(ch);
  until ch <> ' ';
  (* ! * ) if ch='i' then write('SKIP'); (**)
  next_ch:= ch;
end;    

procedure read_label;
var ch: char;
    i: integer;
    def: boolean;
begin
  next_ch:= ' ';
  instruction[0]:= chr(inst_length);
  i:= 0;
  repeat
    i:= i + 1;
    read_src(ch);
    if i <= inst_length then
    instruction[i]:= ch;
  until (((ch < 'a') or (ch > 'z')) and (ch <> '.') and
        ((ch < '0') or (ch > '9')));
  if i < inst_length then begin
    delete(instruction, i, inst_length);
  end;
  (* ! * ) if ch='i' then write('READ LABEL'); (**)
  next_ch:= ch;
end;  

procedure read_def_label;
var i:integer;
begin
  read_label;
  i:= find_label(instruction);
  if def_label[i].where <> -1 then error('def label already used', instruction, next_use_label) else
  def_label[i].where:= open_address;
end;

procedure read_use_label;
var i:integer;
begin
  read_label;
  i:= find_label(instruction);
  with use_label[next_use_label] do
  begin
    where:= open_address;
    size:= 8;
    open_address:= open_address + 7;
    def:= i;
  end;
  next_use_label:= next_use_label + 1;
end;

procedure read_name;
var ch: char;
    i: integer;
    name_char : char;
begin
  if rtp35 then name_char:= '_' else name_char:= '.';
  instruction[0]:= chr(inst_length);
  i:= 0;
  repeat
    i:= i + 1;
    read_src(ch);
    (* ! * ) write(ch); (**)
    if i <= inst_length then
    instruction[i]:= ch;
  until ((ch <> name_char)
    and ((ch < 'a') or (ch > 'z'))) and ((ch < '0') or (ch > '9'));
  if i < inst_length then begin
    delete(instruction, i, inst_length);
  end;
  (* ! * ) if ch='i' then write('READ NAME'); (**)
  next_ch:= ch;
  writeln(instruction);
end;  



function read_instruction: integer;
begin
  skip;
  while next_ch = ':' do
  begin
    read_def_label;
    skip;
  end;
  read_name;
  read_instruction:= find( instruction );
end;  

function read_const_argument: integer;
var ch: char;
    i, p: integer;
begin
  skip;
  instruction[0]:= chr(inst_length);
  i:= 0;
  repeat
    i:= i + 1;
    read_src(ch);
    if i <= inst_length then 
    instruction[i]:= ch;
  until (((ch < '0') or (ch > '9')) and (ch <> '-'));
  if i < inst_length then begin
    delete(instruction, i, inst_length);
  end;
  (* ! * ) if ch='i' then write('READ CONST ARG'); (**)
  next_ch:= ch;
  val( instruction, i, p );
  if p <> 0 then begin
    if rtp35 then else error('illegal argument', instruction, p);
    read_const_argument:= 0;
  end else read_const_argument:= i;
end;


function read_argument: integer;
var ch: char;
    i, p: integer;
begin
  skip;
  if next_ch = '.' then 
  begin 
    read_use_label;
    read_argument:= 0;
  end else 
  if ('a' <= next_ch) and (next_ch <= 'z') then begin
    read_name;
    read_argument:= find_const;    
  end else read_argument:= read_const_argument;
end;

procedure dump_code_arg(code_val, argument: integer);
var i, four_bit, ignore: integer;
    nfix, started: boolean;
begin
  if argument < 0 then ignore:= 15 else ignore:= 0;
  for i:= 3 downto 1 do
  begin
    four_bit:= (argument shr (i*4)) AND 15;
    if four_bit <> ignore then
    begin
      if ignore <> 15 then dump_code_arg(pfix_inst_val, four_bit) else
      begin
        dump_code_arg(nfix_inst_val, 16 - four_bit);
        ignore:= -1;
      end;
    end;
  end;
  if ignore = 15 then dump_code_arg(nfix_inst_val, 0);
  open_code[open_address]:= code_val * 16 + (argument and 15 );
  (* ! * ) write(' ',hex(open_code[open_address],2)); (**)
  open_address:= open_address + 1;
end;

procedure check_labels;
var i, j, adjust_size:integer;
    ok: boolean;
    inst_val: integer;
begin
  for j:=0 to next_def_label-1 do
    if def_label[j].where = -1 then error('undefined label', def_label[j].name, 0); 
  repeat
    ok:= true;
    for i:=0 to next_use_label-1 do
    with use_label[i] do
    begin
      inst_val:= open_code[ where + size - 1] SHR 4;
      open_address:= where;
      dump_code_arg(inst_val, def_label[ def ].where - where - size);
      adjust_size:= where + size - open_address;
      if adjust_size > 0 then
      begin
        ok:= false;
        size:= size - adjust_size;
        for j:= i + 1 to next_use_label - 1 do
          use_label[j].where:= use_label[j].where - adjust_size;
        for j:= 0 to next_def_label - 1 do
          with def_label[j] do
            if where >= open_address then 
              where:= where - adjust_size; 
        for j:= open_address + adjust_size to last_open_address do
          open_code[j-adjust_size]:= open_code[j];
        last_open_address:= last_open_address - adjust_size;
      end;      
    end;
  until ok;
end;

procedure read_const;
var i:integer;
begin
  read_label;
  with const_table[next_const] do
  begin
    write(' VAL: ');
    name:=instruction;
    write(instruction, ',');
    i:= read_instruction; (* skip IS *)
    write(instruction, ',');
    i:= read_const_argument;
    value:= i;
    writeln(instruction, ',', i:1);
  end;
  next_const:= next_const + 1;
  if next_ch <> ':' then
  repeat
    next_ch:= ' ';
    skip;
  until next_ch=':';
  next_ch:= ' ';
end;

procedure dump_code_record;
begin
if open_address > 0 then begin
  write_byte( ope_tmp, code_record );
  write_byte( ope_tmp, open_address );
  for i:=0 to open_address - 1
  do write(ope_tmp, open_code[i]);
  open_code_address:= open_code_address + 2 + open_address;
  open_address:= 0;
end;
end;

procedure dump_pushproc;
begin
  dump_code_record;
  write_byte( ope_tmp, pushproc_record );
  open_code_address:= open_code_address + 1;
end;

procedure dump_finis;
begin
  dump_code_record;
  write_byte( ope_tmp, finis_record );
  (* ! *) writeln(' dump finis '); (**)
  open_code_address:= open_code_address + 1;
end;

procedure dump_cjump( no: integer ) ;
begin
  dump_code_record;
  write_byte( ope_tmp, cjump_record );
  write_byte( ope_tmp, no );
  open_code_address:= open_code_address + 2;
end;  

procedure dump_jump( no: integer ) ;
begin
  dump_code_record;
  write_byte( ope_tmp, jump_record );
  write_byte( ope_tmp, no );
  open_code_address:= open_code_address + 2;
end;

procedure dump_label( no: integer ) ;
begin
  dump_code_record;
  write_byte( ope_tmp, label_record );
  write_byte( ope_tmp, no );
  open_code_address:= open_code_address + 2;
end;


procedure read_code_lines( routine_code: boolean );
var instruction_index, inst_val, argument: integer;
    i: integer;
begin
  next_use_label:= 0;
  next_def_label:= 0;
  repeat
    (* ! * ) writeln; (**)
    write_space:= true;
    instruction_index:= read_instruction;
    if instruction_index = next_instruction
    then error('unknown instruction', instruction, 0) else
    if instruction_index = val_inst then begin
      read_const;
    end else
    if instruction_index = push_proc_inst then begin
      dump_pushproc;
    end else
    if instruction_index = cjump_inst then begin
      i:= read_const_argument;
      dump_cjump( i );  
    end else
    if instruction_index = jump_inst then begin
      i:= read_const_argument;
      dump_jump( i );  
    end else
    if instruction_index = label_inst then begin
      i:= read_const_argument;
      dump_label( i );
    end else
    if instruction_index <> end_inst then
    begin
      with instructions[instruction_index] do
      begin
        if direct then 
        begin
          inst_val:= instructions[ instruction_index].code_value; 
          argument:= read_argument;
        end else begin
          inst_val:= opr_inst_val;
          argument:= code_value;
        end;
      end;
      dump_code_arg( inst_val, argument );
    end;
  until instruction_index = end_inst;
  last_open_address:= open_address - 1;
  check_labels;
  (* ! * ) writeln; write(' code to open routine ');
  for i:=0 to last_open_address do
  begin
    if i mod 10 = 0 then writeln;
    write(' ',hex(open_code[i],2));
  end; (**)
  open_address:= last_open_address + 1;
  if routine_code then dump_finis;
end;

procedure readlibname(var s: alfastring);
var i : integer;
    b : byte;
begin
  s := '';
  for i := 1 to 12 do    
  begin
    read(lib_file, b);
    s := s + chr(b);
  end;
end;

procedure readlibint(var i : integer);
var b, b1: byte;
begin
  if eof(lib_file) then i := 0 else
  begin
    read(lib_file, b);
    read(lib_file,b1);
    i := b1 + (b shl 8);
  end;
end;

procedure read_code35(no : integer; save : boolean);
var i : integer;
    b : byte;
begin
  open_address := 0;
  for i := 1 to no do
  begin
    read(lib_file, b);
    if (i > 16) and (save) then 
    begin
      open_code[open_address] := b;
      open_address := open_address + 1;
    end;
  end;
end;

procedure read_proc_parameters;
var open_name, libprocname : alfastring;
    parameters, libprocparameters : array[0..40] of integer;
    i, openparameters, libparameters: integer;
    descr_length, no_of_pages, page_size, last_page_length,
    kind, dummy, j, code_length: integer;
    first_on_lib : boolean;
begin
  read_name;
  open_name := instruction + '            ';
  i := 0;
  repeat
    (* ! * ) writeln; (**)
    write_space:= true;
    parameters[i] := read_const_argument;
    i := i+1;
  until instruction = '';
  openparameters := (i-1)div 2;
  if parameters[0] <> openparameters then
  begin
    writeln(' parameter specification error ', parameters[0],
            '  ', openparameters);
    halt;
  end;
  repeat 
    i := read_instruction;
  until i = end_inst;

  reset(lib_file);
  first_on_lib := true;
  readlibint(descr_length);
  while descr_length > 0 do
  begin
    readlibint(no_of_pages);
    readlibint(page_size);
    readlibint(last_page_length);
    readlibint(kind);
    readlibname(libprocname);
    for i := 1 to 10 do readlibint(dummy);
    readlibint(libparameters);
    libprocparameters[0] := libparameters;
    for i := 1 to libparameters*2 do readlibint(libprocparameters[i]);
    if open_name <> libprocname then libparameters := openparameters+1;
    if (openparameters = libparameters) then
    begin
      for i := 0 to openparameters do
      if parameters[i] <> libprocparameters[i] then
       libparameters := openparameters+1;
    end;

    read_code35((no_of_pages-1)*page_size+last_page_length,
                libparameters = openparameters);

    readlibint(kind);
    for i := 1 to kind do
    begin (* skip external uses *)
      readlibname(libprocname);
      readlibint(no_of_pages);
      for j := 1 to no_of_pages*2 do readlibint(dummy);
      readlibint(no_of_pages);
      for j := 1 to no_of_pages*2 do readlibint(dummy);
    end;
    readlibint(no_of_pages);
    for j := 1 to no_of_pages do
    begin
       readlibint(dummy);
       if dummy <> 1 then
       begin
         writeln('more than one page'); halt;
       end;
       readlibint(i);
       readlibint(dummy);
       readlibint(dummy);
       if i = 14 then
       begin
         open_address := dummy-16;
         if first_on_lib then open_address := open_address-4; (* FUSK *)
       end;
     end;
    first_on_lib := false;
    if libparameters = openparameters then
    begin (* open routine found *)
       writeln(' open routine found ');
       descr_length := 0;
    end else
    begin
      open_address := 0;
    end;
    if descr_length > 0 then
    begin
      readlibint(descr_length);
      if descr_length <= 0 then
        begin
        writeln('not found                   <-----', @7);
        if nf_cnt < max_nf_cnt then nf_cnt:= nf_cnt + 1;
        notfound[nf_cnt]:= open_name;
        end;
    end;
  end;

  last_open_address:= open_address - 1;
  (* ! *) writeln; write(' code to open routine ');
  for i:=0 to last_open_address do
  begin
    if i mod 10 = 0 then writeln;
    write(' ',hex(open_code[i],2));
  end; (**)
  open_address:= last_open_address + 1;
  dump_code_record;
  dump_finis;
end;

procedure dump_ope;
var i:integer;
    b: byte;
begin
  reset(ope_tmp);
  write_int(ope, open_code_address + open_entry * 2);
  for i:= 0 to open_entry-1 do
    write_int(ope, open_entry * 2 + open_entries[i]);
  for i:= 1 to open_code_address do
  begin
    read(ope_tmp, b);
    write(ope, b);
  end;
end;

(* rtp *)

procedure rtp_keyword_init;
var i: integer;
begin
  for i:= key_first to key_last do
  begin
    rtp_keywords[ i ]:=  '';
    rtp_keyword_copy[ i ]:= true;
  end;
  rtp_keywords[ key_function ]:= 'function';
  rtp_keywords[ key_procedure ]:= 'procedure';
  rtp_keywords[ key_external ]:= 'external';
  rtp_keywords[ key_begin ]   := 'begin';
  rtp_keyword_copy[ key_begin ]   := false;
  rtp_keywords[ key_and ]    := 'and';
  rtp_keyword_copy[ key_and ]    := false;
  rtp_keywords[ key_code ]    := 'code';
  rtp_keyword_copy[ key_code ]    := false;
  rtp_keywords[ key_comment1_start ] := '(*';
  rtp_keywords[ key_comment1_end ] := '*)';
  rtp_keywords[ key_comment2_start ] := '<*';
  rtp_keywords[ key_comment2_end ] := '*>';
  rtp_keywords[ key_comment3_start ] := '--';
  rtp_keywords[ key_finis ] := ' ';
end;

function is_alfanum(ch: char): boolean;
begin
  is_alfanum:= (('a' <= ch) and (ch <= 'z')) or
               (('0' <= ch) and (ch <= '9'));
end;

function is_rtp_keyword(i, p: integer):boolean;
var ok: boolean;
     np: integer;
begin
  ok:= true;
  if p > 1 then ok:= not is_alfanum(rtp_line[p-1]);
  if ok then
  begin
    np:= p + len(rtp_keywords[i]);
    if np <= len(rtp_line) then ok:= not is_alfanum(rtp_line[np])
    else ok:= eoln(src);
  end;
  ok:= ok or (i > key_last_name);
  (* ! * ) if not ok then begin
    writeln;
    writeln('-KEYWORD: ',i,' ',p,' ',np,' "',rtp_keywords[i],'" "',rtp_line,'"');
  end; (**)
  is_rtp_keyword:= ok;
end;

procedure convert_rtp_line;
var i:integer;
    ch: char;
begin
  for i:=1 to len(rtp_line) do
  begin
    ch:= rtp_line[i];
    if ('A' <= ch) and (ch <= 'Z') then rtp_line[i]:= chr( ord(ch) - ord('A') + ord('a'));
  end;
end;

function next_rtp_keyword: integer;
var help_line: string[64];
    key_pos, key, i, p: integer;
begin
  repeat
    if len(rtp_line) = 0 then
    begin
      if eoln(src) then begin readln(src); writeln(env); end;
      read(src, rtp_line);
      convert_rtp_line;
      (* ! * ) write('=', rtp_line); (**)
    end else
    if (len(rtp_line) <= 64) and (not eoln(src)) then
    begin
      read(src, help_line);
      (* ! * ) write('*',help_line); (**)
      rtp_line:= concat( rtp_line, help_line );
      convert_rtp_line;
    end;
    key_pos:= maxint;
    for i:= key_first to key_last do
    begin
      p:= pos( rtp_keywords[i], rtp_line );
      if (p <> 0) and (p < key_pos)
      then begin
        if is_rtp_keyword(i, p) then
        begin key_pos:= p; key:= i; end;
      end;
    end;
    if key_pos = maxint then
    begin
      write(env, rtp_line);
      if eof(src) then begin
        key_pos:= 0;
        key:= key_finis;
      end else read(src, rtp_line);
    end;
  until key_pos < maxint;
  next_rtp_keyword:= key;
  p:= key_pos + len( rtp_keywords[ key ] );
  if rtp_keyword_copy[ key ]
  then write(env, copy( rtp_line, 1, p - 1))
  else write(env, copy( rtp_line, 1, key_pos - 1));
  delete( rtp_line, 1, p - 1 );
end;

procedure rtp_skip_line(print: boolean);
begin
  while not eoln(src) do
  begin
    if print then write(env, rtp_line);
    read(src, rtp_line);
  end;
  readln(src);
  if print then writeln(env, rtp_line);
  rtp_line:= '';
end;


begin
  writeln ( ' RTPSTD35   rel 1.5   92.08.24 ');
  nf_cnt:= 0;
  write_space:= false;
  open_address:= 0;
  rtp35:= true;
  if argcnt >= 1 then
  begin
    if argstr(1) = '35' then
    begin
      rtp35 := true;
      open_address := 1;
    end else if argstr(1) = '50' then
    begin
      open_address:= 1;
    end;
  end;
  if argcnt>open_address+3 then
  begin
    writeln('Syntax: RTPSTD35 [35/50] [source-file [envirement-file [openroutines-file]]]'); 
    halt;
  end;
  if rtp35 then
  begin
    src_name:= 'rtpstd35.src';
    env_name:= 'rtpstd35.env';
    ope_name:= 'rtpope35.lib';
  end else
  begin
    src_name:= 'rtpstd50.src';
    env_name:= 'rtpstd50.env';
    ope_name:= 'rtpope50.lib';
  end;
  ope_tmp_name:= 'rtpstd.tmp';
  if argcnt >= open_address+1 then
  begin
    src_name:= argstr(1+open_address);
  end;
  if argcnt >= open_address+2 then
  begin
    env_name:= argstr(2+open_address);
  end;
  if argcnt >= open_address+3 then
  begin
    ope_name:= argstr(3+open_address);
  end;
  
  assign(src,src_name); {$I-} reset(src) {$I+};
  if iores>0 then
  begin
    writeln('SRC: "',src_name,'" does not exist'); halt;
  end;

  if rtp35 then
  begin
    lib_name := ope_name;
    open_address:= len(lib_name);
    while open_address > 0 do
    if lib_name[open_address] = '.' then open_address := 0 else
    begin
      delete(lib_name, open_address, 1);
      open_address := open_address - 1;
    end;
    lib_name := lib_name+'src';
    assign(lib_file,lib_name); {$I-} reset(lib_file) {$I+};
    if iores>0 then
    begin
      writeln('LIB: "',lib_name,'" does not exist'); halt;
    end;
  end;
  assign(env,env_name); rewrite(env);
  assign(ope,ope_name); rewrite(ope);
  assign(ope_tmp, ope_tmp_name); rewrite(ope_tmp);
  next_ch:= ' ';
  lookahead_ch:= ' ';
  init_instructions;
  opr_inst:= find('opr');
  pfix_inst:= find('pfix');
  nfix_inst:= find('nfix');  
  end_inst:= find('end');
  val_inst:= find('val');
  push_proc_inst:= find('pushproc');
  cjump_inst:= find('cjump');
  jump_inst:= find('jump');
  label_inst:= find('label');
  opr_inst_val:= instructions[ opr_inst ].code_value;
  pfix_inst_val:= instructions[ pfix_inst ].code_value;
  nfix_inst_val:= instructions[ nfix_inst ].code_value;
  next_const:= 0;

  open_address:= 0;
  open_code_address:= 0;
  open_entry:= 0;

  rtp_in_routine:= false;
  rtp_keyword_init;
  rtp_line:='';
  repeat
    key:= next_rtp_keyword;
    case key of
      key_function, key_procedure: rtp_in_routine:= true;
      key_external: rtp_in_routine:= false;
      key_code: read_code_lines( false );
      key_begin: begin
        write('.');
        rtp_skip_line(false);
        writeln(env,'openroutine;');
        open_entries[ open_entry ]:= open_code_address;
        (* ! *) writeln( 'open code address: ', open_code_address:1); (**)
        if rtp35 then read_proc_parameters else read_code_lines( true );
        open_entry:= open_entry + 1;
      end;
      key_and: if rtp_in_routine then begin
        rtp_skip_line(false);
        writeln(env,'openroutine;');
        open_entries[ open_entry ]:= open_code_address;
        (* ! *) writeln( 'open code address: ', open_code_address:1); (**)
        open_entry:= open_entry + 1;
      end;
      key_finis: ;
      key_comment1_start: repeat
         key:= next_rtp_keyword;
       until (key = key_comment1_end) or (key = key_finis);
      key_comment2_start: repeat
         key:= next_rtp_keyword;
       until (key = key_comment2_end) or (key = key_finis);
      key_comment3_start: rtp_skip_line(true);
      otherwise ;
    end;
  until key=key_finis;

  dump_ope;

  close(src);
  close(env);
  close(ope);

  if nf_cnt > 0 then
    begin
    writeln ( ' ***  Open routines not found in  RTPOPE35.SRC : ');
    for i:= 1 to nf_cnt do  writeln ( '     ', notfound[i]);
    end;
    

END.