unit rtpunit;
interface
uses dos;

const

i_pass1_env1name ='rtp35021.env';
i_pass1_env2name ='rtp35022.env';
i_pass1_envzname ='z80.env';
i_pass1_tabname  ='rtp35022.tab';

i_passx_err1name ='rtp35021.err';
i_passx_err2name ='rtp35022.err';

i_pass5_extname  ='rtp35022.lib';
i_pass6_envname  ='rtp35022.en5';

o_pass1_codename ='rtppass1.cod'; (* on path1 *)
o_pass1_symbname ='rtppass1.sym';
o_pass1_spixname ='rtppass1.spx';

o_pass3_codename ='rtppass3.cod'; (* on path2 *)
o_pass3_nixname  ='rtppass3.nix';

o_pass4_codename ='rtppass4.cod'; (* on path1 *)
o_pass4_nixname  ='rtppass4.nix';

o_pass5_codename ='rtppass5.cod'; (* on path2 *)

o_pass6_codename ='rtppass6.cod'; (* on user path *)
o_pass6_workname ='rtppass6.wrk'; (* on path1 *)

alfalength=12;                  (*length of alfa variable*)
pathlength=30;

type

alfa = string[alfalength ];
path = string[pathlength ];

paramptr = ^paramheap;
paramheap = record
  parameter : string;
  next      : paramptr;
end;
const
linemax=150; (*max. length of lines*)
type
line_type= array [ 1..linemax ] of char;

var exitptr : pointer;
    paramhead: paramptr;
    paramrec : string;
    leftside, programname: alfa;
    rtp35_pathname, path1_name, path2_name, source_path: path;
    i : word;
    hexnumber: array[0..15] of char;


procedure assign_alfa(var a: alfa; s: string);
procedure write_hex(dec_number: integer; positions : integer);
procedure runtime_error(s: string);
procedure rtphalt(trace : boolean);
procedure getclock(var t: datetime);
procedure filetime(var f: text; var d: datetime);
procedure nofile(s:string);
procedure replace(f:string);
function  paramread(p_no: integer; var ri: integer; var txt: alfa): integer;
procedure date(var dat:alfa);
procedure time(var tim: alfa);

implementation

procedure write_hex;
begin
if positions = 4 then write(hexnumber [ dec_number shr 12 ]);
if positions >= 3 then write(hexnumber [ (dec_number shr 8)  and 15 ]);
write(hexnumber [ (dec_number shr 4)  and 15 ],
      hexnumber [ dec_number and 15 ] );
end;


procedure runtime_error;
begin

writeln(output, s);

if (exitcode <> 0) and (exitcode <> 300) then
begin
  write(output, '*** Runtime error(', exitcode, '): ');
  case exitcode of
    2: write(output, 'File not found');
    3: write(output, 'Path not found');
    4: write(output, 'Too many open files');
    5: write(output, 'File access denied');
    6: write(output, 'Invalid file handle');
    12:write(output, 'Invalid file access code');
    100:write(output,'Read past end of file');
    101:write(output,'Disk full');
    102:write(output,'File not assigned');
    103:write(output,'File not open');
    104,105:write(output,'File opened in bad mode');
    106:write(output,'Invalid numeric format');
    200:write(output,'Division by zero');
    201:write(output,'Out of range');
    202:write(output,'Stack overflow');
    203:write(output,'Heap overflow');
    204:write(output,'Invalid pointer operation');
    205,206,207:write(output,'Floating point error');
    255:write(output,'Program breaked by operator');
    else ;
  end;
  write(output,', called from ');
  write_hex(seg(erroraddr),4);
  write(output,':');
  write_hex(ofs(erroraddr),4);
  writeln;
end;

halt(300);

end;

procedure assign_alfa;
var l: integer;
begin
  a := '            ';
  l := length(s);
  if l > alfalength then l := alfalength;
  a := copy(s, 1, l);
end;

procedure rtphalt;
begin
  halt(300);
end;

procedure getclock;
var y, mo, da, ho, mi, se, dummy: word;
begin
  getdate(y,mo,da,dummy);
  gettime(ho, mi, se, dummy);
  with t do
  begin
    year   := y ;
    month  := mo;
    day    := da;
    hour   := ho;
    min    := mi;
    sec    := se;
  end;
end;

procedure filetime;
var t: longint;
begin
  getftime(f,t);
  unpacktime(t, d);
end;

procedure nofile;
begin
  writeln(' file : ', s);
  halt(2);
end;

procedure replace;
begin
  halt;
end;

