-h- close.pr 490
{$debug-}
MODULE MCLOSE;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'flush.dcl'}

{ close (PC) -- release file descriptor slot for open file }
procedure xclose (fd : filedesc);
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
begin
 if (fd > STDERR) and (fd <= MAXOPEN) then begin
  flush(fd);
  with openlist[fd] do begin
   close(filevar^); { in case buffered }
   dispose(filevar);
   dispose(buf);
   mode := IOAVAIL
  end;
 end
end;

END.
-h- create.pr 1102
{$debug-}
MODULE MCREATE;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ create (PC) -- create a file }
function create (var name : sstring; xmode : integer) : filedesc;
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
 i : integer;
 intname : packed array[1..MAXFN] of char;
 found : boolean;
begin
 i := 1;
 while (name[i] <> ENDSTR) do begin
  intname[i] := chr(name[i]);
  i := i + 1
 end;
 for i := i to MAXFN do
  intname[i] := ' '; { pad name with blanks }
 { find a free slot in openlist }
 create := IOERROR;
 found := false;
 i := 1;
 while (i <= MAXOPEN) and (not found) do begin
  if (openlist[i].mode = IOAVAIL) then with openlist[i] do begin
   mode := xmode;
   cpos := 0;
   new(buf);
   buf^ := NULL;
   new(filevar);
   filevar^.trap := TRUE;  {catch file open failure}
   assign(filevar^, intname);
   rewrite(filevar^);
   if (mode = IOREAD) then reset(filevar^);
   create := i;
   found := true;
   if filevar^.errs <> 0 then create := IOERROR;
   filevar^.trap := FALSE; {reset so we will exit on i/o error}
  end;
  i := i + 1
 end
end;

END.
-h- error.pr 518
{$debug-}
MODULE MERROR;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{$include:'putc.dcl' }
{$include:'putcf.dcl'}
{$include:'flush.dcl'}
procedure ENDXQQ; extern;

{ error (PC) -- write error message and exit }
{ note: string is not terminated by normal ENDSTR delimiter }
procedure error (const s : lstring);
var
 i : integer;
begin
 for i := 1 to ord(s[0]) do putcf(ord(s[i]),STDERR);
 putcf(NEWLINE,STDERR);
 flush(0);  { force write of standard output }
 ENDXQQ; { call system exit routine }
end;

END.
-h- flush.pr 805
{$debug-}
MODULE MFLUSH;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ flush (PC) -- forces writing of the given file buffer, or flushes }
{ all buffers if fd = 0 }
procedure flush (fd: filedesc);
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
 i : filedesc;
begin
 if fd = 0 then begin
  for i := STDOUT to MAXOPEN do
   if (openlist[i].mode = IOWRITE) and (ord(openlist[i].buf^[0]) > 0)
   then with openlist[i] do begin
    if i = STDOUT then
     write(buf^)
    else
     write(filevar^,buf^);
    buf^ := NULL;
   end;
 end
 else with openlist[fd] do
  if (fd >= STDOUT) and (fd <= MAXOPEN) and (mode = IOWRITE)
     and (ord(buf^[0]) > 0)
  then begin
   if fd = STDOUT then
    write(buf^)
   else
    write(filevar^,buf^);
   buf^ := NULL;
  end;
end;

END.
-h- gdate.pr 510
{$debug-}
MODULE MGDATE;

Type
 character = 0..255;  { byte-sized. ascii + other stuff }
 sstring = super packed array [1..*] of character;

Procedure DATE (var s: string); { NOTE: <-- this string is the IBM Pascal  }
	  external;		{ idea of a string, and not the Tools idea }

{ gdate (PC) -- get the current date as 8 characters like mm-dd-yy }
Procedure gdate (var s : sstring);
var
 dt : string(8);
 i  : integer;
begin
 date(dt);
 for i := 1 to 8 do s[i] := ord(dt[i]);
 s[9] := 0;  { ENDSTR }
end;

END.
-h- getarg.pr 1025
{$debug-}
MODULE MGETARG;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'nargs.dcl'}

