module f77init;
{ updated 21/3/82 - function openfile defined }
{ updated 23/4/82 - real underflow dealt with in handler all }
{                   procedure movebee inserted }
{ updated 3 may  -  div 2 inserted in dblelen , local areas}
{ updated 4 may  -  localrec string dispensed with}
{         5 may -  size of area and common tables increased to 32}
{         7 may -  remove newline after x chars from iocp}
{        25 may - increase size of comarea & startad }
{                 set initial values of locind & comind to 0 }
{                 define constant maximum values for them }
{                 check against these values before creating new area  }
{                 reduce length of name in comrec & list6rec }
{                 set bc flag false if named common }
{                 set startad[areaind] if blank common already exists }
{                 set data to startad[areaind] if preinitialising }
{                 comment out any references to locarea }
{                 comment out any references to rootnam }
{       28/may/82 - fault in initialisation of arrays greater then 32kw fixed
{                   in routine fill.}
{        3/6/82 - Correct calculation of segment size(fsize) so that 64K word
{                 area can be created }
{        4/6/82 - set flag if compiling as opposed to running a user program.}
{               - procedure to set file type added.}
{        7/6/82 - arearange becomes 1..140}
{                 debug boolean added to initcomp }
{                 define maxcomarea & maxtotarea constants }
{                 remove listrange type & lind variable }
{        8/6/82 - code in initialise to look for /debug and set debugging }
{               - new procedure nominateproc }
{ init19 18/6/82 - increase maxcomarea & maxlocarea }
{ INIT20 12/8/82 - use BIGAREA - routine createarea added}
{                - remove setfiletype - 3R recommend not setting type.}
{                - rewrite ldata list 6 handling  and
{                  remember commons in linked list on heap rather than in
                   an array in on stack to save globals
                   Total areas (commons+locals) raised to 400}
{        23/7/82 - report error if trying to initialise exisitng common }
  

exports
imports filedefs from filedefs;
imports filesystem from filesystem;
imports fileutils from fileutils;
imports memory from memory;
imports clock from clock;
imports filedir from filedir;
imports cmdparse from cmdparse;


type buff84=packed array[1..84] of char;

procedure unsatref;
procedure initmain;
procedure INITGLA;
function iocp(ep,off,seg:integer):integer;
procedure stop;
procedure iwrite(val,place:long);
procedure newseg(var s:segmentnumber;fsize,fincr,fmax:mmextsize);
procedure extendseg(s:segmentnumber;fsize:mmextsize);
procedure decrefseg(s:segmentnumber);
procedure readblock(idfile,block:integer;buff:pdirblk);
procedure writeblock(idfile,block:integer;buff:pdirblk);
procedure closefile(idfile,blks,bits:integer);
procedure getline(var buff:buff84;var len:integer);
procedure initcomp(list,err,debug:boolean);
function openfile(var filename:pathname;var blks,bits:integer):fileid;
procedure dateandtime(var str:timestring);
function createfile(namead:pointer):fileid;
function filelookup(filename:pathname;var blocks,bits:integer):fileid;
procedure extendfilename(var filename:pathname;nulliserror:boolean);
procedure destroyfile(name:pathname);
procedure movebee;
procedure nominateproc(procid,p1,p2,p3,p4:integer);


const maxlocarea=128;
      
type str8=string[8];
    str31=string[31]; 
    pstr31=^str31; 
     acb=record 
                ep,rr,ra,rs,tl,gl,dl,lp,sl:fsbit16 
                end;
     acbptr=^acb;
     txtptr=^text;
     header = record
                dict:fsbit16;
                rts:fsbit16;
                ldata:fsbit16;
                area:fsbit16
              end;           
     headptr=^header;
     codemaprec = record
                    start:fsbit16;
                    props:fsbit16;
                    len:long
                  end;
     codemap=array[1..10] of codemaprec;
     codemapptr=^codemap;
     ldatamap=array[0..10] of fsbit16;
     ldataptr=^ldatamap;
     comptr=^comrec;
     comrec=record
              ad:fsbit32;
              len:long;
              props:fsbit16;
              name:str8;
              next:comptr           
            end;

var INITFLAG:integer;
    ss:fsbit16;
    listing,errlist,dlist:boolean;
    rungotten:boolean;
    tin,tout,dfile,lfile,efile:text;
    curout,curin:txtptr;
    firstcommon:comptr;
    debugging,compiling:boolean;
    cfvrd1,cfvrd2,cfvrd3,cfvrd4:integer;  { remember closefiles var. rt desc.}
                  
private
imports f77dctl from f77dctl;
imports except from except;
imports system from system;
imports perq_string from perq_string;
imports utilprogress from utilprogress;
imports BIGAREA from BIGAREA;


const {$Include acb.dfs}
      {$Include except.dfs}

type string255=string[255];
     pstr=^string255;
var outptr:integer;
    imprs,imprr,impgp,impsl:fsbit16;


procedure movewords(srce,dest:fsbit32;len:integer);
begin
loadadr(dest^);
inlinebyte(227); { tlate1 }
loadadr(srce^);
inlinebyte(227);
loadexpr(len);
inlinebyte(170); { movw }
end;

procedure movebytes(srce,dest:fsbit32;srceoff,destoff,len:fsbit16);
begin
loadadr(dest^);
inlinebyte(227); { tlate1 }
loadexpr(destoff);
loadadr(srce^);
inlinebyte(227);
loadexpr(srceoff);
loadexpr(len);
inlinebyte(168); { mvbw }
end; { movebytes }

procedure adjlen(dblelen:long;var oflo,singlelen:integer);
begin
singlelen:=shrink(dblelen mod 32768);
oflo:=shrink(dblelen div 32768);
end; { adjlen }

procedure fill(startad:fsbit32;len,value:fsbit16);
var i:integer;
highad:fsbit32;
begin

if len = 32767 then begin
  highad := recast(recast(startad,long)+32767,fsbit32);
  highad^ := value;
  len := 32766;
end;

for i:=0 to len do
  begin
  startad^:=value;
  startad:=recast(recast(startad,long)+1,fsbit32);
  end;
end; { fill }


procedure setin(var infile:text;var inptr:txtptr);
var inadr:fsbit16;
begin
loadadr(infile);
storexpr(inadr);
inptr:=makeptr(ss,inadr,txtptr);
end; { setin }

procedure setout(var outfile:text;var outptr:txtptr);
var outadr:fsbit16;
begin
loadadr(outfile);
storexpr(outadr);
outptr:=makeptr(ss,outadr,txtptr);
end; { setout }
 
procedure badarea;
begin
  writeln(curout^);
  writeln(curout^,'Loader Fails - Bad area number specified');
  raise exitprogram;
end;



PROCEDURE INITIALISE;
var i:integer;
    ch:char;
    id:Cstring;
    isswitch:boolean;
BEGIN
ss:=loadss;
setin(tin,curin);
reset(curin^,'console:');
setout(tout,curout);
rewrite(curout^,'console:');
{ writeln(curout^,'entering initialise'); }
INITFLAG:=999;
OUtPTR:=0;
compiling:=false;
listing:=false;
errlist:=false;
dlist:=false;
firstcommon:=nil;
rungotten:=false;

debugging:=false;
{ look at rest of input line for /debug }
{ at compile time, input line will already have been analysed and initcomp
{ will set debugging }
ch:=nextid(id,isswitch);
if isswitch then
  begin
  convupper(id);
  if id='DEBUG' then debugging:=true;
  end else if ch<>ccr then
  begin
  ch:=nextid(id,isswitch);
  if isswitch then
    begin
    convupper(id);
    if id='DEBUG' then debugging:=true;
    end;
  end;
  cfvrd1:=0;
  cfvrd2:=0;
  cfvrd3:=0;
  cfvrd4:=0;

{ writeln(curout^,'stack segment is',ss); }
{writeln(curout^,'exit from initialise');}
END; { INITIALISE }


procedure Loaderror(text:string);
  begin
  writeln(curout^,'Terminal error found by Fortran Loader - ',text);
  raise exitprogram
end;


PROCEDURE createarea(var startad:fsbit32;blks:integer;text:string);
var s:segmentnumber;

   {Catch exceptions from BIGAREA in order to make clear to user that this is
     a size limitation, not a break in the loader }
    
  HANDLER FullMemory;  
  begin
    Loaderror('Unable to create area of required size - Exception Full Memory')
  end;

  HANDLER NoFreeSegments;
  begin
    Loaderror('Unable to create area of required size - Exception NoFreeSegments')
  end;
  
begin
            {Assume size in blocks is less than 32k or 16 Mbytes}
 if debugging then write(curout^,text,' of ',blks:6,' blocks ');
            {claim contiguous space}
 if blks>256 then createbigarea(s,blks,256) else createsegment(s,blks,1,256);
 if debugging then writeln(curout^,'in segment',s:5);
  startad:=makeptr(s,0,fsbit32)            {return start address}
end;


PROCEDURE copygla(cs,gp:fsbit16);   { LOADER }
label 10,40;
const fincr=1; fmax=256;    {mmmaxblocks}
      maxtotarea=400;

type list6rec=record
                area,link:fsbit16;
                len:long;
                props:fsbit16;
                name:str8
              end;
     list7rec=record
                area,link:fsbit16;
                disp:long;
                len,copies:fsbit16
              end;
     fix16array=array[1..5000] of fsbit16;
     list8rec=record
                link:fsbit16;
                num:fsbit16;
                fix:fix16array
                end;
     fix32=record
                disp:fsbit16;
                area:fsbit16
                end;
     fix32array=array[1..5000] of fix32;
     list9rec=record
                link:fsbit16;
                num:fsbit16;
                fix:fix32array
              end;
     list6ptr=^list6rec;
     list7ptr=^list7rec;
     list8ptr=^list8rec;
     list9ptr=^list9rec;
     arearange=1..maxtotarea;
     longptr=^long;
var gdb,srce,word,data:fsbit32;
    dest:array[1..2] of fsbit32;
    startad:array[1..maxtotarea] of fsbit32;
    areaptr,areadisp,areastart:long;
    codearea:codemapptr;
    codehd:headptr;
    areaind:arearange;
    ldata:ldataptr;
    ldat6:list6ptr;
    ldat7:list7ptr;
    ldat8:list8ptr;
    ldat9:list9ptr;
    dbleword:longptr;
    dblelen:long;
    fsize:integer;
    nseg:segmentnumber;
    rootnam:pstr31; 
    name:str8;
    local_area,data_init,area_to_be_preset,bc:boolean;
    len,oflolen,dstart,ldataoff,link,num,props,glaoff,areaoff,i,j:fsbit16;
    pre_set_pattern:fsbit16;
    tim:timestring;
    comarea,com,last:comptr;

begin
{WRITELN(CUROUT^,'ENTERING COPYGLA');}
gdb:=makeptr(ss,gp,fsbit32);
codehd:=makeptr(cs,0,headptr);
codearea:=makeptr(cs,codehd^.area,codemapptr);

{----------------------------------
{      initialise data areas
{----------------------------------

{ areas 2 & 5 }

for i := 1 to 6 do begin  { remember addresses of areas }
   startad[i] := makeptr(cs,codearea^[i].start,fsbit32);
end;

for i := 7 to maxtotarea do begin   { put bad area marker in table}
  startad[i] := makeptr(0,0,fsbit32);
end;

areaind:=2;
dest[1]:=gdb;
for i:=1 to 2 do
  begin
  {WRITELN(CUROUT^,'ldata[',areaind:1,']');}
  startad[areaind] := dest[i];  { adjust startad to loaded address}
  if codearea^[areaind].len=0 then goto 10;
  adjlen(codearea^[areaind].len,oflolen,len);
  srce:=makeptr(cs,codearea^[areaind].start,fsbit32);
  for j:=1 to oflolen do
    begin
    movewords(srce,dest[i],32767);
    srce:=recast(recast(srce,long)+32767,fsbit32);
    dest[i]:=recast(recast(dest[i],long)+32767,fsbit32);
    dest[i]^:=srce^;
    srce:=recast(recast(srce,long)+1,fsbit32);
    dest[i]:=recast(recast(dest[i],long)+1,fsbit32);
    end;
  movewords(srce,dest[i],len);
  10:
  if i=1 then
    begin
    dest[2]:=recast(recast(gdb,long)+codearea^[areaind].len,fsbit32);
    areaind:=5;
    end;
  end;

{-----------------------------------------------------------}
{   Process Ldata list 6 to create common and local areas   }
{-----------------------------------------------------------}

LDATAOFF:=CODEHD^.LDATA;
LDATA:=MAKEPTR(CS,LDATAOFF,LDATAPTR);
if debugging then begin
  rootnam:=makeptr(cs,ldata^[10]+ldataoff,pstr31);
  writeln(curout^,'Loading ',rootnam^);
end;

link:=ldata^[6];
while link<>0 do begin                              {chain through list 6}
  ldat6:=makeptr(cs,link+ldataoff,list6ptr);
  areaind:=ldat6^.area;
  props:=ldat6^.props;
  dblelen:=(ldat6^.len+1) DIV 2;
  fsize:=shrink(dblelen div 256)+1;
  if (dblelen mod 256 = 0) then fsize:=fsize-1;
  if land(props,1)<>0 then local_area:=false       else local_area:=true;
  if land(props,2)<>0 then begin
    name:='F#BLCM';
    bc:=true
  end else begin
    name:=ldat6^.name;
    bc:=false
  end;
  if land(props,4)<>0 then data_init:=true         else data_init:=false;
  if land(props,8)<>0 then area_to_be_preset:=true else area_to_be_preset:=false;
  if land(props,16)<>0 then pre_set_pattern:=#100200 else pre_set_pattern:=0;

  
  if local_area then createarea(startad[areaind],fsize,  'creating local area')
  else begin        {common area}
    comarea:=firstcommon;
    while comarea<>nil do begin              { search list of commons }
      if comarea^.name=name then begin        { common area found }
        if debugging then writeln(curout^,'  Mapping on common area ',name);
        startad[areaind]:=comarea^.ad;
        if bc then begin                      { make blank common checks}
          if dblelen>comarea^.len then
            Loaderror('Blank common is larger than first blank common found')
        end else begin                        {make named common checks}
          if dblelen<>comarea^.len then
            Loaderror(concat(name,' is a common with inconsistent lengths'));
          if data_init then                  {Double pre-init is ok}
            Loaderror(concat(name,' is a common doubly initialised'))
        end;
        goto 40   { finished processing this common }
      end;  {of area found }
      last:=comarea;
      comarea:=comarea^.next
    end; {of search loop - drop through means a new area to be created }
    
    createarea(startad[areaind],fsize,concat('creating a common area ',name));
    NEW(com);
    if com=nil then Loaderror('Heap exhausted');
    if firstcommon=nil then firstcommon:=com else last^.next:=com;
    com^.next:=nil;
    com^.name:=name;
    com^.ad:=startad[areaind];
    com^.len:=dblelen;
    com^.props:=land(props,12) { save bits 2,3 of org props }
  end;{ of common area }
  
  if area_to_be_preset then begin    
    dblelen:=dblelen-1;
    adjlen(dblelen,oflolen,len);
    data:=startad[areaind];
    for i:=1 to oflolen do begin
      fill(data,32767,pre_set_pattern);
      data:=recast(recast(data,long)+32768,fsbit32)
    end;
    fill(data,len,pre_set_pattern)
  end;

40: link:=ldat6^.link;
end;

{------------------------------------
         data initialisation
--------------------------------------}
{ ldata[7] }

{writeln(curout^,'ldata[7]');}

link:=ldata^[7];
while link<>0 do
  begin
  ldat7:=makeptr(cs,link+ldataoff,list7ptr);
  areaind:=ldat7^.area;
  areastart:=recast(startad[areaind],long);
  if areastart=0 then badarea;
  num:=ldat7^.copies; len:=ldat7^.len;
  dstart:=link+ldataoff+6;
  data:=makeptr(cs,dstart,fsbit32);
  for i:=0 to num-1 do
    begin
    areadisp:=ldat7^.disp+len*i;
    areaoff:=shrink(areadisp mod 2);
    areadisp:=areadisp div 2;
    areaptr:=areastart+areadisp;
    movebytes(data,recast(areaptr,fsbit32),0,areaoff,len);
    end;
  link:=ldat7^.link;
  end;
              
                  
{------------------------------------
{        perform relocation
{------------------------------------
{ ldata[8] & [9] }


{ ldata[8] }

{writeln(curout^,'ldata[8]');}

LINK:=LDATA^[8];
WHILE LINK<>0 DO
  BEGIN
  LDAT8:=MAKEPTR(CS,LINK+LDATAOFF,LIST8PTR);
  NUM:=LDAT8^.NUM;
  FOR I:=1 TO NUM DO
    BEGIN
    word:=recast(recast(gdb,long)+ldat8^.fix[i],fsbit32);
    WORD^:=WORD^+GP;
    END;
  LINK:=LDAT8^.LINK;
  END;

{ ldata[9] }

{writeln(curout^,'ldata[9]');}

LINK:=LDATA^[9];
WHILE LINK<>0 DO
  BEGIN
  LDAT9:=MAKEPTR(CS,LINK+LDATAOFF,LIST9PTR);
  NUM:=LDAT9^.NUM;
  FOR I:=1 TO NUM DO
    BEGIN
    areaind := ldat9^.fix[i].area;
    areastart := recast(startad[areaind],long);
    if areastart=0 then badarea;
    dbleword:=recast(recast(gdb,long)+ldat9^.fix[i].disp,longptr);
    DBLEWORD^:=DBLEWORD^+areastart;
    END;
  LINK:=LDAT9^.LINK;
  END;

{WRITELN(CUROUT^,'EXIT FROM COPYGLA');}
end; { copyGLA }

procedure run;

begin { run }
{ load variable routine descriptor }
loadexpr(impsl);
loadexpr(IMPrr);
loadexpr(IMPgp);
loadexpr(IMPrs);
inlinebyte(187); { callv }
{writeln(curout^,'exit from imp program - should we reach here');}
end; { run }

procedure unsatref;
begin
writeln(curout^,'unsatisfied reference');
ndiag(0,0,0,0);
end; { unsatref }

procedure initmain;
var ap,dl,impap:fsbit16;
    gdb1:fsbit32;
    acb0,impacb:acbptr;
    wfile:pathname;

handler all(es,er,pstart,pend:integer);
label 10;
type dblerec=record msw,lsw:integer end;
     dbleptr=^dblerec;
     psys9s=^sys9s;
var raiseap,ap:fsbit16;
    acball:acbptr;
    estack:dbleptr;
    retstr:psys9s;
    seg,off:fsbit32;
begin
{ pass on seg faults & stack overflow }
if (es=excseg) and ((er=errsegmentfault) or (er=errstackoverflow)) then
  raisep(es,er,pstart,pend)

{ pass on ctlc,ctlcabort,exitprogram }
else if (es=firstsystemseg) then
  begin
  if er=errctlc then raise ctlc
  else if er=errctlcabort then raise ctlcabort
  else if er=errexitprogram then raise exitprogram
  else if er=errhelpkey then
    begin
    off:=makeptr(ss,pstart,fsbit32);
    seg:=recast(recast(off,long)+1,fsbit32);
    retstr:=makeptr(seg^,off^,psys9s);
    raise helpkey(retstr^);
    end
  else
    begin
    goto 10;
    end;
  end

else begin
  10:
  inlinebyte(244); {ldap }
  storexpr(ap);
  acball:=makeptr(ss,ap,acbptr); {acb of all }
  raiseap:=acball^.dl; {ap of raise }
  if (es=excseg) and (er=errunderreal) then
    begin
    {writeln(curout^,'* Real underflow trapped');}
    estack:=makeptr(ss,raiseap+acbsavestack,dbleptr);
    estack^.lsw:=0;
    estack^.msw:=0;
    end else diags(raiseap,es,er,pstart,pend);
end;
end; { ALL }

begin {initmain }
IF INITFLAG=0 THEN INITIALISE;
{writeln(curout^,'entering initmain');}
inlinebyte(244); { ldap }
storexpr(ap); { ap of initmain }
acb0:=makeptr(ss,ap,acbptr); { acb of initmain }
imprs:=acb0^.rs; { ssn of calling prog }
impgp:=acb0^.gl;{ gp of calling prog }
gdb1:=makeptr(ss,impgp,fsbit32);
if gdb1^=0 then copygla(imprs,impgp);
impap:=acb0^.dl; { ap of calling prog }
impacb:=makeptr(imprs,impap,acbptr);
impsl:=impacb^.sl; { sl of calling prog}
imprr:=acb0^.rr;{ return routine of calling prog }
run;
{ return here from STOP }
{writeln(curout^,'returned to initmain');}
if compiling then begin
  wfile:='F_TEMP';
  FIXFILENAME(wfile,false);
  destroyfile(wfile);
  wfile:='t_wrk$';
  FIXFILENAME(wfile,false);
  destroyfile(wfile);
end;
setout(tout,curout);
if listing then close(lfile);
if errlist then close(efile);
raise exitprogram;
end; { INITMAIN }
 
procedure initcomp;
begin
listing:=list;
errlist:=err;
debugging:=debug;
compiling:=true;
end; { initcomp }

PROCEDURE initgla;
var ssn,ap,gp:fsbit16;
    gdb1:fsbit32;
    acb0:acbptr;
begin
if initflag=0 then initialise;
{writeln(curout^,'entering initgla');}
inlinebyte(244); { ldap }
storexpr(ap); { ap of initgla }
acb0:=makeptr(ss,ap,acbptr);{ acb of initgla }
ssn:=acb0^.rs; { ssn of calling prog }
gp:=acb0^.gl; { gp of calling prog }
copygla(ssn,gp);
{writeln(curout^,'exit from initgla');}
end; { INITGLA }

function iocp;
CONST NL=10; NP=12;
      CR=13;RTMARGINS=132;
var i,j,k:integer;
    strn:pstr;
    ch:char;
    lf:boolean;
begin
case ep of
  1:begin
    read(curin^,ch);
    iocp := ord(ch)
  end;
  3,5:begin
        j:=land(off,#177);
        if (j=nl) or (j=np) then begin
          writeln(curout^);outptr:=0;
          if j=np then write(curout^,chr(np));
        end else begin
          write(curout^,chr(j));outptr:=outptr+1;
          if outptr>=rtmargin then begin
            {writeln(curout^)}; outptr:=0;
          end;
        end;
        iocp:=0;
      end;
7:begin
      strn:=makeptr(seg,off,pstr);
      k:=length(strn^);
      for i:=1 to k do begin
        j:=land(ord(strn^[i]),#177);
        if j=nl then begin
          writeln(curout^);outptr:=0;
        end else begin
          write(curout^,chr(j)); outptr:=outptr+1;
          if  outptr>=rtmargin then begin
            writeln(curout^); outptr:=0;
          end;
        end;
      end;
      iocp:=0;
    end;
  9:begin
      if outptr>0 then
        begin
        writeln(curout^);
        outptr:=0;
        end;
      case off of
       0:setout(tout,curout);
       1:begin
         if listing then setout(lfile,curout)
         else begin
           writeln(curout^,'listing file does not exist');
           ndiag(0,0,0,0);
           end;
         end;
       2,107:begin
             if dlist then setout(dfile,curout)
             else begin
               writeln(curout^,'diagnostic file does not exist');
               ndiag(0,0,0,0);
               end;
             end;
       3:begin
         if errlist then setout(efile,curout)
         else begin
           writeln(curout^,'error file does not exist');
           ndiag(0,0,0,0);
           end;
         end;
       end;
    end;
 15:begin
       strn:=makeptr(seg,off,pstr);
       k:=length(strn^);
       if k<>0 then begin
         if ord(strn^[k])=nl then begin
           lf:=true;
           strn^[k]:=chr(cr);
           outptr:=-k;
         end;
         write(curout^,strn^);outptr:=outptr+k;
         if lf then write(curout^,chr(nl));
       end;
       iocp:=0;
     end;
  16:close(curout^);
  17:begin
       j:=shift(off,-8);
       off:=land(off,#177);
       for k:=1 to j do i:=iocp(3,off,0);
       iocp:=0;
     end;
  otherwise:begin
              writeln(curout^,'IOCP ',ep:2,' not implemented');
              raise dump('dump from iocp');
              stop;
            end;
  end;
end; { IOCP }

procedure stop;
begin
{writeln;}
if debugging then writeln(curout^,'%stop called ***');
exit(run);
{writeln(curout^,'end of stop');}
end;

procedure iwrite;
begin
if val<0 then write(curout^,val:shrink(place)+1)
  else write(curout^,' ',val:shrink(place));
end;

procedure newseg;
begin
createsegment(s,fsize,fincr,fmax);
if debugging then writeln(curout^,'NEWSEG - new segment ',s:3,
                          ' of size',fsize:4,fincr,fmax);
end; { newseg }

procedure extendseg;
var i:integer;
begin
if debugging then writeln(curout^,'EXTENDSEG - extending segment ',s:3,
                          ' to',fsize:3,' blocks');
changesize(s,fsize);
end; {extendseg }

procedure decrefseg;
begin
decrefcount(s);
end; {decrefseg }

procedure readblock;
begin
{writeln(curout^,'reading a block',idfile,block);}
fsblkread(idfile,block,buff);
end;

procedure writeblock;
begin
{writeln(curout^,'writing a block',idfile,block);}
fsblkwrite(idfile,block,buff);
end;

function openfile;
begin
openfile:=fsextsearch(fssyssearchlist,' ',filename,blks,bits);
end; { openfile }

procedure closefile;
begin
{writeln(curout^,'closing a file ',idfile,'blks = ',blks,'bits = ',bits);}
fsclose(idfile,blks,bits);
end;

procedure getline;
label 99;
var i:integer;
begin
i:=0;
while not eof(curin^) do
  begin
  while not eoln(curin^) do
    begin
    i:=i+1;
    if i<85 then buff[i]:=curin^^;
    get(curin^);
    end;
  len:=i;
  get(curin^);
  exit(getline);
  end;
buff[1]:=chr(25);
len:=1;
end; {getline }

procedure dateandtime;
  begin
    gettstring(str);
end;

function createfile;

  type pathptr=^pathname;
  var name:pathname;
      id:fileid;
      pp:pathptr;

  begin
    pp := recast(namead,pathptr);
    id := fsenter(pp^);     {returns fileid}
    {writeln(curout^,'creating file ',id);} 
    createfile := id;
end;

function filelookup;

  Handler FSNotFnd(name:Pathname);
    begin
    filelookup:=0;
    exit(filelookup)
  end;
  
  var i:integer;
  
  begin
    i:=fslookup(filename,blocks,bits);
    filelookup:=1
end;

procedure extendfilename;
  begin
    fixfilename(filename,nulliserror);
end;

function destroyfile;
  var i:segid;
  begin
    fsdelete(name);
end;

procedure movebee;
var i:integer;
begin
for i:=1 to 10 do showprogress(1); { move bee }
end;


procedure nominateproc;     { remember a var. rt. desc. for closefiles}
begin
  inlinebyte(110);    {LDL1}
  storexpr(cfvrd1);
  inlinebyte(111);    {LDL2}
  storexpr(cfvrd2);
  inlinebyte(112);    {LDL3}
  storexpr(cfvrd3);
  inlinebyte(113);    {LDL4}
  storexpr(cfvrd4);
  
end.