⟦2d3a92189⟧

TextFile

unit rtpunit;\r
interface\r
uses dos;\r
\r
const\r
\r
i_pass1_env1name ='rtp35021.env';\r
i_pass1_env2name ='rtp35022.env';\r
i_pass1_envzname ='z80.env';\r
i_pass1_tabname  ='rtp35022.tab';\r
\r
i_passx_err1name ='rtp35021.err';\r
i_passx_err2name ='rtp35022.err';\r
\r
i_pass5_extname  ='rtp35022.lib';\r
i_pass6_envname  ='rtp35022.en5';\r
\r
o_pass1_codename ='rtppass1.cod'; (* on path1 *)\r
o_pass1_symbname ='rtppass1.sym';\r
o_pass1_spixname ='rtppass1.spx';\r
\r
o_pass3_codename ='rtppass3.cod'; (* on path2 *)\r
o_pass3_nixname  ='rtppass3.nix';\r
\r
o_pass4_codename ='rtppass4.cod'; (* on path1 *)\r
o_pass4_nixname  ='rtppass4.nix';\r
\r
o_pass5_codename ='rtppass5.cod'; (* on path2 *)\r
\r
o_pass6_codename ='rtppass6.cod'; (* on user path *)\r
o_pass6_workname ='rtppass6.wrk'; (* on path1 *)\r
\r
alfalength=12;                  (*length of alfa variable*)\r
pathlength=30;\r
\r
type\r
\r
alfa = string[alfalength ];\r
path = string[pathlength ];\r
\r
paramptr = ^paramheap;\r
paramheap = record\r
  parameter : string;\r
  next      : paramptr;\r
end;\r
const\r
linemax=150; (*max. length of lines*)\r
type\r
line_type= array [ 1..linemax ] of char;\r
\r
var exitptr : pointer;\r
    paramhead: paramptr;\r
    paramrec : string;\r
    leftside, programname: alfa;\r
    rtp35_pathname, path1_name, path2_name, source_path: path;\r
    i : word;\r
    hexnumber: array[0..15] of char;\r
\r
\r
procedure assign_alfa(var a: alfa; s: string);\r
procedure write_hex(dec_number: integer; positions : integer);\r
procedure runtime_error(s: string);\r
procedure rtphalt(trace : boolean);\r
procedure getclock(var t: datetime);\r
procedure filetime(var f: text; var d: datetime);\r
procedure nofile(s:string);\r
procedure replace(f:string);\r
function  paramread(p_no: integer; var ri: integer; var txt: alfa): integer;\r
procedure date(var dat:alfa);\r
procedure time(var tim: alfa);\r
\r
implementation\r
\r
procedure write_hex;\r
begin\r
if positions = 4 then write(hexnumber [ dec_number shr 12 ]);\r
if positions >= 3 then write(hexnumber [ (dec_number shr 8)  and 15 ]);\r
write(hexnumber [ (dec_number shr 4)  and 15 ],\r
      hexnumber [ dec_number and 15 ] );\r
end;\r
\r
\r
procedure runtime_error;\r
begin\r
\r
writeln(output, s);\r
\r
if (exitcode <> 0) and (exitcode <> 300) then\r
begin\r
  write(output, '*** Runtime error(', exitcode, '): ');\r
  case exitcode of\r
    2: write(output, 'File not found');\r
    3: write(output, 'Path not found');\r
    4: write(output, 'Too many open files');\r
    5: write(output, 'File access denied');\r
    6: write(output, 'Invalid file handle');\r
    12:write(output, 'Invalid file access code');\r
    100:write(output,'Read past end of file');\r
    101:write(output,'Disk full');\r
    102:write(output,'File not assigned');\r
    103:write(output,'File not open');\r
    104,105:write(output,'File opened in bad mode');\r
    106:write(output,'Invalid numeric format');\r
    200:write(output,'Division by zero');\r
    201:write(output,'Out of range');\r
    202:write(output,'Stack overflow');\r
    203:write(output,'Heap overflow');\r
    204:write(output,'Invalid pointer operation');\r
    205,206,207:write(output,'Floating point error');\r
    255:write(output,'Program breaked by operator');\r
    else ;\r
  end;\r
  write(output,', called from ');\r
  write_hex(seg(erroraddr),4);\r
  write(output,':');\r
  write_hex(ofs(erroraddr),4);\r
  writeln;\r