{ getarg (PC) -- copy n-th command line argument into s }
function getarg (n : integer; var s : sstring;
  maxs : integer) : boolean;

var
 lpos [static] : parmptr;   { position of last argument asked for }
 lnum [static] : integer;   { number of last argument asked for   }
 lstr : parmstr;	    { pointer to parm string }
 parmtop  [extern] : parmptr;
 parmcnt  [extern] : integer;
 count : integer;
 i,j   : integer;
value
 lpos  := NIL; { we keep this so a sequential scan thru args is fast }

begin
 if (n > 0) and (n <= nargs) then begin
  if (lpos = NIL) or (n < lnum) then begin
   lpos := parmtop;
   lnum := 1;
  end;
  { get the argument }
  while (lnum <> n) do begin
   lpos := lpos^.next;
   lnum := lnum + 1;
  end;
  i := 1;
  lstr := lpos^.parm;
  repeat
   s[i] := lstr^[i];
   i := i + 1;
  until (s[i-1] = ENDSTR);
  getarg := true
 end
 else begin
  s[1] := ENDSTR;
  getarg := false;
 end;
end;

END.
-h- getc.pr 750
{$debug-}
MODULE MGETC;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ getc (PC) -- get one character from standard input }
{ This is a fast version which actually reads a line at a time and returns }
{ one character from a buffer }

function getc (var c : character) : character;
Label
 ReadBuf;
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
begin
 with openlist[STDIN] do begin
  if (cpos = 0) then
   if eof then begin
    c := ENDFILE;
    getc := c;
    return
   end
   else
ReadBuf:
    read(buf^);
  cpos := cpos + 1;
  if (cpos > ord(buf^[0])) then begin
   cpos := 0;
   if not eoln(input) then goto ReadBuf;
   readln;
   c := NEWLINE
  end
  else
   c := ord(buf^[cpos]);
 end;
 getc := c
end;

END.
-h- getcf.pr 746
{$debug-}
MODULE MGETCF;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'getc.dcl'}

{ getcf (PC) -- get one character from file }
function getcf (var c: character; fd : filedesc) : character;
Label
 ReadBuf;
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
begin
 if (fd = STDIN) then
  getcf := getc(c)
 else with openlist[fd] do begin
  if (cpos = 0) then
   if eof(filevar^) then begin
    c := ENDFILE;
    getcf := c;
    return
   end
   else
ReadBuf:
    read(filevar^,buf^);
  cpos := cpos + 1;
  if (cpos > ord(buf^[0])) then begin
   cpos := 0;
   if not eoln(filevar^) then goto ReadBuf;
   readln(filevar^);
   c := NEWLINE
  end
  else
   c := ord(buf^[cpos]);
 end;
 getcf := c
end;

END.
-h- getline.pr 492
{$debug-}
MODULE MGETLINE;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'getcf.dcl'}

{ getline (PC) -- get a line from file }
function getline (var s : sstring; fd : filedesc;
  maxsize : integer) : boolean;
var
 i : integer;
 c : character;
begin
 i := 1;
 repeat
  s[i] := getcf(c, fd);
  i := i + 1;
 until (c = ENDFILE) or (c = NEWLINE) or (i >= maxsize);
 if (c = ENDFILE) then { went one too far }
  i := i - 1;
 s[i] := ENDSTR;
 getline := (c <> ENDFILE)
end;

END.
-h- gtime.pr 510
{$debug-}
MODULE MGTIME;

Type
 character = 0..255;  { byte-sized. ascii + other stuff }
 sstring = super packed array [1..*] of character;

Procedure TIME (var s: string); { NOTE: <-- this string is the IBM Pascal  }
	  external;		{ idea of a string, and not the Tools idea }

{ gtime (PC) -- get the current time as 8 characters like hh:mm:ss }
Procedure gtime (var s : sstring);
var
 tm : string(8);
 i  : integer;
begin
 time(tm);
 for i := 1 to 8 do s[i] := ord(tm[i]);
 s[9] := 0;  { ENDSTR }