procedure set_path_end(var s: path);
begin
  while copy(s, length(s), 1) = chr(92) do
  begin
    delete(s, length(s), 1);
  end;
  if s <> '' then s := s + chr(92);
end;

function paramsearch(p: paramptr; var no: integer; var txt: alfa): integer;
var b, b1, e: byte;
    result: integer;
    sourcepath: boolean;
begin
  sourcepath := false;
  paramrec   := p^.parameter;
  b          := 1;
  while (b > 0) and (no > 0) do
  begin
    b      := pos(' ', paramrec);
    b1     := pos('-', paramrec);
    result := 4;
    if b1 <> 0 then
    begin
      if b = 0 then b := b1;
      if b1 <= b then
      begin
        b      := b1;
        result := 8;
      end;
    end;
    if b <> 0 then paramrec[b] := chr(26);
    e  := pos(' ', paramrec);
    b1 := pos('-', paramrec);
    if e = 0 then e := b1;
    if b1 <> 0 then
    begin
      if b1 < e then e := b1;
    end;
    if e = 0 then e := length(paramrec) else e := e-1;
    if b = 0 then e := b;
    if e > b then
    begin
      assign_alfa(txt, copy(paramrec, b+1, e-b));
      no := no - 1;
      if sourcepath then
      begin
        sourcepath := false;
        if result = 8 then
        begin
          source_path := copy(paramrec, b+1, e-b);
          set_path_end(source_path);
          no          := no + 1;
        end;
      end else
      if (result = 4) and (txt = 'sourcepath') then
      begin
        sourcepath  := true;
        source_path := '';
        no          := no + 1;
      end;
    end;
  end;
  paramsearch := result shl 8;
end;

function paramread;
var result: integer;
    p : paramptr;
begin

  ri    := 0;

  if length(leftside) > 0 then
  begin
    if p_no <= 0 then
    begin
      assign_alfa(txt, leftside);
      paramread := 4;
      exit;
    end;
    p_no := p_no - 1;
  end;

  if p_no <= 0 then
  begin
    if length(programname) > 0 then
    begin
      assign_alfa(txt, programname);
    end else
    begin
      assign_alfa(txt,'rtp35022');
    end;
    if length(leftside) > 0 then paramread := 6*256+4 else paramread := 4;
    exit;
  end;

  p := paramhead;
  while (p <> nil) and (p_no > 0) do
  begin
    result := paramsearch(p, p_no, txt);
    p := p^.next;
  end;

  if p_no > 0 then
  begin
    assign_alfa(txt,'');
    paramread := 0;
    exit;
  end;

  val(txt, ri, p_no);
  if p_no <> 0 then
  begin
     result := result + 10;
  end else result := result + 4;

  paramread := result;

end;

procedure date;
var t: datetime;
    a,b: string;
begin
  getclock(t);
  str(t.year:4, a);
  b := concat(' ',a,'.');
  str(t.month:2,a);
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';
  a := concat(b, a, '.');
  str(t.day:2,b);
  while pos(' ',b) > 0 do b[pos(' ',b)] := '0';
  dat := concat(a,b,' ');
end;

procedure time;
var t: datetime;
    a,b: string;
begin
  getclock(t);
  str(t.hour:2, a);
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';
  b := concat(' ',a,':');
  str(t.min:2,a);
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';
  a := concat(b, a, ':');
  str(t.sec:2,b);
  while pos(' ',b) > 0 do b[pos(' ',b)] := '0';
  tim := concat(a,b,'   ');
end;

procedure paramadd;
var p: paramptr;
begin
  if length(paramrec) > 0 then
  begin
    new(p);
    p^.parameter := paramrec;
    p^.next      := paramhead;
    paramhead    := p;
    paramrec     := '';
  end;
end;

procedure paraminverse;
var p, q: paramptr;
begin
  p := paramhead; paramhead := nil;
  while p <> nil do
  begin
    q         := p^.next;
    p^.next   := paramhead;
    paramhead := p;
    p         := q;
  end;
end;

procedure param(var p: string);
var ch: char;
begin
  p := '';
  repeat
    if eof(input) then ch := chr(26) else read(ch);
  until (ch > ' ') or (ch = chr(26));
  while (ch <> ' ') and (ch <> chr(26)) do
  begin
    if ch > ' ' then p := concat(p, ch);
    if eof(input) then ch := chr(26) else
    begin
      read(ch);
      if ch < ' ' then ch := ' ';
    end;
  end;
end;

procedure paramput(s: string); forward;