end;\r
\r
halt(300);\r
\r
end;\r
\r
procedure assign_alfa;\r
var l: integer;\r
begin\r
  a := '            ';\r
  l := length(s);\r
  if l > alfalength then l := alfalength;\r
  a := copy(s, 1, l);\r
end;\r
\r
procedure rtphalt;\r
begin\r
  halt(300);\r
end;\r
\r
procedure getclock;\r
var y, mo, da, ho, mi, se, dummy: word;\r
begin\r
  getdate(y,mo,da,dummy);\r
  gettime(ho, mi, se, dummy);\r
  with t do\r
  begin\r
    year   := y ;\r
    month  := mo;\r
    day    := da;\r
    hour   := ho;\r
    min    := mi;\r
    sec    := se;\r
  end;\r
end;\r
\r
procedure filetime;\r
var t: longint;\r
begin\r
  getftime(f,t);\r
  unpacktime(t, d);\r
end;\r
\r
procedure nofile;\r
begin\r
  writeln(' file : ', s);\r
  halt(2);\r
end;\r
\r
procedure replace;\r
begin\r
  halt;\r
end;\r
\r
procedure set_path_end(var s: path);\r
begin\r
  while copy(s, length(s), 1) = chr(92) do\r
  begin\r
    delete(s, length(s), 1);\r
  end;\r
  if s <> '' then s := s + chr(92);\r
end;\r
\r
function paramsearch(p: paramptr; var no: integer; var txt: alfa): integer;\r
var b, b1, e: byte;\r
    result: integer;\r
    sourcepath: boolean;\r
begin\r
  sourcepath := false;\r
  paramrec   := p^.parameter;\r
  b          := 1;\r
  while (b > 0) and (no > 0) do\r
  begin\r
    b      := pos(' ', paramrec);\r
    b1     := pos('-', paramrec);\r
    result := 4;\r
    if b1 <> 0 then\r
    begin\r
      if b = 0 then b := b1;\r
      if b1 <= b then\r
      begin\r
        b      := b1;\r
        result := 8;\r
      end;\r
    end;\r
    if b <> 0 then paramrec[b] := chr(26);\r
    e  := pos(' ', paramrec);\r
    b1 := pos('-', paramrec);\r
    if e = 0 then e := b1;\r
    if b1 <> 0 then\r
    begin\r
      if b1 < e then e := b1;\r
    end;\r
    if e = 0 then e := length(paramrec) else e := e-1;\r
    if b = 0 then e := b;\r
    if e > b then\r
    begin\r
      assign_alfa(txt, copy(paramrec, b+1, e-b));\r
      no := no - 1;\r
      if sourcepath then\r
      begin\r
        sourcepath := false;\r
        if result = 8 then\r
        begin\r
          source_path := copy(paramrec, b+1, e-b);\r
          set_path_end(source_path);\r
          no          := no + 1;\r
        end;\r
      end else\r
      if (result = 4) and (txt = 'sourcepath') then\r
      begin\r
        sourcepath  := true;\r
        source_path := '';\r
        no          := no + 1;\r
      end;\r
    end;\r
  end;\r
  paramsearch := result shl 8;\r
end;\r
\r
function paramread;\r
var result: integer;\r
    p : paramptr;\r
begin\r
\r
  ri    := 0;\r
\r
  if length(leftside) > 0 then\r
  begin\r
    if p_no <= 0 then\r
    begin\r
      assign_alfa(txt, leftside);\r
      paramread := 4;\r
      exit;\r
    end;\r
    p_no := p_no - 1;\r
  end;\r
\r
  if p_no <= 0 then\r
  begin\r
    if length(programname) > 0 then\r
    begin\r
      assign_alfa(txt, programname);\r
    end else\r
    begin\r
      assign_alfa(txt,'rtp35022');\r
    end;\r
    if length(leftside) > 0 then paramread := 6*256+4 else paramread := 4;\r
    exit;\r
  end;\r
