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 }


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);
procedure setfiletype(fileid,ftype:integer);


const maxcomarea=128;
      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;
     comrec=record
              seg:segmentnumber;
              len:long;
              props:fsbit16;
              name:str8           
            end;
{     localrec=record
                seg:segmentnumber;
                len:long
              end; }

var INITFLAG:integer;
    ss:fsbit16;
    listing,errlist,dlist:boolean;
    rungotten:boolean;
    tin,tout,dfile,lfile,efile:text;
    curout,curin:txtptr;
    comarea:array[0..maxcomarea] of comrec;
{   localarea:array[1..maxlocarea] of localrec; }
{   localind, } comind:integer;
    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 filetypes from filetypes;

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;
{ localind:=0; } comind:=0;
for i:=1 to maxcomarea do
  begin
  comarea[i].seg:=-1;
{ localarea[i].seg:=-1; }
  comarea[i].name:='';
  end;
comarea[0].seg:=-1;
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 copygla(cs,gp:fsbit16);
label 10,20,30,40;
const fincr=1; fmax=256;    {mmmaxblocks}
      maxtotarea=maxcomarea+maxlocarea+12;

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:mmextsize;
    nseg:segmentnumber;
{   rootnam:pstr31; }
    bc:boolean;
    len,oflolen,dstart,ldataoff,link,num,props,glaoff,areaoff,i,j:fsbit16;
    tim:timestring;

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;

{------------------------------------
      create common areas
-------------------------------------}
{ ldata[6] }

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


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

link:=ldata^[6];
while link<>0 do
  begin
  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;
  case land(props,1) of
  0:begin {local area}
  if debugging then writeln(curout^,'creating local area');

    if fsize>fmax then
      begin
      writeln(curout^,'new local area too big',dblelen);
      raise exitprogram;
      end;
{   if  localind=maxlocarea then
      begin
      writeln(curout^,'maximum permissible local areas(64) already exist');
      raise exitprogram;
      end; }

    createsegment(nseg,fsize,fincr,fmax);
    if debugging then writeln(curout^,'created local area segment',nseg:4,
                      ' size ',fsize:3,' id ',areaind:3);
    startad[areaind]:=makeptr(nseg,0,fsbit32);

{save info in localarea}
{    rootnam:=makeptr(cs,ldata^[10]+ldataoff,pstr31); }
{   localind:=localind+1; }
{   localarea[localind].name:=concat(rootnam^,ldat6^.name); }
{   localarea[localind].seg:=nseg; }
{   localarea[localind].len:=dblelen; }

    if (land(props,8)=8) then begin
      if (land(props,16)=16) then j := #100200 else j := 0;
      dblelen := dblelen -1;
      adjlen(dblelen,oflolen,len);
      data := startad[areaind];
      for i := 1 to oflolen do begin
        fill(data,32767,j);
        data := recast(recast(data,long)+32768,fsbit32)
      end;
      fill(data,len,j)
    end    
  end; {local areas }
  1:begin { common area }
    if debugging then writeln(curout^,
      'looking for common area with id ',areaind:3);
    if fsize>fmax then
      begin
      writeln(curout^,'new common area too big',dblelen);
      raise exitprogram;
      end;
    if (land(props,2)=2) then
      begin { blank common }
      bc:=true;
      i:=0;
      if comarea[0].seg<>-1 then goto 20; {blank common already exists}
      end else begin
        bc:=false;
        for i:=1 to comind do
         if (comarea[i].name=ldat6^.name) and (comarea[i].seg<>-1) then goto 20;      end;

    if debugging then writeln(curout^,'create new common area');
    createsegment(nseg,fsize,fincr,fmax);
    if debugging then writeln(curout^,'created common area segment',nseg:4,
                      ' size ',fsize:3,' id ',areaind:3);
    startad[areaind]:=makeptr(nseg,0,fsbit32);
    if bc then i:=0 else
      begin
      if comind=maxcomarea then
        begin
        writeln(curout^,'maximum permissible common areas already exist');
        raise exitprogram;
        end;
      comind:=comind+1;
      i:=comind;
      end;
    comarea[i].name:=ldat6^.name;
    comarea[i].seg:=nseg; comarea[i].len:=dblelen;
    goto 30;
    20: { area already exists }
    if debugging then writeln(curout^,'common area already exists');
    startad[areaind]:=makeptr(comarea[i].seg,0,fsbit32);
    if dblelen<>comarea[i].len then
      begin
        writeln(curout^,'common area ',ldat6^.name,' has inconsistent length');
        raise exitprogram;
      end;
    if (land(props,4)=4) then { area is to be initialised }
      if comarea[i].props<>0 then
        begin
        writeln(curout^,'common area',ldat6^.name,' already initialised');
        raise exitprogram;
        end;
    if comarea[i].props<>0 then goto 40; { area already initialised }
    30:
    comarea[i].props:=shift(land(props,12),-2); { save bits 2,3 of original props }
    if (land(comarea[i].props,2)=2) then { preinitialise }
      begin
      if (land(props,16)=16) then j:=#100200 else j:=0;
      dblelen:=dblelen-1;
      adjlen(dblelen,oflolen,len);
      data:=startad[areaind];
      for i:=1 to oflolen do
        begin
        fill(data,32767,j);
        data:=recast(recast(data,long)+32768,fsbit32);
        end;
      fill(data,len,j);
      end;
    40:end; { common area }
  end;
{writeln(curout^,'end create area');}

  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;

procedure setfiletype;
   var pentry:ptrFSdataentry;
   begin
   FSgetFSdata(fileid,pentry);
   pentry^.filetype:=ftype;
   FSsetFSdata(fileid,pentry);
end.