end;

END.
-h- initio.pr 8860
{$debug-}
{$include:'a:filkqq.inc'}
MODULE MINITIO;
uses filkqq;

{$include:'globcons.inc'}
  MAXARGS = 300;       { maximum number of args to be put into linked }
		       { list, necessary because of strange behavior  }
		       { caused by extremely long list ... sigh.      }

{$include:'globtyps.inc'}

{$include:'error.dcl'}
{$include:'putc.dcl'}

function  PPMUQQ (unused1: word; unused2: adrmem; var dst: lstring): word;
	  external;
function getfcb(vars fin,fout: dosfcb;	mode: integer): boolean; external;

{ initialize routine for software tools }
procedure initio;

label normchar,err;

var
 openlist [public] : array [STDIN..MAXOPEN] of ioblock; { open files }
 outpflag [public] : outptype;
 parmtop  [public] : parmptr;
 parmcnt  [public] : integer;
 parmcur : parmptr;
 sortptr : parmptr;
 f	 : filedesc;
 errx	 : word;
 i,j,l	 : integer;
 fname	 : lstring(MAXFN);
 parms	 : lstring(255);
 oneparm : string;
 c	 : character;
 inarg	 : boolean;
 sparg	 : boolean;

{ pcompare -- compare two argument strings, return -1 if str1 < str2, }
{	      0 if equal, and 1 if str1 > str2. 		      }
function pcompare (const str1: superst; const str2: string) : integer;
var
 i : integer;
begin
 i := 1;
 while (str1[i] = str2[i]) and (str1[i] <> ENDSTR) do
  i := i + 1;
 if	 str1[i] < str2[i] then pcompare := -1
 else if str1[i] = str2[i] then pcompare := 0
 else pcompare := 1;
end;

{ routine to add an argument to the parameter linked list }
{ note: if sortflg is TRUE, then argument is put into list in sorted   }
{ order, starting somewhere after sortptr.			       }
procedure addarg(const arg: string; len: integer; var sortptr: parmptr;
		 sortflg : boolean);
Label
    Add_at_end, All_done;
var
 parmnew : parmptr;
 parmp	 : parmstr;
 mm	 : integer;
 pp,pl	 : parmptr;
begin
 new(parmnew);
 new(parmp,len);
 for mm := 1 to len do parmp^[mm] := arg[mm];
 parmnew^.parm := parmp;
 if parmcur = NIL then begin
  parmtop := parmnew;
  goto Add_at_end;
  end;
 if (not sortflg) then goto Add_at_end;
 { insert arg in sorted order somewhere }
 pl := sortptr;
 if pl = NIL then pp := parmtop else pp := pl^.next;
 while pp <> NIL do begin
   if pcompare(pp^.parm^, arg) < 0 then begin
     pl := pp;
     pp := pl^.next;
     cycle;
     end;
   if pl = NIL then begin { insert at top }
     parmtop := parmnew;
     parmnew^.next := pp;
     goto All_done;
     end
   else begin		 { insert in middle }
     pl^.next := parmnew;
     parmnew^.next := pp;
     goto All_done;
     end;
   end;
Add_at_End:
 parmcur^.next := parmnew;
 parmcur := parmnew;
 parmcur^.next := NIL;
All_done:
 parmcnt := parmcnt + 1;
 if parmcnt > MAXARGS then error('Too many arguments');
end;

{ routine to expand a special character type argument into a set of }
{ filenames that match.  We will use the DOS search ability, rather }
{ than general pattern matching routines, in the interest of speed  }
{ and memory and complexity.					    }
procedure expparm(var farg : string);
const
 upcaseA = LETA - 32;
 upcaseZ = LETZ - 32;
var
 fin,fout : dosfcb;
 ii,jj	  : integer;
 func	  : integer;
 filenm   : string;