\r
  p := paramhead;\r
  while (p <> nil) and (p_no > 0) do\r
  begin\r
    result := paramsearch(p, p_no, txt);\r
    p := p^.next;\r
  end;\r
\r
  if p_no > 0 then\r
  begin\r
    assign_alfa(txt,'');\r
    paramread := 0;\r
    exit;\r
  end;\r
\r
  val(txt, ri, p_no);\r
  if p_no <> 0 then\r
  begin\r
     result := result + 10;\r
  end else result := result + 4;\r
\r
  paramread := result;\r
\r
end;\r
\r
procedure date;\r
var t: datetime;\r
    a,b: string;\r
begin\r
  getclock(t);\r
  str(t.year:4, a);\r
  b := concat(' ',a,'.');\r
  str(t.month:2,a);\r
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';\r
  a := concat(b, a, '.');\r
  str(t.day:2,b);\r
  while pos(' ',b) > 0 do b[pos(' ',b)] := '0';\r
  dat := concat(a,b,' ');\r
end;\r
\r
procedure time;\r
var t: datetime;\r
    a,b: string;\r
begin\r
  getclock(t);\r
  str(t.hour:2, a);\r
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';\r
  b := concat(' ',a,':');\r
  str(t.min:2,a);\r
  while pos(' ',a) > 0 do a[pos(' ',a)] := '0';\r
  a := concat(b, a, ':');\r
  str(t.sec:2,b);\r
  while pos(' ',b) > 0 do b[pos(' ',b)] := '0';\r
  tim := concat(a,b,'   ');\r
end;\r
\r
procedure paramadd;\r
var p: paramptr;\r
begin\r
  if length(paramrec) > 0 then\r
  begin\r
    new(p);\r
    p^.parameter := paramrec;\r
    p^.next      := paramhead;\r
    paramhead    := p;\r
    paramrec     := '';\r
  end;\r
end;\r
\r
procedure paraminverse;\r
var p, q: paramptr;\r
begin\r
  p := paramhead; paramhead := nil;\r
  while p <> nil do\r
  begin\r
    q         := p^.next;\r
    p^.next   := paramhead;\r
    paramhead := p;\r
    p         := q;\r
  end;\r
end;\r
\r
procedure param(var p: string);\r
var ch: char;\r
begin\r
  p := '';\r
  repeat\r
    if eof(input) then ch := chr(26) else read(ch);\r
  until (ch > ' ') or (ch = chr(26));\r
  while (ch <> ' ') and (ch <> chr(26)) do\r
  begin\r
    if ch > ' ' then p := concat(p, ch);\r
    if eof(input) then ch := chr(26) else\r
    begin\r
      read(ch);\r
      if ch < ' ' then ch := ' ';\r
    end;\r
  end;\r
end;\r
\r
procedure paramput(s: string); forward;\r
\r
procedure paramfile(s: string);\r
var p: string;\r
begin\r
  if pos('-', s) = 0 then exit;\r
  s := copy(s, pos('-', s)+1, length(s) - pos('-',s));\r
  close(input);\r
  assign(input, s);\r
(*$I-*)\r
  reset(input);\r
(*$I+*)\r
  if ioresult = 0 then param(p) else p := '';\r
  while length(p) > 0 do\r
  begin\r
    paramput(p);\r
    param(p);\r
  end;\r
end;\r
\r
procedure assign_path(var a: path; s:string);\r
var l: integer;\r
begin\r
  l := length(s);\r
  if l > pathlength then l := pathlength;\r
  a := copy(s, 1, l);\r
end;\r
\r
procedure savepath(s: string; var n: alfa; var p1,p2: path);\r
var b1, b2, e: byte;\r
begin\r
  b1 := pos('-', s);\r
  e  := b1;\r
  if b1 > 0 then\r
  begin\r
    s[b1] := chr(26);\r
    e     := e - 1;\r
  end else e := length(s);\r
  assign_alfa(n, copy(s,1+1,e-1));\r
  b2 := pos('-', s);\r
  e  := b2;\r
  if b2 = 0 then e := length(s) else e := e - 1;\r
  if b1 > 0 then\r
  begin\r
    assign_path(p1, copy(s,b1+1,e-b1));\r
    if b2 > 0 then\r
    begin\r
      s[b2] := chr(26);\r
      e := pos('-', s);\r
      if e = 0 then e := length(s) else e := e - 1;\r
      assign_path(p2, copy(s, b2+1, e-b2));\r
    end;\r
  end;\r