procedure paramfile(s: string);
var p: string;
begin
  if pos('-', s) = 0 then exit;
  s := copy(s, pos('-', s)+1, length(s) - pos('-',s));
  close(input);
  assign(input, s);
(*$I-*)
  reset(input);
(*$I+*)
  if ioresult = 0 then param(p) else p := '';
  while length(p) > 0 do
  begin
    paramput(p);
    param(p);
  end;
end;

procedure assign_path(var a: path; s:string);
var l: integer;
begin
  l := length(s);
  if l > pathlength then l := pathlength;
  a := copy(s, 1, l);
end;

procedure savepath(s: string; var n: alfa; var p1,p2: path);
var b1, b2, e: byte;
begin
  b1 := pos('-', s);
  e  := b1;
  if b1 > 0 then
  begin
    s[b1] := chr(26);
    e     := e - 1;
  end else e := length(s);
  assign_alfa(n, copy(s,1+1,e-1));
  b2 := pos('-', s);
  e  := b2;
  if b2 = 0 then e := length(s) else e := e - 1;
  if b1 > 0 then
  begin
    assign_path(p1, copy(s,b1+1,e-b1));
    if b2 > 0 then
    begin
      s[b2] := chr(26);
      e := pos('-', s);
      if e = 0 then e := length(s) else e := e - 1;
      assign_path(p2, copy(s, b2+1, e-b2));
    end;
  end;
end;

procedure paramput(s: string);
var i: word;
begin
  for i := 1 to length(s) do
  if (s[i] >= 'A') and (s[i] <= 'Z') then
    s[i] := chr(ord(s[i]) - ord('A') + ord('a'));

  if pos('paramin', s) = 1 then
  begin
    paramfile(s);
  end else
  if pos('=', s) = 1 then
  begin
    savepath(s, leftside, path1_name, path2_name);
  end else
  if pos('/', s) = 1 then
  begin
    savepath(s, programname, rtp35_pathname, rtp35_pathname);
  end else
  begin
    if length(paramrec) + length(s) + 1 > 255 then paramadd;
    paramrec := concat(paramrec, ' ', s);
  end;
end;

procedure findset(name: string; var res: path);
Var
    e    	:  integer;
    envirseg	:  ^word;
    envir	:  ^char;
    setname     :  string;
begin

  res      := '';

  envirseg := ptr( prefixseg, $2c);
  e        := 0;
  envir    := ptr ( envirseg^, e);
  while envir^ <> chr(0) do
    begin
      setname := '';
      repeat
        if (envir^>='A') and (envir^<='Z') then
        begin
          setname := setname + envir^;
        end else
        if (envir^>='0') and (envir^<='9') then
        begin
          setname := setname + envir^;
        end;
        e     := e + 1;
        envir := ptr(envirseg^, e);
      until envir^ = '=';
      e      := e + 1;
      envir  := ptr(envirseg^, e);
      while envir^ <> chr(0) do
      begin
        if setname = name then res := res + envir^;
        e     := e + 1;
        envir := ptr(envirseg^, e);
      end;
      e     := e + 1;
      envir := ptr(envirseg^, e);
    end;  (*  while  *)

end;

(*$F+*) procedure myexit; (*$F-*)
begin
  exitproc := exitptr;
end;

begin

  exitptr  := exitproc;
  exitproc := @myexit;

  for i := 0 to 9 do hexnumber[i]    := chr(i+48);
  for i := 0 to 5 do hexnumber[10+i] := chr(i+65);

  paramrec  := '';
  paramhead := nil;
  assign_alfa(leftside, '');
  assign_alfa(programname, '');
  assign_path(rtp35_pathname, '');
  assign_path(path1_name,'');
  assign_path(path2_name,'');
  assign_path(source_path,'');

  for i := 1 to paramcount do paramput(paramstr(i));
  paramadd;
  paraminverse;

  if rtp35_pathname = '' then findset('RTPPATH', rtp35_pathname);
  if path1_name     = '' then findset('RTPWORK1',path1_name);
  if path2_name     = '' then findset('RTPWORK2',path2_name);

  if rtp35_pathname = '' then
  begin
    rtp35_pathname := paramstr(0);
    repeat
      delete(rtp35_pathname, length(rtp35_pathname), 1);
      i := length(rtp35_pathname);
      if copy(rtp35_pathname, i, 1) = chr(92) then i := 0;
    until i = 0;
  end;

  set_path_end(rtp35_pathname);
  set_path_end(path1_name);
  set_path_end(path2_name);

  setcbreak(true);
end.