begin
 sortptr := parmcur;
 { build pattern for getfcb routine }
 fin.fn := '        ';
 fin.ft := '   ';
 ii := 1;
 { start with disk letter }
 fin.dr := 0;
 if farg[2] = COLON then begin
  if farg[1] in [upcaseA..upcaseZ] then farg[1] := farg[1] + 32;
  if (not (farg[1] in [LETA..LETZ])) then
   error('Invalid command line filename disk letter')
  else
   fin.dr := wrd(farg[1] - 96);
  ii :=  3;
 end;
 { now do filename }
 if farg[ii] = PERIOD then
  fin.fn := '????????'
 else begin
  jj := 1;
  while (not (farg[ii] in [PERIOD,ENDSTR])) do begin
   if jj > 8 then error('Invalid command line filename');
   if farg[ii] = STAR then
    while (jj <= 8) do begin fin.fn[jj] := '?'; jj := jj + 1; end
   else begin
    fin.fn[jj] := chr(farg[ii]);
    jj := jj + 1;
   end;
   ii := ii + 1;
  end;
 end;
 { and finally do filetype }
 if (farg[ii] = PERIOD) then ii := ii + 1;
 if (farg[ii] = ENDSTR) then
  fin.ft := '???'
 else begin
  jj := 1;
  while (farg[ii] <> ENDSTR) do begin
   if jj > 3 then error('Invalid command line filetype');
   if farg[ii] = STAR then
    while (jj <= 3) do begin fin.ft[jj] := '?'; jj := jj + 1; end
   else begin
    fin.ft[jj] := chr(farg[ii]);
    jj := jj + 1;
   end;
   ii := ii + 1;
  end;
 end;
 { ok, we got a pattern into 'fin', now call getfcb as long as we can }
 func := 1;
 while (getfcb(fin, fout, func)) do begin
  func := 2;
  ii := 0;
  if fin.dr <> 0 then begin
   filenm[ii+1] := ord(fout.dr) + 96;  {lower case}
   filenm[ii+2] := COLON;
   ii := 2;
  end;
  jj := 1;
  while (jj <= 8) and (fout.fn[jj] <> ' ') do begin
   ii := ii + 1;
   filenm[ii] := ord(fout.fn[jj]);
   if (filenm[ii] in [ord('A')..ord('Z')]) then filenm[ii] := filenm[ii]+32;
   jj := jj + 1;
  end;
  if fout.ft[1] <> ' ' then begin
   ii := ii + 1;
   filenm[ii] := PERIOD;
  end;
  jj := 1;
  while (jj <= 3) and (fout.ft[jj] <> ' ') do begin
   ii := ii + 1;
   filenm[ii] := ord(fout.ft[jj]);
   if (filenm[ii] in [ord('A')..ord('Z')]) then filenm[ii] := filenm[ii]+32;
   jj := jj + 1;
  end;
  { now add the argument to the list }
  ii := ii + 1;
  filenm[ii] := ENDSTR;
  addarg(filenm,ii,sortptr,TRUE);
 end;
end;

begin
 outpflag := STDCONS;

 new(openlist[STDIN].buf);
 new(openlist[STDOUT].buf);
 new(openlist[STDERR].buf);
 openlist[STDIN].buf^ := NULL;
 openlist[STDOUT].buf^ := NULL;
 openlist[STDERR].buf^ := NULL;
 openlist[STDIN].mode := IOREAD;
 openlist[STDOUT].mode := IOWRITE;
 openlist[STDERR].mode := IOWRITE;
 openlist[STDIN].cpos := 0;
 openlist[STDERR].cpos := 0;
 openlist[STDERR].cpos := 0;

 new(openlist[STDERR].filevar);
 assign(openlist[STDERR].filevar^,'USER');
 rewrite(openlist[STDERR].filevar^);

 for f := STDERR+1 to MAXOPEN do
  openlist[f].mode := IOAVAIL;

