{*****************************************************************
                        Copyright 1984 by
                        NCR Corporation
                        Dayton, Ohio  U.S.A.
                        All Rights Reserved
******************************************************************
                        EOS Software produced by:
                        NCR Systems Engineering - Copenhagen
                        Copenhagen
                        DENMARK
*****************************************************************}
 
{$h=0} { no heap space }
object program Appl;
CONST
  orgSys = 7; {dummy valye}
{$L-}
{$F=FAMILY.UNIV.ID}
{$F=FAMILY.KNEL.ID}
{$F=FAMILY.IOSYS.ID}
{$F=FAMILY.ALLOC.ID}
{$F=FAMILY.SCHED.ID}
{$F=FAMILY.OBJDIR.ID}
{$F=FAMILY.APPLI.ID}
{$F=PASINCLU.MIKTYPES.SA}
{$F=PASINCLU.TERMTOOL.SA}
{$L+}
 
function retRes
  (main,
   family,
   argNo: integer)
  : resultType;
  var res: resultType;
begin
  res.main:=main;
  res.family:=family;
  res.argNo:=argNo;
  res.orgNo:=0;
  res.orgSys:=7;
  retRes:=res;
end;
 
function random (var seed : integer ) : integer;
  const
    mult  = 50767;
    incr  = 49999;
    modul = 99991;
  begin
    random := abs(seed);
    seed := (mult * seed + incr) mod modul;
  end;
 
{local definitions}
type
  demoLocals = record
    code      : ^^;
    stubRef   : ^^ ObjDir;
    fao       : faoRefType;
    stdin     : faoRefType;
    stdout    : faoRefType;
    stderror  : faoRefType;
  end;  {demoLocals}
 
program ImplAppl object Application with demoLocals;
 
procedure checkOk
  (res: resultType;
   text: shortId);
  var line: threeLines;
begin
  if res.main<>ok then begin
    putError(line,res,text,0);
    res:=termIo(stdout,WriteSeq,line);
    if res.main=ok then exception(retRes(GiveUp,Universal,0))
    else exception(res);
  end;
end {***checkOk***};
 
ENTRY Run {fileEnv, jobSys; progrId (,text...)}
    with record
      tt: ^^;
      filsys: ^^ IoSys;
    end;
  const
    bufsize = 256;
  var
    i: integer;
    filesize, used, no, seed, key, pos: integer;
    clearline: array[1..75] of char;
    buf : array [1..bufsize] of byte;
    line : array [1..85] of char;
    res : resultType;
    masterFile: shortid;
    optionArg : shortid;
    oneline: boolean;
begin
  in
    CheckOk(Copy(fileEnv^^[1],stdin),'');
    CheckOk(Copy(fileEnv^^[2],stdout),'');
    CheckOk(Copy(fileEnv^^[3],stderror),'');
    {output welcome message on terminal}
      clearText(line);
      putText(line,'tpdemo  release 00.02   83-07-01');
      putNL(line);
      for i:=2 to 74 do clearline[i]:=' ';
      clearline[1]:=chr(13); clearline[75]:=chr(13);
      check(termIo(stdout,WriteSeq,line));
    { open file "text" }
    if not NextValArg(masterFile) then
      exception(retRes(-DataValueIllegal,Universal,-2));
    if elements(masterfile)=0 then
      checkOk(retRes(DataValueIllegal,Universal,-1),'');
    i:=1;
    while masterfile[i]=' ' do begin
      i:=i+1;
      if i>elements(masterfile) then
        checkOk(retRes(DataValueIllegal,Universal,-1),'');
    end;
    CheckOk(stubRef.GetRef(out filsys;
             masterFile[i..elements(masterfile)],out used, 0),
             masterFile[i..elements(masterfile)]);
    used:=used+i-1;
    CheckOk(filsys.Assign(out fao;
                masterFile[used+1..elements(masterFile)],ReadRight),
                masterFile[used+1..elements(masterFile)]);
 
    { check echo option - "O(neline)" means echo on same line }
    oneline := false;
    if nextValArg(optionArg) then
      if elements(optionArg) > 0 then
        oneline := (optionArg[1]='o') or (optionArg[1]='O');
 
    { read records randomly from file }
    filesize := wordmax;
    while true do
    begin
      clearText(line);
      if oneline then
        putText(line,clearline)
      else
        putNl(line);
      checkOk(termIo(stdOut,writeSeq,line),'');
      pos := 1;
      no := 0;
      repeat
        no := no+1;
        key := random(seed) mod filesize;
        res:=fao.ReadRandom (var in out buf ;
                                   out used, key,out key);
        if res.main=ok then begin
          clearText(line);
          putInt(line,key ,8);
          checkOk(termIo(stdout,WriteSeq,line),'');
        end else begin
          { error in ReadRandom, if unknown block then reduce filesize
            and read again
          }
          if (res.Family=IoFamily) and (res.main=-PosOutsideRange) then
          begin
            filesize := key - 1;
            no := no-1;
          end else
            if (res.orgSys=Universal) and (res.Family=dummyfied-1) then begin
              clearText(line);
              putText(line,'***Program status: File System removed ');
              putNL(line);
              exception(termIo(stdout,WriteSeq,line));
            end else
              checkOk(res,'');
        end;  { error in Read }
      until no = 9 ;
    end;  { while true }
  do begin
    res:=getException;
    res.orgNo:=0;
    res.orgSys:=7;
  end;
  ObjReturn(res);
end;  { Run }
 
entry pascalerror with record tt:^^ end;
begin end;
 
  otherwise unknownCall with record tt:^^; end;
  begin
    exception (retRes(-EntryIllegal,Universal,2));
  end;
 
end;  { DemoImplement }
 
initialize ImplAppl 'tpdemo':
           stubRef 'objdir'
end.