end;\r
\r
procedure paramput(s: string);\r
var i: word;\r
begin\r
  for i := 1 to length(s) do\r
  if (s[i] >= 'A') and (s[i] <= 'Z') then\r
    s[i] := chr(ord(s[i]) - ord('A') + ord('a'));\r
\r
  if pos('paramin', s) = 1 then\r
  begin\r
    paramfile(s);\r
  end else\r
  if pos('=', s) = 1 then\r
  begin\r
    savepath(s, leftside, path1_name, path2_name);\r
  end else\r
  if pos('/', s) = 1 then\r
  begin\r
    savepath(s, programname, rtp35_pathname, rtp35_pathname);\r
  end else\r
  begin\r
    if length(paramrec) + length(s) + 1 > 255 then paramadd;\r
    paramrec := concat(paramrec, ' ', s);\r
  end;\r
end;\r
\r
procedure findset(name: string; var res: path);\r
Var\r
    e    	:  integer;\r
    envirseg	:  ^word;\r
    envir	:  ^char;\r
    setname     :  string;\r
begin\r
\r
  res      := '';\r
\r
  envirseg := ptr( prefixseg, $2c);\r
  e        := 0;\r
  envir    := ptr ( envirseg^, e);\r
  while envir^ <> chr(0) do\r
    begin\r
      setname := '';\r
      repeat\r
        if (envir^>='A') and (envir^<='Z') then\r
        begin\r
          setname := setname + envir^;\r
        end else\r
        if (envir^>='0') and (envir^<='9') then\r
        begin\r
          setname := setname + envir^;\r
        end;\r
        e     := e + 1;\r
        envir := ptr(envirseg^, e);\r
      until envir^ = '=';\r
      e      := e + 1;\r
      envir  := ptr(envirseg^, e);\r
      while envir^ <> chr(0) do\r
      begin\r
        if setname = name then res := res + envir^;\r
        e     := e + 1;\r
        envir := ptr(envirseg^, e);\r
      end;\r
      e     := e + 1;\r
      envir := ptr(envirseg^, e);\r
    end;  (*  while  *)\r
\r
end;\r
\r
(*$F+*) procedure myexit; (*$F-*)\r
begin\r
  exitproc := exitptr;\r
end;\r
\r
begin\r
\r
  exitptr  := exitproc;\r
  exitproc := @myexit;\r
\r
  for i := 0 to 9 do hexnumber[i]    := chr(i+48);\r
  for i := 0 to 5 do hexnumber[10+i] := chr(i+65);\r
\r
  paramrec  := '';\r
  paramhead := nil;\r
  assign_alfa(leftside, '');\r
  assign_alfa(programname, '');\r
  assign_path(rtp35_pathname, '');\r
  assign_path(path1_name,'');\r
  assign_path(path2_name,'');\r
  assign_path(source_path,'');\r
\r
  for i := 1 to paramcount do paramput(paramstr(i));\r
  paramadd;\r
  paraminverse;\r
\r
  if rtp35_pathname = '' then findset('RTPPATH', rtp35_pathname);\r
  if path1_name     = '' then findset('RTPWORK1',path1_name);\r
  if path2_name     = '' then findset('RTPWORK2',path2_name);\r
\r
  if rtp35_pathname = '' then\r
  begin\r
    rtp35_pathname := paramstr(0);\r
    repeat\r
      delete(rtp35_pathname, length(rtp35_pathname), 1);\r
      i := length(rtp35_pathname);\r
      if copy(rtp35_pathname, i, 1) = chr(92) then i := 0;\r
    until i = 0;\r
  end;\r
\r
  set_path_end(rtp35_pathname);\r
  set_path_end(path1_name);\r
  set_path_end(path2_name);\r
\r
  setcbreak(true);\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦2d3a92189⟧ TextFile

Derivation

TextFile