{ initialize parmstrg, and perform any redirection of i/o }
{ also, if we find a parm with an * or ? in it, and not in quotes or }
{ preceded by a \, we will expand it to all filenames that match.    }
{ SPECIAL DOS 2.0 NOTE:
{ Redirection will be done by DOS, and not this routine, since we will }
{ never see a > or < character.  Also, we will not see a \ character,  }
{ so escaped characters must be surrounded by quotes.		       }
 errx := PPMUQQ(0, adr NULL, parms);
 parms[0] := chr(ord(parms[0])+1);     {stick ENDSTR on end to ease scan}
 parms[ord(parms[0])] := chr(ENDSTR);
 parmtop := NIL;
 parmcur := NIL;
 parmcnt := 0;
 i := 1;			{current pos in parms}
 while (parms[i] in [' ']) do   {skip any leading blanks}
  i := i + 1;
 j := 0;			{current pos in oneparm}
 inarg := FALSE;  {flag says if we are in middle of arg or not}
 sparg := FALSE;  {flag says if we found a special char in current arg}
 c := ord(parms[i]);
 while (c <> ENDSTR) do begin
  if (j >= MAXSTR) then error('Command line argument too large');
  c := ord(parms[i]);
  case c of
  BLANK,TAB,ENDSTR: begin
   if inarg then begin
    j := j + 1;
    oneparm[j] := ENDSTR;
    if sparg then
     expparm(oneparm)
    else
     addarg(oneparm,j,sortptr,FALSE)
   end;
   j := 0;
   inarg := FALSE;
   sparg := FALSE;
   end;
  BACKSLASH: begin  {just pass following char without interpreting it}
   i := i + 1;
   if (parms[i] = chr(ENDSTR)) then goto err;
   j := j + 1;
   oneparm[j] := ord(parms[i]);
   inarg := TRUE;
   end;
  SQUOTE,DQUOTE: begin {whole string of stuff is escaped}
   i := i + 1;
   if (parms[i] = chr(c)) then begin
    j := j + 1;
    oneparm[j] := c;
    end
   else
    while (parms[i] <> chr(c)) do begin
     if (parms[i] = chr(ENDSTR)) then goto err;
     j := j + 1;
     oneparm[j] := ord(parms[i]);
     i := i + 1;
    end;
   inarg := TRUE;
   end;
  LBRACE,RBRACE: begin
   if inarg then goto normchar;  {forget it if not leading character}
   i := i + 1;
   if (ord(parms[i]) in [BLANK,TAB,ENDSTR]) then
    error('Re-direction syntax error');
   l := 0;
   while (not (ord(parms[i]) in [BLANK,TAB,ENDSTR])) do begin
    l := l + 1;
    fname[l] := parms[i];
    i := i + 1;
   end;
   fname[0] := chr(l);
   if c = LBRACE then begin
    close (input);
    assign(input, fname);
    reset (input);
    end
   else begin
    close (output);
    assign(output, fname);
    rewrite(output);
    for l := 1 to ord(fname[0]) do {convert to lower case for compares}
     if (fname[l] in ['A'..'Z'])
      then fname[l] := chr(ord(fname[l]) + 32);
    fname[0] := chr(3);
    if (fname = 'lpt') or (fname = 'prn') then
     outpflag := STDPRT
    else if (fname <> 'con') then
     outpflag := STDFILE;
    end;
   end;
  STAR,QUESTION: begin {special expand characters found}
   sparg := TRUE;
   goto normchar;
   end;
  OTHERWISE
normchar:
   inarg := TRUE;
   j := j + 1;
   oneparm[j] := c;
  end; {of case, that is}
  i := i + 1;
 end; {of while}
 return;

 err: error('Command line syntax error');
end;

END.
-h- message.pr 373
{$debug-}
MODULE MMESSAGE;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'putcf.dcl'}

{ message (PC) - write message to terminal and return }
{ note: string is not terminated by normal ENDSTR delimiter }
procedure message (const s : lstring);
var
 i : integer;
begin
 for i := 1 to ord(s[0]) do putcf(ord(s[i]),STDERR);
 putcf(NEWLINE,STDERR);
end;

END.
-h- nargs.pr 243
{$debug-}
MODULE MNARGS;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ nargs (PC) -- return number of arguments }
function nargs : integer;
var
 parmcnt [extern] : integer;
begin
 { this is a hard one }
 nargs := parmcnt;
end;

END.
-h- open.pr 1122
{$debug-}
MODULE MOPEN;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ open (PC) -- open a file for reading or writing }
function open (var name : sstring; xmode : integer) : filedesc;
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
 i : integer;
 intname :packed array[1..MAXFN] of char;
 found : boolean;
begin
 i := 1;
 while (name[i] <> ENDSTR) do begin
  intname[i] := chr(name[i]);
  i := i + 1
 end;
 for i := i to MAXFN do
  intname[i] := ' '; { pad name with blanks }
 { find a free slot in openlist }
 open := IOERROR;
 found := false;
 i := 1;
 while (i <= MAXOPEN) and (not found) do begin
  if (openlist[i].mode = IOAVAIL) then with openlist[i] do begin
   mode := xmode;
   cpos := 0;
   new(buf);
   buf^ := NULL;
   new(filevar);
   filevar^.trap := TRUE;  {catch file open failure}
   assign(filevar^, intname);
   if (mode = IOREAD) then
    reset(filevar^)
   else
    rewrite(filevar^);
   open := i;
   found := true;
   if filevar^.errs <> 0 then open := IOERROR;
   filevar^.trap := FALSE; {reset so we will exit on i/o error}
  end;
  i := i + 1
 end
end;

END.
-h- putc.pr 649
{$debug-}
MODULE MPUTC;

{$include:'globcons.inc'}
  MAXLLEN = 100;
{$include:'globtyps.inc'}
{$include:'flush.dcl'}

{ putc (PC) -- put one character on standard output }
{ This is a fast version which actually buffers the character until a }
{ newline character is received }

procedure putc (c : character);
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
begin
 with openlist[STDOUT] do begin
  if c = NEWLINE then begin
   writeln(buf^);
   buf^ := NULL;
  end
  else begin
   buf^[0] := chr(ord(buf^[0]) + 1);
   buf^[ord(buf^[0])] := chr(c);
   if ord(buf^[0]) > MAXLLEN then flush(STDOUT);
  end;
 end;
end;

END.
-h- putcf.pr 618
{$debug-}
MODULE MPUTCF;

{$include:'globcons.inc'}
  MAXLLEN = 100;
{$include:'globtyps.inc'}
{$include:'putc.dcl'}
{$include:'flush.dcl'}

{ putcf (PC) -- put a single character on file fd }
procedure putcf (c : character; fd : filedesc);
var
 openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
begin
 if (fd = STDOUT) then
  putc(c)
 else with openlist[fd] do begin
  if c = NEWLINE then begin
   writeln(filevar^,buf^);
   buf^ := NULL;
  end
  else begin
   buf^[0] := chr(ord(buf^[0]) + 1);
   buf^[ord(buf^[0])] := chr(c);
   if ord(buf^[0]) > MAXLLEN then flush(fd);
  end;
 end;
end;

END.
-h- putstr.pr 308
{$debug-}
MODULE MPUTSTR;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}
{$include:'putcf.dcl'}

{ putstr (PC) -- put out string on file }
procedure putstr (var s : sstring; f : filedesc);
var
 i : integer;
begin
 i := 1;
 while (s[i] <> ENDSTR) do begin
  putcf(s[i], f);
  i := i + 1
 end
end;

END.
-h- remove.pr 532
{$debug-}
MODULE MREMOVE;

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{ remove (PC) -- remove file s from file system }
procedure remove (var name : sstring);
var
 discfil : text;
 i : integer;
 intname : packed array [1..MAXFN] of char;
begin
 i := 1;
 while (name[i] <> ENDSTR) do begin
  intname[i] := chr(name[i]);
  i := i + 1;
 end;
 for i := i to MAXFN do
  intname[i] := ' ';  { pad name with blanks }
 { open file, so we can discard it }
 assign(discfil, intname);
 reset (discfil);
 discard(discfil);
end;

END.